Branch data Line data Source code
1 : : /* Implementation of Fortran 2003 Polymorphism.
2 : : Copyright (C) 2009-2024 Free Software Foundation, Inc.
3 : : Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
4 : : and Janus Weil <janus@gcc.gnu.org>
5 : :
6 : : This file is part of GCC.
7 : :
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
11 : : version.
12 : :
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
16 : : for more details.
17 : :
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/>. */
21 : :
22 : :
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. */
26 : :
27 : :
28 : : /* Outline of the internal representation:
29 : :
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.
36 : :
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
41 : : '_data'.
42 : :
43 : : For each derived type we set up a "vtable" entry, i.e. a structure with the
44 : : following fields:
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.
54 : :
55 : : After these follow procedure pointer components for the specific
56 : : type-bound procedures. */
57 : :
58 : :
59 : : #include "config.h"
60 : : #include "system.h"
61 : : #include "coretypes.h"
62 : : #include "gfortran.h"
63 : : #include "constructor.h"
64 : : #include "target-memory.h"
65 : :
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. */
73 : :
74 : : static void
75 : 10772 : insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
76 : : {
77 : 10772 : gfc_ref *new_ref;
78 : 10772 : int wcnt, ecnt;
79 : :
80 : 10772 : gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
81 : :
82 : 10772 : gfc_find_component (ts->u.derived, name, true, true, &new_ref);
83 : :
84 : 10772 : gfc_get_errors (&wcnt, &ecnt);
85 : 10772 : if (ecnt > 0 && !new_ref)
86 : 1 : return;
87 : 10771 : gcc_assert (new_ref->u.c.component);
88 : :
89 : 10771 : while (new_ref->next)
90 : 0 : new_ref = new_ref->next;
91 : 10771 : new_ref->next = *ref;
92 : :
93 : 10771 : if (new_ref->next)
94 : : {
95 : 10771 : gfc_ref *next = NULL;
96 : :
97 : : /* We need to update the base type in the trailing reference chain to
98 : : that of the new component. */
99 : :
100 : 10771 : gcc_assert (strcmp (name, "_data") == 0);
101 : :
102 : 10771 : if (new_ref->next->type == REF_COMPONENT)
103 : : next = new_ref->next;
104 : 10326 : else if (new_ref->next->type == REF_ARRAY
105 : 10326 : && new_ref->next->next
106 : 1970 : && new_ref->next->next->type == REF_COMPONENT)
107 : : next = new_ref->next->next;
108 : :
109 : 2346 : if (next != NULL)
110 : : {
111 : 2346 : gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
112 : : || new_ref->u.c.component->ts.type == BT_DERIVED);
113 : 2346 : next->u.c.sym = new_ref->u.c.component->ts.u.derived;
114 : : }
115 : : }
116 : :
117 : 10771 : *ref = new_ref;
118 : : }
119 : :
120 : :
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,
124 : : not a subobject. */
125 : :
126 : : static bool
127 : 1149628 : class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
128 : : {
129 : : /* Only class containers may need the "_data" reference. */
130 : 1149628 : if (ts->type != BT_CLASS)
131 : : return false;
132 : :
133 : : /* Accessing a class container with an array reference is certainly wrong. */
134 : 100115 : if (ref->type != REF_COMPONENT)
135 : : return true;
136 : :
137 : : /* Accessing the class container's fields is fine. */
138 : 89788 : if (ref->u.c.component->name[0] == '_')
139 : : return false;
140 : :
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 : 12439 : if (first_ref_in_chain && ts->u.derived->attr.extension)
154 : 11994 : return false;
155 : :
156 : : /* We have a class container with a non class container's field component
157 : : reference that doesn't fall into the above. */
158 : : return true;
159 : : }
160 : :
161 : :
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. */
166 : :
167 : : void
168 : 3500076 : gfc_fix_class_refs (gfc_expr *e)
169 : : {
170 : 3500076 : gfc_typespec *ts;
171 : 3500076 : gfc_ref **ref;
172 : :
173 : 3500076 : if ((e->expr_type != EXPR_VARIABLE
174 : 1688031 : && e->expr_type != EXPR_FUNCTION)
175 : 2088899 : || (e->expr_type == EXPR_FUNCTION
176 : 276854 : && e->value.function.isym != NULL))
177 : : return;
178 : :
179 : 1860343 : if (e->expr_type == EXPR_VARIABLE)
180 : 1812045 : ts = &e->symtree->n.sym->ts;
181 : : else
182 : : {
183 : 48298 : gfc_symbol *func;
184 : :
185 : 48298 : gcc_assert (e->expr_type == EXPR_FUNCTION);
186 : 48298 : if (e->value.function.esym != NULL)
187 : : func = e->value.function.esym;
188 : : else
189 : 1425 : func = e->symtree->n.sym;
190 : :
191 : 48298 : if (func->result != NULL)
192 : 47184 : ts = &func->result->ts;
193 : : else
194 : 1114 : ts = &func->ts;
195 : : }
196 : :
197 : 3009971 : for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
198 : : {
199 : 1149628 : if (class_data_ref_missing (ts, *ref, ref == &e->ref))
200 : 10772 : insert_component_ref (ts, ref, "_data");
201 : :
202 : 1149628 : if ((*ref)->type == REF_COMPONENT)
203 : 226957 : ts = &(*ref)->u.c.component->ts;
204 : : }
205 : : }
206 : :
207 : :
208 : : /* Insert a reference to the component of the given name.
209 : : Only to be used with CLASS containers and vtables. */
210 : :
211 : : void
212 : 56679 : gfc_add_component_ref (gfc_expr *e, const char *name)
213 : : {
214 : 56679 : gfc_component *c;
215 : 56679 : gfc_ref **tail = &(e->ref);
216 : 56679 : gfc_ref *ref, *next = NULL;
217 : 56679 : gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
218 : 80622 : while (*tail != NULL)
219 : : {
220 : 38081 : if ((*tail)->type == REF_COMPONENT)
221 : : {
222 : 23169 : if (strcmp ((*tail)->u.c.component->name, "_data") == 0
223 : 1322 : && (*tail)->next
224 : 1322 : && (*tail)->next->type == REF_ARRAY
225 : 1238 : && (*tail)->next->next == NULL)
226 : : return;
227 : 22189 : derived = (*tail)->u.c.component->ts.u.derived;
228 : : }
229 : 37101 : if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
230 : : break;
231 : 23943 : tail = &((*tail)->next);
232 : : }
233 : 55699 : if (derived && derived->components && derived->components->next &&
234 : 55693 : derived->components->next->ts.type == BT_DERIVED &&
235 : 43100 : derived->components->next->ts.u.derived == NULL)
236 : : {
237 : : /* Fix up missing vtype. */
238 : 19 : gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
239 : 19 : gcc_assert (vtab);
240 : 19 : derived->components->next->ts.u.derived = vtab->ts.u.derived;
241 : : }
242 : 55699 : if (*tail != NULL && strcmp (name, "_data") == 0)
243 : : next = *tail;
244 : : else
245 : : /* Avoid losing memory. */
246 : 48113 : gfc_free_ref_list (*tail);
247 : 55699 : c = gfc_find_component (derived, name, true, true, tail);
248 : :
249 : 55699 : if (c) {
250 : 55692 : for (ref = *tail; ref->next; ref = ref->next)
251 : : ;
252 : 55692 : ref->next = next;
253 : 55692 : if (!next)
254 : 48106 : e->ts = c->ts;
255 : : }
256 : : }
257 : :
258 : :
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. */
262 : :
263 : : void
264 : 4594 : gfc_add_class_array_ref (gfc_expr *e)
265 : : {
266 : 4594 : int rank = CLASS_DATA (e)->as->rank;
267 : 4594 : int corank = CLASS_DATA (e)->as->corank;
268 : 4594 : gfc_array_spec *as = CLASS_DATA (e)->as;
269 : 4594 : gfc_ref *ref = NULL;
270 : 4594 : gfc_add_data_component (e);
271 : 4594 : e->rank = rank;
272 : 4594 : e->corank = corank;
273 : 8789 : for (ref = e->ref; ref; ref = ref->next)
274 : 8789 : if (!ref->next)
275 : : break;
276 : 4594 : if (ref->type != REF_ARRAY)
277 : : {
278 : 1091 : ref->next = gfc_get_ref ();
279 : 1091 : ref = ref->next;
280 : 1091 : ref->type = REF_ARRAY;
281 : 1091 : ref->u.ar.type = AR_FULL;
282 : 1091 : ref->u.ar.as = as;
283 : : }
284 : 4594 : }
285 : :
286 : :
287 : : /* Unfortunately, class array expressions can appear in various conditions;
288 : : with and without both _data component and an arrayspec. This function
289 : : deals with that variability. The previous reference to 'ref' is to a
290 : : class array. */
291 : :
292 : : static bool
293 : 6838 : class_array_ref_detected (gfc_ref *ref, bool *full_array)
294 : : {
295 : 6838 : bool no_data = false;
296 : 6838 : bool with_data = false;
297 : :
298 : : /* An array reference with no _data component. */
299 : 6838 : if (ref && ref->type == REF_ARRAY
300 : 444 : && !ref->next
301 : 444 : && ref->u.ar.type != AR_ELEMENT)
302 : : {
303 : 444 : if (full_array)
304 : 444 : *full_array = ref->u.ar.type == AR_FULL;
305 : 444 : no_data = true;
306 : : }
307 : :
308 : : /* Cover cases where _data appears, with or without an array ref. */
309 : 7257 : if (ref && ref->type == REF_COMPONENT
310 : 6369 : && strcmp (ref->u.c.component->name, "_data") == 0)
311 : : {
312 : 6363 : if (!ref->next)
313 : : {
314 : 0 : with_data = true;
315 : 0 : if (full_array)
316 : 0 : *full_array = true;
317 : : }
318 : 6363 : else if (ref->next && ref->next->type == REF_ARRAY
319 : : && ref->type == REF_COMPONENT
320 : 6363 : && ref->next->u.ar.type != AR_ELEMENT)
321 : : {
322 : 6135 : with_data = true;
323 : 6135 : if (full_array)
324 : 2715 : *full_array = ref->next->u.ar.type == AR_FULL;
325 : : }
326 : : }
327 : :
328 : 6838 : return no_data || with_data;
329 : : }
330 : :
331 : :
332 : : /* Returns true if the expression contains a reference to a class
333 : : array. Notice that class array elements return false. */
334 : :
335 : : bool
336 : 252782 : gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
337 : : {
338 : 252782 : gfc_ref *ref;
339 : :
340 : 252782 : if (!e->rank)
341 : : return false;
342 : :
343 : 219794 : if (full_array)
344 : 3183 : *full_array= false;
345 : :
346 : : /* Is this a class array object? ie. Is the symbol of type class? */
347 : 219794 : if (e->symtree
348 : 178178 : && e->symtree->n.sym->ts.type == BT_CLASS
349 : 6630 : && CLASS_DATA (e->symtree->n.sym)
350 : 6630 : && CLASS_DATA (e->symtree->n.sym)->attr.dimension
351 : 225618 : && class_array_ref_detected (e->ref, full_array))
352 : : return true;
353 : :
354 : : /* Or is this a class array component reference? */
355 : 390830 : for (ref = e->ref; ref; ref = ref->next)
356 : : {
357 : 177615 : if (ref->type == REF_COMPONENT
358 : 14481 : && ref->u.c.component->ts.type == BT_CLASS
359 : 1076 : && CLASS_DATA (ref->u.c.component)->attr.dimension
360 : 178629 : && class_array_ref_detected (ref->next, full_array))
361 : : return true;
362 : : }
363 : :
364 : : return false;
365 : : }
366 : :
367 : :
368 : : /* Returns true if the expression is a reference to a class
369 : : scalar. This function is necessary because such expressions
370 : : can be dressed with a reference to the _data component and so
371 : : have a type other than BT_CLASS. */
372 : :
373 : : bool
374 : 43236 : gfc_is_class_scalar_expr (gfc_expr *e)
375 : : {
376 : 43236 : gfc_ref *ref;
377 : :
378 : 43236 : if (e->rank)
379 : : return false;
380 : :
381 : : /* Is this a class object? */
382 : 36750 : if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS
383 : 1938 : && CLASS_DATA (e->symtree->n.sym)
384 : 1938 : && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
385 : 1692 : && (e->ref == NULL
386 : 1297 : || (e->ref->type == REF_COMPONENT
387 : 1295 : && strcmp (e->ref->u.c.component->name, "_data") == 0
388 : 998 : && (e->ref->next == NULL
389 : 31 : || (e->ref->next->type == REF_ARRAY
390 : 31 : && e->ref->next->u.ar.codimen > 0
391 : 31 : && e->ref->next->u.ar.dimen == 0
392 : 31 : && e->ref->next->next == NULL)))))
393 : : return true;
394 : :
395 : : /* Or is the final reference BT_CLASS or _data? */
396 : 37896 : for (ref = e->ref; ref; ref = ref->next)
397 : : {
398 : 2988 : if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS
399 : 565 : && CLASS_DATA (ref->u.c.component)
400 : 565 : && !CLASS_DATA (ref->u.c.component)->attr.dimension
401 : 499 : && (ref->next == NULL
402 : 367 : || (ref->next->type == REF_COMPONENT
403 : 365 : && strcmp (ref->next->u.c.component->name, "_data") == 0
404 : 365 : && (ref->next->next == NULL
405 : 42 : || (ref->next->next->type == REF_ARRAY
406 : 6 : && ref->next->next->u.ar.codimen > 0
407 : 6 : && ref->next->next->u.ar.dimen == 0
408 : 6 : && ref->next->next->next == NULL)))))
409 : : return true;
410 : : }
411 : :
412 : : return false;
413 : : }
414 : :
415 : :
416 : : /* Tells whether the expression E is a reference to a (scalar) class container.
417 : : Scalar because array class containers usually have an array reference after
418 : : them, and gfc_fix_class_refs will add the missing "_data" component reference
419 : : in that case. */
420 : :
421 : : bool
422 : 1262 : gfc_is_class_container_ref (gfc_expr *e)
423 : : {
424 : 1262 : gfc_ref *ref;
425 : 1262 : bool result;
426 : :
427 : 1262 : if (e->expr_type != EXPR_VARIABLE)
428 : 152 : return e->ts.type == BT_CLASS;
429 : :
430 : 1110 : if (e->symtree->n.sym->ts.type == BT_CLASS)
431 : : result = true;
432 : : else
433 : 888 : result = false;
434 : :
435 : 2409 : for (ref = e->ref; ref; ref = ref->next)
436 : : {
437 : 1299 : if (ref->type != REF_COMPONENT)
438 : : result = false;
439 : 289 : else if (ref->u.c.component->ts.type == BT_CLASS)
440 : : result = true;
441 : : else
442 : 1299 : result = false;
443 : : }
444 : :
445 : : return result;
446 : : }
447 : :
448 : :
449 : : /* Build an initializer for CLASS pointers,
450 : : initializing the _data component to the init_expr (or NULL) and the _vptr
451 : : component to the corresponding type (or the declared type, given by ts). */
452 : :
453 : : gfc_expr *
454 : 3226 : gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
455 : : {
456 : 3226 : gfc_expr *init;
457 : 3226 : gfc_component *comp;
458 : 3226 : gfc_symbol *vtab = NULL;
459 : :
460 : 3226 : if (init_expr && init_expr->expr_type != EXPR_NULL)
461 : 1588 : vtab = gfc_find_vtab (&init_expr->ts);
462 : : else
463 : 1638 : vtab = gfc_find_vtab (ts);
464 : :
465 : 6452 : init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
466 : 3226 : &ts->u.derived->declared_at);
467 : 3226 : init->ts = *ts;
468 : :
469 : 10140 : for (comp = ts->u.derived->components; comp; comp = comp->next)
470 : : {
471 : 6914 : gfc_constructor *ctor = gfc_constructor_get();
472 : 6914 : if (strcmp (comp->name, "_vptr") == 0 && vtab)
473 : 3226 : ctor->expr = gfc_lval_expr_from_sym (vtab);
474 : 3688 : else if (init_expr && init_expr->expr_type != EXPR_NULL)
475 : 1810 : ctor->expr = gfc_copy_expr (init_expr);
476 : : else
477 : 1878 : ctor->expr = gfc_get_null_expr (NULL);
478 : 6914 : gfc_constructor_append (&init->value.constructor, ctor);
479 : : }
480 : :
481 : 3226 : return init;
482 : : }
483 : :
484 : :
485 : : /* Create a unique string identifier for a derived type, composed of its name
486 : : and module name. This is used to construct unique names for the class
487 : : containers and vtab symbols. */
488 : :
489 : : static char *
490 : 97482 : get_unique_type_string (gfc_symbol *derived)
491 : : {
492 : 97482 : const char *dt_name;
493 : 97482 : char *string;
494 : 97482 : size_t len;
495 : 97482 : if (derived->attr.unlimited_polymorphic)
496 : : dt_name = "STAR";
497 : : else
498 : 90887 : dt_name = gfc_dt_upper_string (derived->name);
499 : 97482 : len = strlen (dt_name) + 2;
500 : 97482 : if (derived->attr.unlimited_polymorphic)
501 : : {
502 : 6595 : string = XNEWVEC (char, len);
503 : 6595 : sprintf (string, "_%s", dt_name);
504 : : }
505 : 90887 : else if (derived->module)
506 : : {
507 : 35806 : string = XNEWVEC (char, strlen (derived->module) + len);
508 : 35806 : sprintf (string, "%s_%s", derived->module, dt_name);
509 : : }
510 : 55081 : else if (derived->ns->proc_name)
511 : : {
512 : 54289 : string = XNEWVEC (char, strlen (derived->ns->proc_name->name) + len);
513 : 54289 : sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
514 : : }
515 : : else
516 : : {
517 : 792 : string = XNEWVEC (char, len);
518 : 792 : sprintf (string, "_%s", dt_name);
519 : : }
520 : 97482 : return string;
521 : : }
522 : :
523 : :
524 : : /* A relative of 'get_unique_type_string' which makes sure the generated
525 : : string will not be too long (replacing it by a hash string if needed). */
526 : :
527 : : static void
528 : 84104 : get_unique_hashed_string (char *string, gfc_symbol *derived)
529 : : {
530 : : /* Provide sufficient space to hold "symbol.symbol_symbol". */
531 : 84104 : char *tmp;
532 : 84104 : tmp = get_unique_type_string (derived);
533 : : /* If string is too long, use hash value in hex representation (allow for
534 : : extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
535 : : We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
536 : : where %d is the (co)rank which can be up to n = 15. */
537 : 84104 : if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
538 : : {
539 : 133 : int h = gfc_hash_value (derived);
540 : 133 : sprintf (string, "%X", h);
541 : : }
542 : : else
543 : 83971 : strcpy (string, tmp);
544 : 84104 : free (tmp);
545 : 84104 : }
546 : :
547 : :
548 : : /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
549 : :
550 : : unsigned int
551 : 13378 : gfc_hash_value (gfc_symbol *sym)
552 : : {
553 : 13378 : unsigned int hash = 0;
554 : : /* Provide sufficient space to hold "symbol.symbol_symbol". */
555 : 13378 : char *c;
556 : 13378 : int i, len;
557 : :
558 : 13378 : c = get_unique_type_string (sym);
559 : 13378 : len = strlen (c);
560 : :
561 : 199838 : for (i = 0; i < len; i++)
562 : 186460 : hash = (hash << 6) + (hash << 16) - hash + c[i];
563 : :
564 : 13378 : free (c);
565 : : /* Return the hash but take the modulus for the sake of module read,
566 : : even though this slightly increases the chance of collision. */
567 : 13378 : return (hash % 100000000);
568 : : }
569 : :
570 : :
571 : : /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
572 : :
573 : : unsigned int
574 : 814 : gfc_intrinsic_hash_value (gfc_typespec *ts)
575 : : {
576 : 814 : unsigned int hash = 0;
577 : 814 : const char *c = gfc_typename (ts, true);
578 : 814 : int i, len;
579 : :
580 : 814 : len = strlen (c);
581 : :
582 : 8920 : for (i = 0; i < len; i++)
583 : 8106 : hash = (hash << 6) + (hash << 16) - hash + c[i];
584 : :
585 : : /* Return the hash but take the modulus for the sake of module read,
586 : : even though this slightly increases the chance of collision. */
587 : 814 : return (hash % 100000000);
588 : : }
589 : :
590 : :
591 : : /* Get the _len component from a class/derived object storing a string.
592 : : For unlimited polymorphic entities a ref to the _data component is available
593 : : while a ref to the _len component is needed. This routine traverese the
594 : : ref-chain and strips the last ref to a _data from it replacing it with a
595 : : ref to the _len component. */
596 : :
597 : : gfc_expr *
598 : 367 : gfc_get_len_component (gfc_expr *e, int k)
599 : : {
600 : 367 : gfc_expr *ptr;
601 : 367 : gfc_ref *ref, **last;
602 : :
603 : 367 : ptr = gfc_copy_expr (e);
604 : :
605 : : /* We need to remove the last _data component ref from ptr. */
606 : 367 : last = &(ptr->ref);
607 : 367 : ref = ptr->ref;
608 : 367 : while (ref)
609 : : {
610 : 367 : if (!ref->next
611 : 367 : && ref->type == REF_COMPONENT
612 : 367 : && strcmp ("_data", ref->u.c.component->name)== 0)
613 : : {
614 : 367 : gfc_free_ref_list (ref);
615 : 367 : *last = NULL;
616 : 367 : break;
617 : : }
618 : 0 : last = &(ref->next);
619 : 0 : ref = ref->next;
620 : : }
621 : : /* And replace if with a ref to the _len component. */
622 : 367 : gfc_add_len_component (ptr);
623 : 367 : if (k != ptr->ts.kind)
624 : : {
625 : 367 : gfc_typespec ts;
626 : 367 : gfc_clear_ts (&ts);
627 : 367 : ts.type = BT_INTEGER;
628 : 367 : ts.kind = k;
629 : 367 : gfc_convert_type_warn (ptr, &ts, 2, 0);
630 : : }
631 : 367 : return ptr;
632 : : }
633 : :
634 : :
635 : : /* Build a polymorphic CLASS entity, using the symbol that comes from
636 : : build_sym. A CLASS entity is represented by an encapsulating type,
637 : : which contains the declared type as '_data' component, plus a pointer
638 : : component '_vptr' which determines the dynamic type. When this CLASS
639 : : entity is unlimited polymorphic, then also add a component '_len' to
640 : : store the length of string when that is stored in it. */
641 : : static int ctr = 0;
642 : :
643 : : bool
644 : 12345 : gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
645 : : gfc_array_spec **as)
646 : : {
647 : 12345 : char tname[GFC_MAX_SYMBOL_LEN+1];
648 : 12345 : char *name;
649 : 12345 : gfc_typespec *orig_ts = ts;
650 : 12345 : gfc_symbol *fclass;
651 : 12345 : gfc_symbol *vtab;
652 : 12345 : gfc_component *c;
653 : 12345 : gfc_namespace *ns;
654 : 12345 : int rank;
655 : :
656 : 12345 : gcc_assert (as);
657 : :
658 : : /* We cannot build the class container now. */
659 : 12345 : if (attr->class_ok && (!ts->u.derived || !ts->u.derived->components))
660 : : return false;
661 : :
662 : : /* Class container has already been built with same name. */
663 : 12344 : if (attr->class_ok
664 : 34 : && ts->u.derived->components->attr.dimension >= attr->dimension
665 : 21 : && ts->u.derived->components->attr.codimension >= attr->codimension
666 : 16 : && ts->u.derived->components->attr.class_pointer >= attr->pointer
667 : 10 : && ts->u.derived->components->attr.allocatable >= attr->allocatable)
668 : : return true;
669 : 12343 : if (attr->class_ok)
670 : : {
671 : 33 : attr->dimension |= ts->u.derived->components->attr.dimension;
672 : 33 : attr->codimension |= ts->u.derived->components->attr.codimension;
673 : 33 : attr->pointer |= ts->u.derived->components->attr.class_pointer;
674 : 33 : attr->allocatable |= ts->u.derived->components->attr.allocatable;
675 : 33 : ts = &ts->u.derived->components->ts;
676 : : }
677 : :
678 : 24686 : attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
679 : 12343 : || attr->select_type_temporary || attr->associate_var;
680 : :
681 : 12343 : if (!attr->class_ok)
682 : : /* We cannot build the class container yet. */
683 : : return true;
684 : :
685 : : /* Determine the name of the encapsulating type. */
686 : 12275 : rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
687 : :
688 : 12275 : if (!ts->u.derived)
689 : : return false;
690 : :
691 : 12270 : get_unique_hashed_string (tname, ts->u.derived);
692 : 12270 : if ((*as) && attr->allocatable)
693 : 1947 : name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
694 : 10323 : else if ((*as) && attr->pointer)
695 : 1145 : name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
696 : 9178 : else if ((*as))
697 : 1125 : name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
698 : 8053 : else if (attr->pointer)
699 : 1709 : name = xasprintf ("__class_%s_p", tname);
700 : 6344 : else if (attr->allocatable)
701 : 2064 : name = xasprintf ("__class_%s_a", tname);
702 : : else
703 : 4280 : name = xasprintf ("__class_%s_t", tname);
704 : :
705 : 12270 : if (ts->u.derived->attr.unlimited_polymorphic)
706 : : {
707 : : /* Find the top-level namespace. */
708 : 4372 : for (ns = gfc_current_ns; ns; ns = ns->parent)
709 : 4372 : if (!ns->parent)
710 : : break;
711 : : }
712 : : else
713 : 9917 : ns = ts->u.derived->ns;
714 : :
715 : : /* Although this might seem to be counterintuitive, we can build separate
716 : : class types with different array specs because the TKR interface checks
717 : : work on the declared type. All array type other than deferred shape or
718 : : assumed rank are added to the function namespace to ensure that they
719 : : are properly distinguished. */
720 : 12270 : if (attr->dummy && (*as)
721 : 1800 : && ((!attr->codimension
722 : 1640 : && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
723 : 1565 : || (attr->codimension
724 : 160 : && !((*as)->cotype == AS_DEFERRED
725 : : || (*as)->cotype == AS_ASSUMED_RANK))))
726 : : {
727 : 328 : char *sname;
728 : 328 : ns = gfc_current_ns;
729 : 328 : gfc_find_symbol (name, ns, 0, &fclass);
730 : : /* If a local class type with this name already exists, update the
731 : : name with an index. */
732 : 328 : if (fclass)
733 : : {
734 : 16 : fclass = NULL;
735 : 16 : sname = xasprintf ("%s_%d", name, ++ctr);
736 : 16 : free (name);
737 : 16 : name = sname;
738 : : }
739 : : }
740 : : else
741 : 11942 : gfc_find_symbol (name, ns, 0, &fclass);
742 : :
743 : 12270 : if (fclass == NULL)
744 : : {
745 : 7426 : gfc_symtree *st;
746 : : /* If not there, create a new symbol. */
747 : 7426 : fclass = gfc_new_symbol (name, ns);
748 : 7426 : st = gfc_new_symtree (&ns->sym_root, name);
749 : 7426 : st->n.sym = fclass;
750 : 7426 : gfc_set_sym_referenced (fclass);
751 : 7426 : fclass->refs++;
752 : 7426 : fclass->ts.type = BT_UNKNOWN;
753 : 7426 : if (!ts->u.derived->attr.unlimited_polymorphic)
754 : 5966 : fclass->attr.abstract = ts->u.derived->attr.abstract;
755 : 7426 : fclass->f2k_derived = gfc_get_namespace (NULL, 0);
756 : 7426 : if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
757 : : &gfc_current_locus))
758 : : return false;
759 : :
760 : : /* Add component '_data'. */
761 : 7426 : if (!gfc_add_component (fclass, "_data", &c))
762 : : return false;
763 : 7426 : c->ts = *ts;
764 : 7426 : c->ts.type = BT_DERIVED;
765 : 7426 : c->attr.access = ACCESS_PRIVATE;
766 : 7426 : c->ts.u.derived = ts->u.derived;
767 : 7426 : c->attr.class_pointer = attr->pointer;
768 : 5805 : c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
769 : 10035 : || attr->select_type_temporary;
770 : 7426 : c->attr.allocatable = attr->allocatable;
771 : 7426 : c->attr.dimension = attr->dimension;
772 : 7426 : c->attr.codimension = attr->codimension;
773 : 7426 : c->attr.abstract = fclass->attr.abstract;
774 : 7426 : c->as = (*as);
775 : 7426 : c->initializer = NULL;
776 : :
777 : : /* Add component '_vptr'. */
778 : 7426 : if (!gfc_add_component (fclass, "_vptr", &c))
779 : : return false;
780 : 7426 : c->ts.type = BT_DERIVED;
781 : 7426 : c->attr.access = ACCESS_PRIVATE;
782 : 7426 : c->attr.pointer = 1;
783 : :
784 : 7426 : if (ts->u.derived->attr.unlimited_polymorphic)
785 : : {
786 : 1460 : vtab = gfc_find_derived_vtab (ts->u.derived);
787 : 1460 : gcc_assert (vtab);
788 : 1460 : c->ts.u.derived = vtab->ts.u.derived;
789 : :
790 : : /* Add component '_len'. Only unlimited polymorphic pointers may
791 : : have a string assigned to them, i.e., only those need the _len
792 : : component. */
793 : 1460 : if (!gfc_add_component (fclass, "_len", &c))
794 : : return false;
795 : 1460 : c->ts.type = BT_INTEGER;
796 : 1460 : c->ts.kind = gfc_charlen_int_kind;
797 : 1460 : c->attr.access = ACCESS_PRIVATE;
798 : 1460 : c->attr.artificial = 1;
799 : : }
800 : : else
801 : : /* Build vtab later. */
802 : 5966 : c->ts.u.derived = NULL;
803 : : }
804 : :
805 : 12270 : if (!ts->u.derived->attr.unlimited_polymorphic)
806 : : {
807 : : /* Since the extension field is 8 bit wide, we can only have
808 : : up to 255 extension levels. */
809 : 9917 : if (ts->u.derived->attr.extension == 255)
810 : : {
811 : 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
812 : : ts->u.derived->name, &ts->u.derived->declared_at);
813 : 0 : return false;
814 : : }
815 : :
816 : 9917 : fclass->attr.extension = ts->u.derived->attr.extension + 1;
817 : 9917 : fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
818 : 9917 : fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
819 : : }
820 : :
821 : 12270 : fclass->attr.is_class = 1;
822 : 12270 : orig_ts->u.derived = fclass;
823 : 12270 : attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
824 : 12270 : (*as) = NULL;
825 : 12270 : free (name);
826 : 12270 : return true;
827 : : }
828 : :
829 : :
830 : : /* Change class, using gfc_build_class_symbol. This is needed for associate
831 : : names, when rank changes or a derived type is produced by resolution. */
832 : :
833 : : void
834 : 109 : gfc_change_class (gfc_typespec *ts, symbol_attribute *sym_attr,
835 : : gfc_array_spec *sym_as, int rank, int corank)
836 : : {
837 : 109 : symbol_attribute attr;
838 : 109 : gfc_component *c;
839 : 109 : gfc_array_spec *as = NULL;
840 : 109 : gfc_symbol *der = ts->u.derived;
841 : :
842 : 109 : ts->type = BT_CLASS;
843 : 109 : attr = *sym_attr;
844 : 109 : attr.class_ok = 0;
845 : 109 : attr.associate_var = 1;
846 : 109 : attr.class_pointer = 1;
847 : 109 : attr.allocatable = 0;
848 : 109 : attr.pointer = 1;
849 : 109 : attr.dimension = rank ? 1 : 0;
850 : 13 : if (rank)
851 : : {
852 : 96 : if (sym_as)
853 : 18 : as = gfc_copy_array_spec (sym_as);
854 : : else
855 : : {
856 : 78 : as = gfc_get_array_spec ();
857 : 78 : as->rank = rank;
858 : 78 : as->type = AS_DEFERRED;
859 : 78 : as->corank = corank;
860 : : }
861 : : }
862 : 109 : if (as && as->corank != 0)
863 : 0 : attr.codimension = 1;
864 : :
865 : 109 : if (!gfc_build_class_symbol (ts, &attr, &as))
866 : 0 : gcc_unreachable ();
867 : :
868 : 109 : gfc_set_sym_referenced (ts->u.derived);
869 : :
870 : : /* Make sure the _vptr is set. */
871 : 109 : c = gfc_find_component (ts->u.derived, "_vptr", true, true, NULL);
872 : 109 : if (c->ts.u.derived == NULL)
873 : 48 : c->ts.u.derived = gfc_find_derived_vtab (der);
874 : : /* _vptr now has the _vtab in it, change it to the _vtype. */
875 : 109 : if (c->ts.u.derived->attr.vtab)
876 : 48 : c->ts.u.derived = c->ts.u.derived->ts.u.derived;
877 : 109 : }
878 : :
879 : :
880 : : /* Add a procedure pointer component to the vtype
881 : : to represent a specific type-bound procedure. */
882 : :
883 : : static void
884 : 4549 : add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
885 : : {
886 : 4549 : gfc_component *c;
887 : 4549 : bool is_abstract = false;
888 : :
889 : 4549 : c = gfc_find_component (vtype, name, true, true, NULL);
890 : :
891 : : /* If the present component typebound proc is abstract, the new version
892 : : should unconditionally be tested if it is a suitable replacement. */
893 : 4549 : if (c && c->tb && c->tb->u.specific
894 : 1305 : && c->tb->u.specific->n.sym->attr.abstract)
895 : 4549 : is_abstract = true;
896 : :
897 : : /* Pass on the new tb being not overridable if a component is found and
898 : : either there is not an overridden specific or the present component
899 : : tb is abstract. This ensures that possible, viable replacements are
900 : : loaded. */
901 : 4549 : if (tb->non_overridable && !tb->overridden && !is_abstract && c)
902 : 7 : return;
903 : :
904 : 4542 : if (c == NULL)
905 : : {
906 : : /* Add procedure component. */
907 : 3226 : if (!gfc_add_component (vtype, name, &c))
908 : : return;
909 : :
910 : 3226 : if (!c->tb)
911 : 3226 : c->tb = XCNEW (gfc_typebound_proc);
912 : 3226 : *c->tb = *tb;
913 : 3226 : c->tb->ppc = 1;
914 : 3226 : c->attr.procedure = 1;
915 : 3226 : c->attr.proc_pointer = 1;
916 : 3226 : c->attr.flavor = FL_PROCEDURE;
917 : 3226 : c->attr.access = ACCESS_PRIVATE;
918 : 3226 : c->attr.external = 1;
919 : 3226 : c->attr.untyped = 1;
920 : 3226 : c->attr.if_source = IFSRC_IFBODY;
921 : : }
922 : 1316 : else if (c->attr.proc_pointer && c->tb)
923 : : {
924 : 1316 : *c->tb = *tb;
925 : 1316 : c->tb->ppc = 1;
926 : : }
927 : :
928 : 4542 : if (tb->u.specific)
929 : : {
930 : 4524 : gfc_symbol *ifc = tb->u.specific->n.sym;
931 : 4524 : c->ts.interface = ifc;
932 : 4524 : if (!tb->deferred)
933 : 3801 : c->initializer = gfc_get_variable_expr (tb->u.specific);
934 : 4524 : c->attr.pure = ifc->attr.pure;
935 : : }
936 : : }
937 : :
938 : :
939 : : /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
940 : :
941 : : static void
942 : 4402 : add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
943 : : {
944 : 4402 : if (!st)
945 : : return;
946 : :
947 : 4402 : if (st->left)
948 : 1124 : add_procs_to_declared_vtab1 (st->left, vtype);
949 : :
950 : 4402 : if (st->right)
951 : 1068 : add_procs_to_declared_vtab1 (st->right, vtype);
952 : :
953 : 4402 : if (st->n.tb && !st->n.tb->error
954 : 4401 : && !st->n.tb->is_generic && st->n.tb->u.specific)
955 : 3757 : add_proc_comp (vtype, st->name, st->n.tb);
956 : : }
957 : :
958 : :
959 : : /* Copy procedure pointers components from the parent type. */
960 : :
961 : : static void
962 : 1421 : copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
963 : : {
964 : 1421 : gfc_component *cmp;
965 : 1421 : gfc_symbol *vtab;
966 : :
967 : 1421 : vtab = gfc_find_derived_vtab (declared);
968 : :
969 : 12196 : for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
970 : : {
971 : 10775 : if (gfc_find_component (vtype, cmp->name, true, true, NULL))
972 : 9983 : continue;
973 : :
974 : 792 : add_proc_comp (vtype, cmp->name, cmp->tb);
975 : : }
976 : 1421 : }
977 : :
978 : :
979 : : /* Returns true if any of its nonpointer nonallocatable components or
980 : : their nonpointer nonallocatable subcomponents has a finalization
981 : : subroutine. */
982 : :
983 : : static bool
984 : 9434 : has_finalizer_component (gfc_symbol *derived)
985 : : {
986 : 9434 : gfc_component *c;
987 : :
988 : 20139 : for (c = derived->components; c; c = c->next)
989 : 10729 : if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
990 : 1855 : && c->attr.flavor != FL_PROCEDURE)
991 : : {
992 : 1849 : if (c->ts.u.derived->f2k_derived
993 : 1753 : && c->ts.u.derived->f2k_derived->finalizers)
994 : : return true;
995 : :
996 : : /* Stop infinite recursion through this function by inhibiting
997 : : calls when the derived type and that of the component are
998 : : the same. */
999 : 1825 : if (!gfc_compare_derived_types (derived, c->ts.u.derived)
1000 : 1825 : && has_finalizer_component (c->ts.u.derived))
1001 : : return true;
1002 : : }
1003 : : return false;
1004 : : }
1005 : :
1006 : :
1007 : : static bool
1008 : 6069 : comp_is_finalizable (gfc_component *comp)
1009 : : {
1010 : 6069 : if (comp->attr.proc_pointer)
1011 : : return false;
1012 : 6015 : else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
1013 : : return true;
1014 : 953 : else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
1015 : 4092 : && (comp->ts.u.derived->attr.alloc_comp
1016 : 413 : || has_finalizer_component (comp->ts.u.derived)
1017 : 413 : || (comp->ts.u.derived->f2k_derived
1018 : 389 : && comp->ts.u.derived->f2k_derived->finalizers)))
1019 : 579 : return true;
1020 : 2610 : else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1021 : 626 : && CLASS_DATA (comp)->attr.allocatable)
1022 : : return true;
1023 : : else
1024 : : return false;
1025 : : }
1026 : :
1027 : :
1028 : : /* Call DEALLOCATE for the passed component if it is allocatable, if it is
1029 : : neither allocatable nor a pointer but has a finalizer, call it. If it
1030 : : is a nonpointer component with allocatable components or has finalizers, walk
1031 : : them. Either of them is required; other nonallocatables and pointers aren't
1032 : : handled gracefully.
1033 : : Note: If the component is allocatable, the DEALLOCATE handling takes care
1034 : : of calling the appropriate finalizers, coarray deregistering, and
1035 : : deallocation of allocatable subcomponents. */
1036 : :
1037 : : static void
1038 : 3085 : finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
1039 : : gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code,
1040 : : gfc_namespace *sub_ns)
1041 : : {
1042 : 3085 : gfc_expr *e;
1043 : 3085 : gfc_ref *ref;
1044 : 3085 : gfc_was_finalized *f;
1045 : :
1046 : 3085 : if (!comp_is_finalizable (comp))
1047 : : return;
1048 : :
1049 : : /* If this expression with this component has been finalized
1050 : : already in this namespace, there is nothing to do. */
1051 : 2754 : for (f = sub_ns->was_finalized; f; f = f->next)
1052 : : {
1053 : 608 : if (f->e == expr && f->c == comp)
1054 : : return;
1055 : : }
1056 : :
1057 : 2146 : e = gfc_copy_expr (expr);
1058 : 2146 : if (!e->ref)
1059 : 1857 : e->ref = ref = gfc_get_ref ();
1060 : : else
1061 : : {
1062 : 374 : for (ref = e->ref; ref->next; ref = ref->next)
1063 : : ;
1064 : 289 : ref->next = gfc_get_ref ();
1065 : 289 : ref = ref->next;
1066 : : }
1067 : 2146 : ref->type = REF_COMPONENT;
1068 : 2146 : ref->u.c.sym = derived;
1069 : 2146 : ref->u.c.component = comp;
1070 : 2146 : e->ts = comp->ts;
1071 : :
1072 : 2146 : if (comp->attr.dimension || comp->attr.codimension
1073 : 1017 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1074 : 326 : && (CLASS_DATA (comp)->attr.dimension
1075 : 326 : || CLASS_DATA (comp)->attr.codimension)))
1076 : : {
1077 : 1248 : ref->next = gfc_get_ref ();
1078 : 1248 : ref->next->type = REF_ARRAY;
1079 : 1248 : ref->next->u.ar.dimen = 0;
1080 : 1248 : ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
1081 : : : comp->as;
1082 : 1248 : e->rank = ref->next->u.ar.as->rank;
1083 : 1248 : e->corank = ref->next->u.ar.as->corank;
1084 : 1265 : ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
1085 : : }
1086 : :
1087 : : /* Call DEALLOCATE (comp, stat=ignore). */
1088 : 2146 : if (comp->attr.allocatable
1089 : 632 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1090 : 326 : && CLASS_DATA (comp)->attr.allocatable))
1091 : : {
1092 : 1840 : gfc_code *dealloc, *block = NULL;
1093 : :
1094 : : /* Add IF (fini_coarray). */
1095 : 1840 : if (comp->attr.codimension
1096 : 1826 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1097 : 326 : && CLASS_DATA (comp)->attr.codimension))
1098 : : {
1099 : 28 : block = gfc_get_code (EXEC_IF);
1100 : 28 : if (*code)
1101 : : {
1102 : 28 : (*code)->next = block;
1103 : 28 : (*code) = (*code)->next;
1104 : : }
1105 : : else
1106 : 0 : (*code) = block;
1107 : :
1108 : 28 : block->block = gfc_get_code (EXEC_IF);
1109 : 28 : block = block->block;
1110 : 28 : block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
1111 : : }
1112 : :
1113 : 1840 : dealloc = gfc_get_code (EXEC_DEALLOCATE);
1114 : :
1115 : 1840 : dealloc->ext.alloc.list = gfc_get_alloc ();
1116 : 1840 : dealloc->ext.alloc.list->expr = e;
1117 : 1840 : dealloc->expr1 = gfc_lval_expr_from_sym (stat);
1118 : :
1119 : 1840 : gfc_code *cond = gfc_get_code (EXEC_IF);
1120 : 1840 : cond->block = gfc_get_code (EXEC_IF);
1121 : 1840 : cond->block->expr1 = gfc_get_expr ();
1122 : 1840 : cond->block->expr1->expr_type = EXPR_FUNCTION;
1123 : 1840 : cond->block->expr1->where = gfc_current_locus;
1124 : 1840 : gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
1125 : 1840 : cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1126 : 1840 : cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
1127 : 1840 : cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
1128 : 1840 : gfc_commit_symbol (cond->block->expr1->symtree->n.sym);
1129 : 1840 : cond->block->expr1->ts.type = BT_LOGICAL;
1130 : 1840 : cond->block->expr1->ts.kind = gfc_default_logical_kind;
1131 : 1840 : cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED);
1132 : 1840 : cond->block->expr1->value.function.actual = gfc_get_actual_arglist ();
1133 : 1840 : cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr);
1134 : 1840 : cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist ();
1135 : 1840 : cond->block->next = dealloc;
1136 : :
1137 : 1840 : if (block)
1138 : 28 : block->next = cond;
1139 : 1812 : else if (*code)
1140 : : {
1141 : 1812 : (*code)->next = cond;
1142 : 1812 : (*code) = (*code)->next;
1143 : : }
1144 : : else
1145 : 0 : (*code) = cond;
1146 : :
1147 : : }
1148 : 306 : else if (comp->ts.type == BT_DERIVED
1149 : 306 : && comp->ts.u.derived->f2k_derived
1150 : 306 : && comp->ts.u.derived->f2k_derived->finalizers)
1151 : : {
1152 : : /* Call FINAL_WRAPPER (comp); */
1153 : 70 : gfc_code *final_wrap;
1154 : 70 : gfc_symbol *vtab, *byte_stride;
1155 : 70 : gfc_expr *scalar, *size_expr, *fini_coarray_expr;
1156 : 70 : gfc_component *c;
1157 : :
1158 : 70 : vtab = gfc_find_derived_vtab (comp->ts.u.derived);
1159 : 420 : for (c = vtab->ts.u.derived->components; c; c = c->next)
1160 : 420 : if (strcmp (c->name, "_final") == 0)
1161 : : break;
1162 : :
1163 : 70 : gcc_assert (c);
1164 : :
1165 : : /* Set scalar argument for storage_size. A leading underscore in
1166 : : the name prevents an unwanted finalization. */
1167 : 70 : gfc_get_symbol ("_comp_byte_stride", sub_ns, &byte_stride);
1168 : 70 : byte_stride->ts = e->ts;
1169 : 70 : byte_stride->attr.flavor = FL_VARIABLE;
1170 : 70 : byte_stride->attr.value = 1;
1171 : 70 : byte_stride->attr.artificial = 1;
1172 : 70 : gfc_set_sym_referenced (byte_stride);
1173 : 70 : gfc_commit_symbol (byte_stride);
1174 : 70 : scalar = gfc_lval_expr_from_sym (byte_stride);
1175 : :
1176 : 70 : final_wrap = gfc_get_code (EXEC_CALL);
1177 : 70 : final_wrap->symtree = c->initializer->symtree;
1178 : 70 : final_wrap->resolved_sym = c->initializer->symtree->n.sym;
1179 : 70 : final_wrap->ext.actual = gfc_get_actual_arglist ();
1180 : 70 : final_wrap->ext.actual->expr = e;
1181 : :
1182 : : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1183 : 70 : size_expr = gfc_get_expr ();
1184 : 70 : size_expr->where = gfc_current_locus;
1185 : 70 : size_expr->expr_type = EXPR_OP;
1186 : 70 : size_expr->value.op.op = INTRINSIC_DIVIDE;
1187 : :
1188 : : /* STORAGE_SIZE (array,kind=c_intptr_t). */
1189 : 70 : size_expr->value.op.op1
1190 : 70 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
1191 : : "storage_size", gfc_current_locus, 2,
1192 : : scalar,
1193 : : gfc_get_int_expr (gfc_index_integer_kind,
1194 : : NULL, 0));
1195 : :
1196 : : /* NUMERIC_STORAGE_SIZE. */
1197 : 70 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
1198 : : gfc_character_storage_size);
1199 : 70 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
1200 : 70 : size_expr->ts = size_expr->value.op.op1->ts;
1201 : :
1202 : : /* Which provides the argument 'byte_stride'..... */
1203 : 70 : final_wrap->ext.actual->next = gfc_get_actual_arglist ();
1204 : 70 : final_wrap->ext.actual->next->expr = size_expr;
1205 : :
1206 : : /* ...and last of all the 'fini_coarray' argument. */
1207 : 70 : fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
1208 : 70 : final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
1209 : 70 : final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
1210 : :
1211 : :
1212 : :
1213 : 70 : if (*code)
1214 : : {
1215 : 70 : (*code)->next = final_wrap;
1216 : 70 : (*code) = (*code)->next;
1217 : : }
1218 : : else
1219 : 0 : (*code) = final_wrap;
1220 : 70 : }
1221 : : else
1222 : : {
1223 : 236 : gfc_component *c;
1224 : :
1225 : 656 : for (c = comp->ts.u.derived->components; c; c = c->next)
1226 : 420 : finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code,
1227 : : sub_ns);
1228 : 236 : gfc_free_expr (e);
1229 : : }
1230 : :
1231 : : /* Record that this was finalized already in this namespace. */
1232 : 2146 : f = sub_ns->was_finalized;
1233 : 2146 : sub_ns->was_finalized = XCNEW (gfc_was_finalized);
1234 : 2146 : sub_ns->was_finalized->e = expr;
1235 : 2146 : sub_ns->was_finalized->c = comp;
1236 : 2146 : sub_ns->was_finalized->next = f;
1237 : : }
1238 : :
1239 : :
1240 : : /* Generate code equivalent to
1241 : : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1242 : : + offset, c_ptr), ptr). */
1243 : :
1244 : : static gfc_code *
1245 : 2067 : finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
1246 : : gfc_expr *offset, gfc_namespace *sub_ns)
1247 : : {
1248 : 2067 : gfc_code *block;
1249 : 2067 : gfc_expr *expr, *expr2;
1250 : :
1251 : : /* C_F_POINTER(). */
1252 : 2067 : block = gfc_get_code (EXEC_CALL);
1253 : 2067 : gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
1254 : 2067 : block->resolved_sym = block->symtree->n.sym;
1255 : 2067 : block->resolved_sym->attr.flavor = FL_PROCEDURE;
1256 : 2067 : block->resolved_sym->attr.intrinsic = 1;
1257 : 2067 : block->resolved_sym->attr.subroutine = 1;
1258 : 2067 : block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
1259 : 2067 : block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
1260 : 2067 : block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
1261 : 2067 : gfc_commit_symbol (block->resolved_sym);
1262 : :
1263 : : /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1264 : 2067 : block->ext.actual = gfc_get_actual_arglist ();
1265 : 2067 : block->ext.actual->next = gfc_get_actual_arglist ();
1266 : 2067 : block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
1267 : : NULL, 0);
1268 : 2067 : block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
1269 : :
1270 : : /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1271 : :
1272 : : /* TRANSFER's first argument: C_LOC (array). */
1273 : 2067 : expr = gfc_get_expr ();
1274 : 2067 : expr->expr_type = EXPR_FUNCTION;
1275 : 2067 : gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
1276 : 2067 : expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1277 : 2067 : expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
1278 : 2067 : expr->symtree->n.sym->attr.intrinsic = 1;
1279 : 2067 : expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
1280 : 2067 : expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
1281 : 2067 : expr->value.function.actual = gfc_get_actual_arglist ();
1282 : 2067 : expr->value.function.actual->expr
1283 : 2067 : = gfc_lval_expr_from_sym (array);
1284 : 2067 : expr->symtree->n.sym->result = expr->symtree->n.sym;
1285 : 2067 : gfc_commit_symbol (expr->symtree->n.sym);
1286 : 2067 : expr->ts.type = BT_INTEGER;
1287 : 2067 : expr->ts.kind = gfc_index_integer_kind;
1288 : 2067 : expr->where = gfc_current_locus;
1289 : :
1290 : : /* TRANSFER. */
1291 : 2067 : expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
1292 : : gfc_current_locus, 3, expr,
1293 : : gfc_get_int_expr (gfc_index_integer_kind,
1294 : : NULL, 0), NULL);
1295 : 2067 : expr2->ts.type = BT_INTEGER;
1296 : 2067 : expr2->ts.kind = gfc_index_integer_kind;
1297 : :
1298 : : /* <array addr> + <offset>. */
1299 : 2067 : block->ext.actual->expr = gfc_get_expr ();
1300 : 2067 : block->ext.actual->expr->expr_type = EXPR_OP;
1301 : 2067 : block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
1302 : 2067 : block->ext.actual->expr->value.op.op1 = expr2;
1303 : 2067 : block->ext.actual->expr->value.op.op2 = offset;
1304 : 2067 : block->ext.actual->expr->ts = expr->ts;
1305 : 2067 : block->ext.actual->expr->where = gfc_current_locus;
1306 : :
1307 : : /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1308 : 2067 : block->ext.actual->next = gfc_get_actual_arglist ();
1309 : 2067 : block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
1310 : 2067 : block->ext.actual->next->next = gfc_get_actual_arglist ();
1311 : :
1312 : 2067 : return block;
1313 : : }
1314 : :
1315 : :
1316 : : /* Calculates the offset to the (idx+1)th element of an array, taking the
1317 : : stride into account. It generates the code:
1318 : : offset = 0
1319 : : do idx2 = 1, rank
1320 : : offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1321 : : end do
1322 : : offset = offset * byte_stride. */
1323 : :
1324 : : static gfc_code*
1325 : 1859 : finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
1326 : : gfc_symbol *strides, gfc_symbol *sizes,
1327 : : gfc_symbol *byte_stride, gfc_expr *rank,
1328 : : gfc_code *block, gfc_namespace *sub_ns)
1329 : : {
1330 : 1859 : gfc_iterator *iter;
1331 : 1859 : gfc_expr *expr, *expr2;
1332 : :
1333 : : /* offset = 0. */
1334 : 1859 : block->next = gfc_get_code (EXEC_ASSIGN);
1335 : 1859 : block = block->next;
1336 : 1859 : block->expr1 = gfc_lval_expr_from_sym (offset);
1337 : 1859 : block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1338 : :
1339 : : /* Create loop. */
1340 : 1859 : iter = gfc_get_iterator ();
1341 : 1859 : iter->var = gfc_lval_expr_from_sym (idx2);
1342 : 1859 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1343 : 1859 : iter->end = gfc_copy_expr (rank);
1344 : 1859 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1345 : 1859 : block->next = gfc_get_code (EXEC_DO);
1346 : 1859 : block = block->next;
1347 : 1859 : block->ext.iterator = iter;
1348 : 1859 : block->block = gfc_get_code (EXEC_DO);
1349 : :
1350 : : /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1351 : : * strides(idx2). */
1352 : :
1353 : : /* mod (idx, sizes(idx2)). */
1354 : 1859 : expr = gfc_lval_expr_from_sym (sizes);
1355 : 1859 : expr->ref = gfc_get_ref ();
1356 : 1859 : expr->ref->type = REF_ARRAY;
1357 : 1859 : expr->ref->u.ar.as = sizes->as;
1358 : 1859 : expr->ref->u.ar.type = AR_ELEMENT;
1359 : 1859 : expr->ref->u.ar.dimen = 1;
1360 : 1859 : expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1361 : 1859 : expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
1362 : 1859 : expr->where = sizes->declared_at;
1363 : :
1364 : 1859 : expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
1365 : : gfc_current_locus, 2,
1366 : : gfc_lval_expr_from_sym (idx), expr);
1367 : 1859 : expr->ts = idx->ts;
1368 : :
1369 : : /* (...) / sizes(idx2-1). */
1370 : 1859 : expr2 = gfc_get_expr ();
1371 : 1859 : expr2->expr_type = EXPR_OP;
1372 : 1859 : expr2->value.op.op = INTRINSIC_DIVIDE;
1373 : 1859 : expr2->value.op.op1 = expr;
1374 : 1859 : expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
1375 : 1859 : expr2->value.op.op2->ref = gfc_get_ref ();
1376 : 1859 : expr2->value.op.op2->ref->type = REF_ARRAY;
1377 : 1859 : expr2->value.op.op2->ref->u.ar.as = sizes->as;
1378 : 1859 : expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1379 : 1859 : expr2->value.op.op2->ref->u.ar.dimen = 1;
1380 : 1859 : expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1381 : 1859 : expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
1382 : 1859 : expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
1383 : 1859 : expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
1384 : 1859 : expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
1385 : 1859 : expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
1386 : 1859 : = gfc_lval_expr_from_sym (idx2);
1387 : 1859 : expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
1388 : 1859 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1389 : 1859 : expr2->value.op.op2->ref->u.ar.start[0]->ts
1390 : 1859 : = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
1391 : 1859 : expr2->ts = idx->ts;
1392 : 1859 : expr2->where = gfc_current_locus;
1393 : :
1394 : : /* ... * strides(idx2). */
1395 : 1859 : expr = gfc_get_expr ();
1396 : 1859 : expr->expr_type = EXPR_OP;
1397 : 1859 : expr->value.op.op = INTRINSIC_TIMES;
1398 : 1859 : expr->value.op.op1 = expr2;
1399 : 1859 : expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
1400 : 1859 : expr->value.op.op2->ref = gfc_get_ref ();
1401 : 1859 : expr->value.op.op2->ref->type = REF_ARRAY;
1402 : 1859 : expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1403 : 1859 : expr->value.op.op2->ref->u.ar.dimen = 1;
1404 : 1859 : expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1405 : 1859 : expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
1406 : 1859 : expr->value.op.op2->ref->u.ar.as = strides->as;
1407 : 1859 : expr->ts = idx->ts;
1408 : 1859 : expr->where = gfc_current_locus;
1409 : :
1410 : : /* offset = offset + ... */
1411 : 1859 : block->block->next = gfc_get_code (EXEC_ASSIGN);
1412 : 1859 : block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
1413 : 1859 : block->block->next->expr2 = gfc_get_expr ();
1414 : 1859 : block->block->next->expr2->expr_type = EXPR_OP;
1415 : 1859 : block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
1416 : 1859 : block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
1417 : 1859 : block->block->next->expr2->value.op.op2 = expr;
1418 : 1859 : block->block->next->expr2->ts = idx->ts;
1419 : 1859 : block->block->next->expr2->where = gfc_current_locus;
1420 : :
1421 : : /* After the loop: offset = offset * byte_stride. */
1422 : 1859 : block->next = gfc_get_code (EXEC_ASSIGN);
1423 : 1859 : block = block->next;
1424 : 1859 : block->expr1 = gfc_lval_expr_from_sym (offset);
1425 : 1859 : block->expr2 = gfc_get_expr ();
1426 : 1859 : block->expr2->expr_type = EXPR_OP;
1427 : 1859 : block->expr2->value.op.op = INTRINSIC_TIMES;
1428 : 1859 : block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
1429 : 1859 : block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
1430 : 1859 : block->expr2->ts = block->expr2->value.op.op1->ts;
1431 : 1859 : block->expr2->where = gfc_current_locus;
1432 : 1859 : return block;
1433 : : }
1434 : :
1435 : :
1436 : : /* Insert code of the following form:
1437 : :
1438 : : block
1439 : : integer(c_intptr_t) :: i
1440 : :
1441 : : if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1442 : : && (is_contiguous || !final_rank3->attr.contiguous
1443 : : || final_rank3->as->type != AS_ASSUMED_SHAPE))
1444 : : || 0 == STORAGE_SIZE (array)) then
1445 : : call final_rank3 (array)
1446 : : else
1447 : : block
1448 : : integer(c_intptr_t) :: offset, j
1449 : : type(t) :: tmp(shape (array))
1450 : :
1451 : : do i = 0, size (array)-1
1452 : : offset = obtain_offset(i, strides, sizes, byte_stride)
1453 : : addr = transfer (c_loc (array), addr) + offset
1454 : : call c_f_pointer (transfer (addr, cptr), ptr)
1455 : :
1456 : : addr = transfer (c_loc (tmp), addr)
1457 : : + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1458 : : call c_f_pointer (transfer (addr, cptr), ptr2)
1459 : : ptr2 = ptr
1460 : : end do
1461 : : call final_rank3 (tmp)
1462 : : end block
1463 : : end if
1464 : : block */
1465 : :
1466 : : static void
1467 : 113 : finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
1468 : : gfc_symbol *array, gfc_symbol *byte_stride,
1469 : : gfc_symbol *idx, gfc_symbol *ptr,
1470 : : gfc_symbol *nelem,
1471 : : gfc_symbol *strides, gfc_symbol *sizes,
1472 : : gfc_symbol *idx2, gfc_symbol *offset,
1473 : : gfc_symbol *is_contiguous, gfc_expr *rank,
1474 : : gfc_namespace *sub_ns)
1475 : : {
1476 : 113 : gfc_symbol *tmp_array, *ptr2;
1477 : 113 : gfc_expr *size_expr, *offset2, *expr;
1478 : 113 : gfc_namespace *ns;
1479 : 113 : gfc_iterator *iter;
1480 : 113 : gfc_code *block2;
1481 : 113 : int i;
1482 : :
1483 : 113 : block->next = gfc_get_code (EXEC_IF);
1484 : 113 : block = block->next;
1485 : :
1486 : 113 : block->block = gfc_get_code (EXEC_IF);
1487 : 113 : block = block->block;
1488 : :
1489 : : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1490 : 113 : size_expr = gfc_get_expr ();
1491 : 113 : size_expr->where = gfc_current_locus;
1492 : 113 : size_expr->expr_type = EXPR_OP;
1493 : 113 : size_expr->value.op.op = INTRINSIC_DIVIDE;
1494 : :
1495 : : /* STORAGE_SIZE (array,kind=c_intptr_t). */
1496 : 113 : size_expr->value.op.op1
1497 : 113 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
1498 : : "storage_size", gfc_current_locus, 2,
1499 : : gfc_lval_expr_from_sym (array),
1500 : : gfc_get_int_expr (gfc_index_integer_kind,
1501 : : NULL, 0));
1502 : :
1503 : : /* NUMERIC_STORAGE_SIZE. */
1504 : 113 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
1505 : : gfc_character_storage_size);
1506 : 113 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
1507 : 113 : size_expr->ts = size_expr->value.op.op1->ts;
1508 : :
1509 : : /* IF condition: (stride == size_expr
1510 : : && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1511 : : || is_contiguous)
1512 : : || 0 == size_expr. */
1513 : 113 : block->expr1 = gfc_get_expr ();
1514 : 113 : block->expr1->ts.type = BT_LOGICAL;
1515 : 113 : block->expr1->ts.kind = gfc_default_logical_kind;
1516 : 113 : block->expr1->expr_type = EXPR_OP;
1517 : 113 : block->expr1->where = gfc_current_locus;
1518 : :
1519 : 113 : block->expr1->value.op.op = INTRINSIC_OR;
1520 : :
1521 : : /* byte_stride == size_expr */
1522 : 113 : expr = gfc_get_expr ();
1523 : 113 : expr->ts.type = BT_LOGICAL;
1524 : 113 : expr->ts.kind = gfc_default_logical_kind;
1525 : 113 : expr->expr_type = EXPR_OP;
1526 : 113 : expr->where = gfc_current_locus;
1527 : 113 : expr->value.op.op = INTRINSIC_EQ;
1528 : 113 : expr->value.op.op1
1529 : 113 : = gfc_lval_expr_from_sym (byte_stride);
1530 : 113 : expr->value.op.op2 = size_expr;
1531 : :
1532 : : /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1533 : : add is_contiguous check. */
1534 : :
1535 : 113 : if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
1536 : 93 : || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
1537 : : {
1538 : 26 : gfc_expr *expr2;
1539 : 26 : expr2 = gfc_get_expr ();
1540 : 26 : expr2->ts.type = BT_LOGICAL;
1541 : 26 : expr2->ts.kind = gfc_default_logical_kind;
1542 : 26 : expr2->expr_type = EXPR_OP;
1543 : 26 : expr2->where = gfc_current_locus;
1544 : 26 : expr2->value.op.op = INTRINSIC_AND;
1545 : 26 : expr2->value.op.op1 = expr;
1546 : 26 : expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
1547 : 26 : expr = expr2;
1548 : : }
1549 : :
1550 : 113 : block->expr1->value.op.op1 = expr;
1551 : :
1552 : : /* 0 == size_expr */
1553 : 113 : block->expr1->value.op.op2 = gfc_get_expr ();
1554 : 113 : block->expr1->value.op.op2->ts.type = BT_LOGICAL;
1555 : 113 : block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
1556 : 113 : block->expr1->value.op.op2->expr_type = EXPR_OP;
1557 : 113 : block->expr1->value.op.op2->where = gfc_current_locus;
1558 : 113 : block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
1559 : 226 : block->expr1->value.op.op2->value.op.op1 =
1560 : 113 : gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1561 : 113 : block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
1562 : :
1563 : : /* IF body: call final subroutine. */
1564 : 113 : block->next = gfc_get_code (EXEC_CALL);
1565 : 113 : block->next->symtree = fini->proc_tree;
1566 : 113 : block->next->resolved_sym = fini->proc_tree->n.sym;
1567 : 113 : block->next->ext.actual = gfc_get_actual_arglist ();
1568 : 113 : block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
1569 : :
1570 : : /* ELSE. */
1571 : :
1572 : 113 : block->block = gfc_get_code (EXEC_IF);
1573 : 113 : block = block->block;
1574 : :
1575 : : /* BLOCK ... END BLOCK. */
1576 : 113 : block->next = gfc_get_code (EXEC_BLOCK);
1577 : 113 : block = block->next;
1578 : :
1579 : 113 : ns = gfc_build_block_ns (sub_ns);
1580 : 113 : block->ext.block.ns = ns;
1581 : 113 : block->ext.block.assoc = NULL;
1582 : :
1583 : 113 : gfc_get_symbol ("ptr2", ns, &ptr2);
1584 : 113 : ptr2->ts.type = BT_DERIVED;
1585 : 113 : ptr2->ts.u.derived = array->ts.u.derived;
1586 : 113 : ptr2->attr.flavor = FL_VARIABLE;
1587 : 113 : ptr2->attr.pointer = 1;
1588 : 113 : ptr2->attr.artificial = 1;
1589 : 113 : gfc_set_sym_referenced (ptr2);
1590 : 113 : gfc_commit_symbol (ptr2);
1591 : :
1592 : 113 : gfc_get_symbol ("tmp_array", ns, &tmp_array);
1593 : 113 : tmp_array->ts.type = BT_DERIVED;
1594 : 113 : tmp_array->ts.u.derived = array->ts.u.derived;
1595 : 113 : tmp_array->attr.flavor = FL_VARIABLE;
1596 : 113 : tmp_array->attr.dimension = 1;
1597 : 113 : tmp_array->attr.artificial = 1;
1598 : 113 : tmp_array->as = gfc_get_array_spec();
1599 : 113 : tmp_array->attr.intent = INTENT_INOUT;
1600 : 113 : tmp_array->as->type = AS_EXPLICIT;
1601 : 113 : tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
1602 : :
1603 : 300 : for (i = 0; i < tmp_array->as->rank; i++)
1604 : : {
1605 : 187 : gfc_expr *shape_expr;
1606 : 187 : tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
1607 : : NULL, 1);
1608 : : /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1609 : 187 : shape_expr
1610 : 374 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
1611 : : gfc_current_locus, 3,
1612 : : gfc_lval_expr_from_sym (array),
1613 : : gfc_get_int_expr (gfc_default_integer_kind,
1614 : 187 : NULL, i+1),
1615 : : gfc_get_int_expr (gfc_default_integer_kind,
1616 : : NULL,
1617 : : gfc_index_integer_kind));
1618 : 187 : shape_expr->ts.kind = gfc_index_integer_kind;
1619 : 187 : tmp_array->as->upper[i] = shape_expr;
1620 : : }
1621 : 113 : gfc_set_sym_referenced (tmp_array);
1622 : 113 : gfc_commit_symbol (tmp_array);
1623 : :
1624 : : /* Create loop. */
1625 : 113 : iter = gfc_get_iterator ();
1626 : 113 : iter->var = gfc_lval_expr_from_sym (idx);
1627 : 113 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1628 : 113 : iter->end = gfc_lval_expr_from_sym (nelem);
1629 : 113 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1630 : :
1631 : 113 : block = gfc_get_code (EXEC_DO);
1632 : 113 : ns->code = block;
1633 : 113 : block->ext.iterator = iter;
1634 : 113 : block->block = gfc_get_code (EXEC_DO);
1635 : :
1636 : : /* Offset calculation for the new array: idx * size of type (in bytes). */
1637 : 113 : offset2 = gfc_get_expr ();
1638 : 113 : offset2->expr_type = EXPR_OP;
1639 : 113 : offset2->where = gfc_current_locus;
1640 : 113 : offset2->value.op.op = INTRINSIC_TIMES;
1641 : 113 : offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
1642 : 113 : offset2->value.op.op2 = gfc_copy_expr (size_expr);
1643 : 113 : offset2->ts = byte_stride->ts;
1644 : :
1645 : : /* Offset calculation of "array". */
1646 : 113 : block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
1647 : : byte_stride, rank, block->block, sub_ns);
1648 : :
1649 : : /* Create code for
1650 : : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1651 : : + idx * stride, c_ptr), ptr). */
1652 : 113 : block2->next = finalization_scalarizer (array, ptr,
1653 : : gfc_lval_expr_from_sym (offset),
1654 : : sub_ns);
1655 : 113 : block2 = block2->next;
1656 : 113 : block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
1657 : 113 : block2 = block2->next;
1658 : :
1659 : : /* ptr2 = ptr. */
1660 : 113 : block2->next = gfc_get_code (EXEC_ASSIGN);
1661 : 113 : block2 = block2->next;
1662 : 113 : block2->expr1 = gfc_lval_expr_from_sym (ptr2);
1663 : 113 : block2->expr2 = gfc_lval_expr_from_sym (ptr);
1664 : :
1665 : : /* Call now the user's final subroutine. */
1666 : 113 : block->next = gfc_get_code (EXEC_CALL);
1667 : 113 : block = block->next;
1668 : 113 : block->symtree = fini->proc_tree;
1669 : 113 : block->resolved_sym = fini->proc_tree->n.sym;
1670 : 113 : block->ext.actual = gfc_get_actual_arglist ();
1671 : 113 : block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
1672 : :
1673 : 113 : if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
1674 : 18 : return;
1675 : :
1676 : : /* Copy back. */
1677 : :
1678 : : /* Loop. */
1679 : 95 : iter = gfc_get_iterator ();
1680 : 95 : iter->var = gfc_lval_expr_from_sym (idx);
1681 : 95 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1682 : 95 : iter->end = gfc_lval_expr_from_sym (nelem);
1683 : 95 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1684 : :
1685 : 95 : block->next = gfc_get_code (EXEC_DO);
1686 : 95 : block = block->next;
1687 : 95 : block->ext.iterator = iter;
1688 : 95 : block->block = gfc_get_code (EXEC_DO);
1689 : :
1690 : : /* Offset calculation of "array". */
1691 : 95 : block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
1692 : : byte_stride, rank, block->block, sub_ns);
1693 : :
1694 : : /* Create code for
1695 : : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1696 : : + offset, c_ptr), ptr). */
1697 : 95 : block2->next = finalization_scalarizer (array, ptr,
1698 : : gfc_lval_expr_from_sym (offset),
1699 : : sub_ns);
1700 : 95 : block2 = block2->next;
1701 : 95 : block2->next = finalization_scalarizer (tmp_array, ptr2,
1702 : : gfc_copy_expr (offset2), sub_ns);
1703 : 95 : block2 = block2->next;
1704 : :
1705 : : /* ptr = ptr2. */
1706 : 95 : block2->next = gfc_get_code (EXEC_ASSIGN);
1707 : 95 : block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
1708 : 95 : block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
1709 : : }
1710 : :
1711 : :
1712 : : /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1713 : : derived type "derived". The function first calls the appropriate FINAL
1714 : : subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1715 : : components (but not the inherited ones). Last, it calls the wrapper
1716 : : subroutine of the parent. The generated wrapper procedure takes as argument
1717 : : an assumed-rank array.
1718 : : If neither allocatable components nor FINAL subroutines exists, the vtab
1719 : : will contain a NULL pointer.
1720 : : The generated function has the form
1721 : : _final(assumed-rank array, stride, skip_corarray)
1722 : : where the array has to be contiguous (except of the lowest dimension). The
1723 : : stride (in bytes) is used to allow different sizes for ancestor types by
1724 : : skipping over the additionally added components in the scalarizer. If
1725 : : "fini_coarray" is false, coarray components are not finalized to allow for
1726 : : the correct semantic with intrinsic assignment. */
1727 : :
1728 : : static void
1729 : 9461 : generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
1730 : : const char *tname, gfc_component *vtab_final)
1731 : : {
1732 : 9461 : gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
1733 : 9461 : gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
1734 : 9461 : gfc_component *comp;
1735 : 9461 : gfc_namespace *sub_ns;
1736 : 9461 : gfc_code *last_code, *block;
1737 : 9461 : char *name;
1738 : 9461 : bool finalizable_comp = false;
1739 : 9461 : gfc_expr *ancestor_wrapper = NULL, *rank;
1740 : 9461 : gfc_iterator *iter;
1741 : :
1742 : 9461 : if (derived->attr.unlimited_polymorphic)
1743 : : {
1744 : 684 : vtab_final->initializer = gfc_get_null_expr (NULL);
1745 : 7610 : return;
1746 : : }
1747 : :
1748 : : /* Search for the ancestor's finalizers. */
1749 : 1302 : if (derived->attr.extension && derived->components
1750 : 10079 : && (!derived->components->ts.u.derived->attr.abstract
1751 : 303 : || has_finalizer_component (derived)))
1752 : : {
1753 : 999 : gfc_symbol *vtab;
1754 : 999 : gfc_component *comp;
1755 : :
1756 : 999 : vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
1757 : 5994 : for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
1758 : 5994 : if (comp->name[0] == '_' && comp->name[1] == 'f')
1759 : : {
1760 : 999 : ancestor_wrapper = comp->initializer;
1761 : 999 : break;
1762 : : }
1763 : : }
1764 : :
1765 : : /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1766 : : components: Return a NULL() expression; we defer this a bit to have
1767 : : an interface declaration. */
1768 : 999 : if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
1769 : 8605 : && !derived->attr.alloc_comp
1770 : 7147 : && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
1771 : 7892 : && !has_finalizer_component (derived))
1772 : : {
1773 : 6869 : vtab_final->initializer = gfc_get_null_expr (NULL);
1774 : 6869 : gcc_assert (vtab_final->ts.interface == NULL);
1775 : : return;
1776 : : }
1777 : : else
1778 : : /* Check whether there are new allocatable components. */
1779 : 5064 : for (comp = derived->components; comp; comp = comp->next)
1780 : : {
1781 : 3156 : if (comp == derived->components && derived->attr.extension
1782 : 324 : && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
1783 : 172 : continue;
1784 : :
1785 : 2984 : finalizable_comp |= comp_is_finalizable (comp);
1786 : : }
1787 : :
1788 : : /* If there is no new finalizer and no new allocatable, return with
1789 : : an expr to the ancestor's one. */
1790 : 1908 : if (!finalizable_comp
1791 : 359 : && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
1792 : : {
1793 : 57 : gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
1794 : : && ancestor_wrapper->expr_type == EXPR_VARIABLE);
1795 : 57 : vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
1796 : 57 : vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
1797 : 57 : return;
1798 : : }
1799 : :
1800 : : /* We now create a wrapper, which does the following:
1801 : : 1. Call the suitable finalization subroutine for this type
1802 : : 2. Loop over all noninherited allocatable components and noninherited
1803 : : components with allocatable components and DEALLOCATE those; this will
1804 : : take care of finalizers, coarray deregistering and allocatable
1805 : : nested components.
1806 : : 3. Call the ancestor's finalizer. */
1807 : :
1808 : : /* Declare the wrapper function; it takes an assumed-rank array
1809 : : and a VALUE logical as arguments. */
1810 : :
1811 : : /* Set up the namespace. */
1812 : 1851 : sub_ns = gfc_get_namespace (ns, 0);
1813 : 1851 : sub_ns->sibling = ns->contained;
1814 : 1851 : ns->contained = sub_ns;
1815 : 1851 : sub_ns->resolved = 1;
1816 : :
1817 : : /* Set up the procedure symbol. */
1818 : 1851 : name = xasprintf ("__final_%s", tname);
1819 : 1851 : gfc_get_symbol (name, sub_ns, &final);
1820 : 1851 : sub_ns->proc_name = final;
1821 : 1851 : final->attr.flavor = FL_PROCEDURE;
1822 : 1851 : final->attr.function = 1;
1823 : 1851 : final->attr.pure = 0;
1824 : 1851 : final->attr.recursive = 1;
1825 : 1851 : final->result = final;
1826 : 1851 : final->ts.type = BT_INTEGER;
1827 : 1851 : final->ts.kind = 4;
1828 : 1851 : final->attr.artificial = 1;
1829 : 1851 : final->attr.always_explicit = 1;
1830 : 1851 : final->attr.if_source = IFSRC_DECL;
1831 : 1851 : if (ns->proc_name->attr.flavor == FL_MODULE)
1832 : 1568 : final->module = ns->proc_name->name;
1833 : 1851 : gfc_set_sym_referenced (final);
1834 : 1851 : gfc_commit_symbol (final);
1835 : :
1836 : : /* Set up formal argument. */
1837 : 1851 : gfc_get_symbol ("array", sub_ns, &array);
1838 : 1851 : array->ts.type = BT_DERIVED;
1839 : 1851 : array->ts.u.derived = derived;
1840 : 1851 : array->attr.flavor = FL_VARIABLE;
1841 : 1851 : array->attr.dummy = 1;
1842 : 1851 : array->attr.contiguous = 1;
1843 : 1851 : array->attr.dimension = 1;
1844 : 1851 : array->attr.artificial = 1;
1845 : 1851 : array->as = gfc_get_array_spec();
1846 : 1851 : array->as->type = AS_ASSUMED_RANK;
1847 : 1851 : array->as->rank = -1;
1848 : 1851 : array->attr.intent = INTENT_INOUT;
1849 : 1851 : gfc_set_sym_referenced (array);
1850 : 1851 : final->formal = gfc_get_formal_arglist ();
1851 : 1851 : final->formal->sym = array;
1852 : 1851 : gfc_commit_symbol (array);
1853 : :
1854 : : /* Set up formal argument. */
1855 : 1851 : gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
1856 : 1851 : byte_stride->ts.type = BT_INTEGER;
1857 : 1851 : byte_stride->ts.kind = gfc_index_integer_kind;
1858 : 1851 : byte_stride->attr.flavor = FL_VARIABLE;
1859 : 1851 : byte_stride->attr.dummy = 1;
1860 : 1851 : byte_stride->attr.value = 1;
1861 : 1851 : byte_stride->attr.artificial = 1;
1862 : 1851 : gfc_set_sym_referenced (byte_stride);
1863 : 1851 : final->formal->next = gfc_get_formal_arglist ();
1864 : 1851 : final->formal->next->sym = byte_stride;
1865 : 1851 : gfc_commit_symbol (byte_stride);
1866 : :
1867 : : /* Set up formal argument. */
1868 : 1851 : gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
1869 : 1851 : fini_coarray->ts.type = BT_LOGICAL;
1870 : 1851 : fini_coarray->ts.kind = 1;
1871 : 1851 : fini_coarray->attr.flavor = FL_VARIABLE;
1872 : 1851 : fini_coarray->attr.dummy = 1;
1873 : 1851 : fini_coarray->attr.value = 1;
1874 : 1851 : fini_coarray->attr.artificial = 1;
1875 : 1851 : gfc_set_sym_referenced (fini_coarray);
1876 : 1851 : final->formal->next->next = gfc_get_formal_arglist ();
1877 : 1851 : final->formal->next->next->sym = fini_coarray;
1878 : 1851 : gfc_commit_symbol (fini_coarray);
1879 : :
1880 : : /* Local variables. */
1881 : :
1882 : 1851 : gfc_get_symbol ("idx", sub_ns, &idx);
1883 : 1851 : idx->ts.type = BT_INTEGER;
1884 : 1851 : idx->ts.kind = gfc_index_integer_kind;
1885 : 1851 : idx->attr.flavor = FL_VARIABLE;
1886 : 1851 : idx->attr.artificial = 1;
1887 : 1851 : gfc_set_sym_referenced (idx);
1888 : 1851 : gfc_commit_symbol (idx);
1889 : :
1890 : 1851 : gfc_get_symbol ("idx2", sub_ns, &idx2);
1891 : 1851 : idx2->ts.type = BT_INTEGER;
1892 : 1851 : idx2->ts.kind = gfc_index_integer_kind;
1893 : 1851 : idx2->attr.flavor = FL_VARIABLE;
1894 : 1851 : idx2->attr.artificial = 1;
1895 : 1851 : gfc_set_sym_referenced (idx2);
1896 : 1851 : gfc_commit_symbol (idx2);
1897 : :
1898 : 1851 : gfc_get_symbol ("offset", sub_ns, &offset);
1899 : 1851 : offset->ts.type = BT_INTEGER;
1900 : 1851 : offset->ts.kind = gfc_index_integer_kind;
1901 : 1851 : offset->attr.flavor = FL_VARIABLE;
1902 : 1851 : offset->attr.artificial = 1;
1903 : 1851 : gfc_set_sym_referenced (offset);
1904 : 1851 : gfc_commit_symbol (offset);
1905 : :
1906 : : /* Create RANK expression. */
1907 : 1851 : rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
1908 : : gfc_current_locus, 1,
1909 : : gfc_lval_expr_from_sym (array));
1910 : 1851 : if (rank->ts.kind != idx->ts.kind)
1911 : 1851 : gfc_convert_type_warn (rank, &idx->ts, 2, 0);
1912 : :
1913 : : /* Create is_contiguous variable. */
1914 : 1851 : gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
1915 : 1851 : is_contiguous->ts.type = BT_LOGICAL;
1916 : 1851 : is_contiguous->ts.kind = gfc_default_logical_kind;
1917 : 1851 : is_contiguous->attr.flavor = FL_VARIABLE;
1918 : 1851 : is_contiguous->attr.artificial = 1;
1919 : 1851 : gfc_set_sym_referenced (is_contiguous);
1920 : 1851 : gfc_commit_symbol (is_contiguous);
1921 : :
1922 : : /* Create "sizes(0..rank)" variable, which contains the multiplied
1923 : : up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1924 : : sizes(2) = sizes(1) * extent(dim=2) etc. */
1925 : 1851 : gfc_get_symbol ("sizes", sub_ns, &sizes);
1926 : 1851 : sizes->ts.type = BT_INTEGER;
1927 : 1851 : sizes->ts.kind = gfc_index_integer_kind;
1928 : 1851 : sizes->attr.flavor = FL_VARIABLE;
1929 : 1851 : sizes->attr.dimension = 1;
1930 : 1851 : sizes->attr.artificial = 1;
1931 : 1851 : sizes->as = gfc_get_array_spec();
1932 : 1851 : sizes->attr.intent = INTENT_INOUT;
1933 : 1851 : sizes->as->type = AS_EXPLICIT;
1934 : 1851 : sizes->as->rank = 1;
1935 : 1851 : sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1936 : 1851 : sizes->as->upper[0] = gfc_copy_expr (rank);
1937 : 1851 : gfc_set_sym_referenced (sizes);
1938 : 1851 : gfc_commit_symbol (sizes);
1939 : :
1940 : : /* Create "strides(1..rank)" variable, which contains the strides per
1941 : : dimension. */
1942 : 1851 : gfc_get_symbol ("strides", sub_ns, &strides);
1943 : 1851 : strides->ts.type = BT_INTEGER;
1944 : 1851 : strides->ts.kind = gfc_index_integer_kind;
1945 : 1851 : strides->attr.flavor = FL_VARIABLE;
1946 : 1851 : strides->attr.dimension = 1;
1947 : 1851 : strides->attr.artificial = 1;
1948 : 1851 : strides->as = gfc_get_array_spec();
1949 : 1851 : strides->attr.intent = INTENT_INOUT;
1950 : 1851 : strides->as->type = AS_EXPLICIT;
1951 : 1851 : strides->as->rank = 1;
1952 : 1851 : strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1953 : 1851 : strides->as->upper[0] = gfc_copy_expr (rank);
1954 : 1851 : gfc_set_sym_referenced (strides);
1955 : 1851 : gfc_commit_symbol (strides);
1956 : :
1957 : :
1958 : : /* Set return value to 0. */
1959 : 1851 : last_code = gfc_get_code (EXEC_ASSIGN);
1960 : 1851 : last_code->expr1 = gfc_lval_expr_from_sym (final);
1961 : 1851 : last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
1962 : 1851 : sub_ns->code = last_code;
1963 : :
1964 : : /* Set: is_contiguous = .true. */
1965 : 1851 : last_code->next = gfc_get_code (EXEC_ASSIGN);
1966 : 1851 : last_code = last_code->next;
1967 : 1851 : last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
1968 : 1851 : last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
1969 : : &gfc_current_locus, true);
1970 : :
1971 : : /* Set: sizes(0) = 1. */
1972 : 1851 : last_code->next = gfc_get_code (EXEC_ASSIGN);
1973 : 1851 : last_code = last_code->next;
1974 : 1851 : last_code->expr1 = gfc_lval_expr_from_sym (sizes);
1975 : 1851 : last_code->expr1->ref = gfc_get_ref ();
1976 : 1851 : last_code->expr1->ref->type = REF_ARRAY;
1977 : 1851 : last_code->expr1->ref->u.ar.type = AR_ELEMENT;
1978 : 1851 : last_code->expr1->ref->u.ar.dimen = 1;
1979 : 1851 : last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1980 : 1851 : last_code->expr1->ref->u.ar.start[0]
1981 : 1851 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1982 : 1851 : last_code->expr1->ref->u.ar.as = sizes->as;
1983 : 1851 : last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1984 : :
1985 : : /* Create:
1986 : : DO idx = 1, rank
1987 : : strides(idx) = _F._stride (array, dim=idx)
1988 : : sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1989 : : if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1990 : : END DO. */
1991 : :
1992 : : /* Create loop. */
1993 : 1851 : iter = gfc_get_iterator ();
1994 : 1851 : iter->var = gfc_lval_expr_from_sym (idx);
1995 : 1851 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1996 : 1851 : iter->end = gfc_copy_expr (rank);
1997 : 1851 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1998 : 1851 : last_code->next = gfc_get_code (EXEC_DO);
1999 : 1851 : last_code = last_code->next;
2000 : 1851 : last_code->ext.iterator = iter;
2001 : 1851 : last_code->block = gfc_get_code (EXEC_DO);
2002 : :
2003 : : /* strides(idx) = _F._stride(array,dim=idx). */
2004 : 1851 : last_code->block->next = gfc_get_code (EXEC_ASSIGN);
2005 : 1851 : block = last_code->block->next;
2006 : :
2007 : 1851 : block->expr1 = gfc_lval_expr_from_sym (strides);
2008 : 1851 : block->expr1->ref = gfc_get_ref ();
2009 : 1851 : block->expr1->ref->type = REF_ARRAY;
2010 : 1851 : block->expr1->ref->u.ar.type = AR_ELEMENT;
2011 : 1851 : block->expr1->ref->u.ar.dimen = 1;
2012 : 1851 : block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2013 : 1851 : block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
2014 : 1851 : block->expr1->ref->u.ar.as = strides->as;
2015 : :
2016 : 1851 : block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
2017 : : gfc_current_locus, 2,
2018 : : gfc_lval_expr_from_sym (array),
2019 : : gfc_lval_expr_from_sym (idx));
2020 : :
2021 : : /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
2022 : 1851 : block->next = gfc_get_code (EXEC_ASSIGN);
2023 : 1851 : block = block->next;
2024 : :
2025 : : /* sizes(idx) = ... */
2026 : 1851 : block->expr1 = gfc_lval_expr_from_sym (sizes);
2027 : 1851 : block->expr1->ref = gfc_get_ref ();
2028 : 1851 : block->expr1->ref->type = REF_ARRAY;
2029 : 1851 : block->expr1->ref->u.ar.type = AR_ELEMENT;
2030 : 1851 : block->expr1->ref->u.ar.dimen = 1;
2031 : 1851 : block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2032 : 1851 : block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
2033 : 1851 : block->expr1->ref->u.ar.as = sizes->as;
2034 : :
2035 : 1851 : block->expr2 = gfc_get_expr ();
2036 : 1851 : block->expr2->expr_type = EXPR_OP;
2037 : 1851 : block->expr2->value.op.op = INTRINSIC_TIMES;
2038 : 1851 : block->expr2->where = gfc_current_locus;
2039 : :
2040 : : /* sizes(idx-1). */
2041 : 1851 : block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
2042 : 1851 : block->expr2->value.op.op1->ref = gfc_get_ref ();
2043 : 1851 : block->expr2->value.op.op1->ref->type = REF_ARRAY;
2044 : 1851 : block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
2045 : 1851 : block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
2046 : 1851 : block->expr2->value.op.op1->ref->u.ar.dimen = 1;
2047 : 1851 : block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2048 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
2049 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
2050 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus;
2051 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
2052 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
2053 : 1851 : = gfc_lval_expr_from_sym (idx);
2054 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
2055 : 1851 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2056 : 1851 : block->expr2->value.op.op1->ref->u.ar.start[0]->ts
2057 : 1851 : = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
2058 : :
2059 : : /* size(array, dim=idx, kind=index_kind). */
2060 : 3702 : block->expr2->value.op.op2
2061 : 1851 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
2062 : : gfc_current_locus, 3,
2063 : : gfc_lval_expr_from_sym (array),
2064 : : gfc_lval_expr_from_sym (idx),
2065 : : gfc_get_int_expr (gfc_index_integer_kind,
2066 : : NULL,
2067 : : gfc_index_integer_kind));
2068 : 1851 : block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
2069 : 1851 : block->expr2->ts = idx->ts;
2070 : :
2071 : : /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
2072 : 1851 : block->next = gfc_get_code (EXEC_IF);
2073 : 1851 : block = block->next;
2074 : :
2075 : 1851 : block->block = gfc_get_code (EXEC_IF);
2076 : 1851 : block = block->block;
2077 : :
2078 : : /* if condition: strides(idx) /= sizes(idx-1). */
2079 : 1851 : block->expr1 = gfc_get_expr ();
2080 : 1851 : block->expr1->ts.type = BT_LOGICAL;
2081 : 1851 : block->expr1->ts.kind = gfc_default_logical_kind;
2082 : 1851 : block->expr1->expr_type = EXPR_OP;
2083 : 1851 : block->expr1->where = gfc_current_locus;
2084 : 1851 : block->expr1->value.op.op = INTRINSIC_NE;
2085 : :
2086 : 1851 : block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
2087 : 1851 : block->expr1->value.op.op1->ref = gfc_get_ref ();
2088 : 1851 : block->expr1->value.op.op1->ref->type = REF_ARRAY;
2089 : 1851 : block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
2090 : 1851 : block->expr1->value.op.op1->ref->u.ar.dimen = 1;
2091 : 1851 : block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2092 : 1851 : block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
2093 : 1851 : block->expr1->value.op.op1->ref->u.ar.as = strides->as;
2094 : :
2095 : 1851 : block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
2096 : 1851 : block->expr1->value.op.op2->ref = gfc_get_ref ();
2097 : 1851 : block->expr1->value.op.op2->ref->type = REF_ARRAY;
2098 : 1851 : block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
2099 : 1851 : block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
2100 : 1851 : block->expr1->value.op.op2->ref->u.ar.dimen = 1;
2101 : 1851 : block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2102 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
2103 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
2104 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
2105 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
2106 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
2107 : 1851 : = gfc_lval_expr_from_sym (idx);
2108 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
2109 : 1851 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2110 : 1851 : block->expr1->value.op.op2->ref->u.ar.start[0]->ts
2111 : 1851 : = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
2112 : :
2113 : : /* if body: is_contiguous = .false. */
2114 : 1851 : block->next = gfc_get_code (EXEC_ASSIGN);
2115 : 1851 : block = block->next;
2116 : 1851 : block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
2117 : 1851 : block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
2118 : : &gfc_current_locus, false);
2119 : :
2120 : : /* Obtain the size (number of elements) of "array" MINUS ONE,
2121 : : which is used in the scalarization. */
2122 : 1851 : gfc_get_symbol ("nelem", sub_ns, &nelem);
2123 : 1851 : nelem->ts.type = BT_INTEGER;
2124 : 1851 : nelem->ts.kind = gfc_index_integer_kind;
2125 : 1851 : nelem->attr.flavor = FL_VARIABLE;
2126 : 1851 : nelem->attr.artificial = 1;
2127 : 1851 : gfc_set_sym_referenced (nelem);
2128 : 1851 : gfc_commit_symbol (nelem);
2129 : :
2130 : : /* nelem = sizes (rank) - 1. */
2131 : 1851 : last_code->next = gfc_get_code (EXEC_ASSIGN);
2132 : 1851 : last_code = last_code->next;
2133 : :
2134 : 1851 : last_code->expr1 = gfc_lval_expr_from_sym (nelem);
2135 : :
2136 : 1851 : last_code->expr2 = gfc_get_expr ();
2137 : 1851 : last_code->expr2->expr_type = EXPR_OP;
2138 : 1851 : last_code->expr2->value.op.op = INTRINSIC_MINUS;
2139 : 1851 : last_code->expr2->value.op.op2
2140 : 1851 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2141 : 1851 : last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
2142 : 1851 : last_code->expr2->where = gfc_current_locus;
2143 : :
2144 : 1851 : last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
2145 : 1851 : last_code->expr2->value.op.op1->ref = gfc_get_ref ();
2146 : 1851 : last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
2147 : 1851 : last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
2148 : 1851 : last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
2149 : 1851 : last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2150 : 1851 : last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
2151 : 1851 : last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
2152 : :
2153 : : /* Call final subroutines. We now generate code like:
2154 : : use iso_c_binding
2155 : : integer, pointer :: ptr
2156 : : type(c_ptr) :: cptr
2157 : : integer(c_intptr_t) :: i, addr
2158 : :
2159 : : select case (rank (array))
2160 : : case (3)
2161 : : ! If needed, the array is packed
2162 : : call final_rank3 (array)
2163 : : case default:
2164 : : do i = 0, size (array)-1
2165 : : addr = transfer (c_loc (array), addr) + i * stride
2166 : : call c_f_pointer (transfer (addr, cptr), ptr)
2167 : : call elemental_final (ptr)
2168 : : end do
2169 : : end select */
2170 : :
2171 : 1851 : if (derived->f2k_derived && derived->f2k_derived->finalizers)
2172 : : {
2173 : 359 : gfc_finalizer *fini, *fini_elem = NULL;
2174 : :
2175 : 359 : gfc_get_symbol ("ptr1", sub_ns, &ptr);
2176 : 359 : ptr->ts.type = BT_DERIVED;
2177 : 359 : ptr->ts.u.derived = derived;
2178 : 359 : ptr->attr.flavor = FL_VARIABLE;
2179 : 359 : ptr->attr.pointer = 1;
2180 : 359 : ptr->attr.artificial = 1;
2181 : 359 : gfc_set_sym_referenced (ptr);
2182 : 359 : gfc_commit_symbol (ptr);
2183 : :
2184 : 359 : fini = derived->f2k_derived->finalizers;
2185 : :
2186 : : /* Assumed rank finalizers can be called directly. The call takes care
2187 : : of setting up the descriptor. resolve_finalizers has already checked
2188 : : that this is the only finalizer for this kind/type (F2018: C790). */
2189 : 359 : if (fini->proc_tree && fini->proc_tree->n.sym->formal->sym->as
2190 : 99 : && fini->proc_tree->n.sym->formal->sym->as->type == AS_ASSUMED_RANK)
2191 : : {
2192 : 6 : last_code->next = gfc_get_code (EXEC_CALL);
2193 : 6 : last_code->next->symtree = fini->proc_tree;
2194 : 6 : last_code->next->resolved_sym = fini->proc_tree->n.sym;
2195 : 6 : last_code->next->ext.actual = gfc_get_actual_arglist ();
2196 : 6 : last_code->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
2197 : :
2198 : 6 : last_code = last_code->next;
2199 : 6 : goto finish_assumed_rank;
2200 : : }
2201 : :
2202 : : /* SELECT CASE (RANK (array)). */
2203 : 353 : last_code->next = gfc_get_code (EXEC_SELECT);
2204 : 353 : last_code = last_code->next;
2205 : 353 : last_code->expr1 = gfc_copy_expr (rank);
2206 : 353 : block = NULL;
2207 : :
2208 : :
2209 : 782 : for (; fini; fini = fini->next)
2210 : : {
2211 : 429 : gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */
2212 : 429 : if (fini->proc_tree->n.sym->attr.elemental)
2213 : : {
2214 : 102 : fini_elem = fini;
2215 : 102 : continue;
2216 : : }
2217 : :
2218 : : /* CASE (fini_rank). */
2219 : 327 : if (block)
2220 : : {
2221 : 63 : block->block = gfc_get_code (EXEC_SELECT);
2222 : 63 : block = block->block;
2223 : : }
2224 : : else
2225 : : {
2226 : 264 : block = gfc_get_code (EXEC_SELECT);
2227 : 264 : last_code->block = block;
2228 : : }
2229 : 327 : block->ext.block.case_list = gfc_get_case ();
2230 : 327 : block->ext.block.case_list->where = gfc_current_locus;
2231 : 327 : if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
2232 : 113 : block->ext.block.case_list->low
2233 : 113 : = gfc_get_int_expr (gfc_default_integer_kind, NULL,
2234 : 113 : fini->proc_tree->n.sym->formal->sym->as->rank);
2235 : : else
2236 : 214 : block->ext.block.case_list->low
2237 : 214 : = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2238 : 327 : block->ext.block.case_list->high
2239 : 327 : = gfc_copy_expr (block->ext.block.case_list->low);
2240 : :
2241 : : /* CALL fini_rank (array) - possibly with packing. */
2242 : 327 : if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
2243 : 113 : finalizer_insert_packed_call (block, fini, array, byte_stride,
2244 : : idx, ptr, nelem, strides,
2245 : : sizes, idx2, offset, is_contiguous,
2246 : : rank, sub_ns);
2247 : : else
2248 : : {
2249 : 214 : block->next = gfc_get_code (EXEC_CALL);
2250 : 214 : block->next->symtree = fini->proc_tree;
2251 : 214 : block->next->resolved_sym = fini->proc_tree->n.sym;
2252 : 214 : block->next->ext.actual = gfc_get_actual_arglist ();
2253 : 214 : block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
2254 : : }
2255 : : }
2256 : :
2257 : : /* Elemental call - scalarized. */
2258 : 353 : if (fini_elem)
2259 : : {
2260 : : /* CASE DEFAULT. */
2261 : 102 : if (block)
2262 : : {
2263 : 13 : block->block = gfc_get_code (EXEC_SELECT);
2264 : 13 : block = block->block;
2265 : : }
2266 : : else
2267 : : {
2268 : 89 : block = gfc_get_code (EXEC_SELECT);
2269 : 89 : last_code->block = block;
2270 : : }
2271 : 102 : block->ext.block.case_list = gfc_get_case ();
2272 : :
2273 : : /* Create loop. */
2274 : 102 : iter = gfc_get_iterator ();
2275 : 102 : iter->var = gfc_lval_expr_from_sym (idx);
2276 : 102 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
2277 : 102 : iter->end = gfc_lval_expr_from_sym (nelem);
2278 : 102 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2279 : 102 : block->next = gfc_get_code (EXEC_DO);
2280 : 102 : block = block->next;
2281 : 102 : block->ext.iterator = iter;
2282 : 102 : block->block = gfc_get_code (EXEC_DO);
2283 : :
2284 : : /* Offset calculation. */
2285 : 102 : block = finalization_get_offset (idx, idx2, offset, strides, sizes,
2286 : : byte_stride, rank, block->block,
2287 : : sub_ns);
2288 : :
2289 : : /* Create code for
2290 : : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2291 : : + offset, c_ptr), ptr). */
2292 : 102 : block->next
2293 : 102 : = finalization_scalarizer (array, ptr,
2294 : : gfc_lval_expr_from_sym (offset),
2295 : : sub_ns);
2296 : 102 : block = block->next;
2297 : :
2298 : : /* CALL final_elemental (array). */
2299 : 102 : block->next = gfc_get_code (EXEC_CALL);
2300 : 102 : block = block->next;
2301 : 102 : block->symtree = fini_elem->proc_tree;
2302 : 102 : block->resolved_sym = fini_elem->proc_sym;
2303 : 102 : block->ext.actual = gfc_get_actual_arglist ();
2304 : 102 : block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
2305 : : }
2306 : : }
2307 : :
2308 : 1492 : finish_assumed_rank:
2309 : :
2310 : : /* Finalize and deallocate allocatable components. The same manual
2311 : : scalarization is used as above. */
2312 : :
2313 : 1851 : if (finalizable_comp)
2314 : : {
2315 : 1549 : gfc_symbol *stat;
2316 : 1549 : gfc_code *block = NULL;
2317 : :
2318 : 1549 : if (!ptr)
2319 : : {
2320 : 1492 : gfc_get_symbol ("ptr2", sub_ns, &ptr);
2321 : 1492 : ptr->ts.type = BT_DERIVED;
2322 : 1492 : ptr->ts.u.derived = derived;
2323 : 1492 : ptr->attr.flavor = FL_VARIABLE;
2324 : 1492 : ptr->attr.pointer = 1;
2325 : 1492 : ptr->attr.artificial = 1;
2326 : 1492 : gfc_set_sym_referenced (ptr);
2327 : 1492 : gfc_commit_symbol (ptr);
2328 : : }
2329 : :
2330 : 1549 : gfc_get_symbol ("ignore", sub_ns, &stat);
2331 : 1549 : stat->attr.flavor = FL_VARIABLE;
2332 : 1549 : stat->attr.artificial = 1;
2333 : 1549 : stat->ts.type = BT_INTEGER;
2334 : 1549 : stat->ts.kind = gfc_default_integer_kind;
2335 : 1549 : gfc_set_sym_referenced (stat);
2336 : 1549 : gfc_commit_symbol (stat);
2337 : :
2338 : : /* Create loop. */
2339 : 1549 : iter = gfc_get_iterator ();
2340 : 1549 : iter->var = gfc_lval_expr_from_sym (idx);
2341 : 1549 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
2342 : 1549 : iter->end = gfc_lval_expr_from_sym (nelem);
2343 : 1549 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2344 : 1549 : last_code->next = gfc_get_code (EXEC_DO);
2345 : 1549 : last_code = last_code->next;
2346 : 1549 : last_code->ext.iterator = iter;
2347 : 1549 : last_code->block = gfc_get_code (EXEC_DO);
2348 : :
2349 : : /* Offset calculation. */
2350 : 1549 : block = finalization_get_offset (idx, idx2, offset, strides, sizes,
2351 : : byte_stride, rank, last_code->block,
2352 : : sub_ns);
2353 : :
2354 : : /* Create code for
2355 : : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2356 : : + idx * stride, c_ptr), ptr). */
2357 : 1549 : block->next = finalization_scalarizer (array, ptr,
2358 : : gfc_lval_expr_from_sym(offset),
2359 : : sub_ns);
2360 : 1549 : block = block->next;
2361 : :
2362 : 4268 : for (comp = derived->components; comp; comp = comp->next)
2363 : : {
2364 : 2719 : if (comp == derived->components && derived->attr.extension
2365 : 206 : && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
2366 : 54 : continue;
2367 : :
2368 : 2665 : finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
2369 : : stat, fini_coarray, &block, sub_ns);
2370 : 2665 : if (!last_code->block->next)
2371 : 0 : last_code->block->next = block;
2372 : : }
2373 : :
2374 : : }
2375 : :
2376 : : /* Call the finalizer of the ancestor. */
2377 : 1851 : if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
2378 : : {
2379 : 115 : last_code->next = gfc_get_code (EXEC_CALL);
2380 : 115 : last_code = last_code->next;
2381 : 115 : last_code->symtree = ancestor_wrapper->symtree;
2382 : 115 : last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
2383 : :
2384 : 115 : last_code->ext.actual = gfc_get_actual_arglist ();
2385 : 115 : last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
2386 : 115 : last_code->ext.actual->next = gfc_get_actual_arglist ();
2387 : 115 : last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
2388 : 115 : last_code->ext.actual->next->next = gfc_get_actual_arglist ();
2389 : 115 : last_code->ext.actual->next->next->expr
2390 : 115 : = gfc_lval_expr_from_sym (fini_coarray);
2391 : : }
2392 : :
2393 : 1851 : gfc_free_expr (rank);
2394 : 1851 : vtab_final->initializer = gfc_lval_expr_from_sym (final);
2395 : 1851 : vtab_final->ts.interface = final;
2396 : 1851 : free (name);
2397 : : }
2398 : :
2399 : :
2400 : : /* Add procedure pointers for all type-bound procedures to a vtab. */
2401 : :
2402 : : static void
2403 : 10198 : add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
2404 : : {
2405 : 10198 : gfc_symbol* super_type;
2406 : :
2407 : 10198 : super_type = gfc_get_derived_super_type (derived);
2408 : :
2409 : 10198 : if (super_type && (super_type != derived))
2410 : : {
2411 : : /* Make sure that the PPCs appear in the same order as in the parent. */
2412 : 1421 : copy_vtab_proc_comps (super_type, vtype);
2413 : : /* Only needed to get the PPC initializers right. */
2414 : 1421 : add_procs_to_declared_vtab (super_type, vtype);
2415 : : }
2416 : :
2417 : 10198 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
2418 : 2188 : add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
2419 : :
2420 : 10198 : if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
2421 : 22 : add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
2422 : 10198 : }
2423 : :
2424 : :
2425 : : /* Find or generate the symbol for a derived type's vtab. */
2426 : :
2427 : : gfc_symbol *
2428 : 71848 : gfc_find_derived_vtab (gfc_symbol *derived)
2429 : : {
2430 : 71848 : gfc_namespace *ns;
2431 : 71848 : gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
2432 : 71848 : gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
2433 : 71848 : gfc_gsymbol *gsym = NULL;
2434 : 71848 : gfc_symbol *dealloc = NULL, *arg = NULL;
2435 : :
2436 : 71848 : if (derived->attr.pdt_template)
2437 : : return NULL;
2438 : :
2439 : : /* Find the top-level namespace. */
2440 : 80620 : for (ns = gfc_current_ns; ns; ns = ns->parent)
2441 : 80620 : if (!ns->parent)
2442 : : break;
2443 : :
2444 : : /* If the type is a class container, use the underlying derived type. */
2445 : 71834 : if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
2446 : 9793 : derived = gfc_get_derived_super_type (derived);
2447 : :
2448 : 9793 : if (!derived)
2449 : : return NULL;
2450 : :
2451 : 71834 : if (!derived->name)
2452 : : return NULL;
2453 : :
2454 : : /* Find the gsymbol for the module of use associated derived types. */
2455 : 71834 : if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
2456 : 32257 : && !derived->attr.vtype && !derived->attr.is_class)
2457 : 32257 : gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
2458 : : else
2459 : : gsym = NULL;
2460 : :
2461 : : /* Work in the gsymbol namespace if the top-level namespace is a module.
2462 : : This ensures that the vtable is unique, which is required since we use
2463 : : its address in SELECT TYPE. */
2464 : 32257 : if (gsym && gsym->ns && ns && ns->proc_name
2465 : 24362 : && ns->proc_name->attr.flavor == FL_MODULE)
2466 : : ns = gsym->ns;
2467 : :
2468 : 52331 : if (ns)
2469 : : {
2470 : 71834 : char tname[GFC_MAX_SYMBOL_LEN+1];
2471 : 71834 : char *name;
2472 : :
2473 : 71834 : get_unique_hashed_string (tname, derived);
2474 : 71834 : name = xasprintf ("__vtab_%s", tname);
2475 : :
2476 : : /* Look for the vtab symbol in various namespaces. */
2477 : 71834 : if (gsym && gsym->ns)
2478 : : {
2479 : 24362 : gfc_find_symbol (name, gsym->ns, 0, &vtab);
2480 : 24362 : if (vtab)
2481 : 23965 : ns = gsym->ns;
2482 : : }
2483 : 71834 : if (vtab == NULL)
2484 : 47869 : gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
2485 : 71834 : if (vtab == NULL)
2486 : 15025 : gfc_find_symbol (name, ns, 0, &vtab);
2487 : 71834 : if (vtab == NULL)
2488 : 9468 : gfc_find_symbol (name, derived->ns, 0, &vtab);
2489 : :
2490 : 71834 : if (vtab == NULL)
2491 : : {
2492 : 9464 : gfc_get_symbol (name, ns, &vtab);
2493 : 9464 : vtab->ts.type = BT_DERIVED;
2494 : 9464 : if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
2495 : : &gfc_current_locus))
2496 : 0 : goto cleanup;
2497 : 9464 : vtab->attr.target = 1;
2498 : 9464 : vtab->attr.save = SAVE_IMPLICIT;
2499 : 9464 : vtab->attr.vtab = 1;
2500 : 9464 : vtab->attr.access = ACCESS_PUBLIC;
2501 : 9464 : gfc_set_sym_referenced (vtab);
2502 : 9464 : free (name);
2503 : 9464 : name = xasprintf ("__vtype_%s", tname);
2504 : :
2505 : 9464 : gfc_find_symbol (name, ns, 0, &vtype);
2506 : 9464 : if (vtype == NULL)
2507 : : {
2508 : 9464 : gfc_component *c;
2509 : 9464 : gfc_symbol *parent = NULL, *parent_vtab = NULL;
2510 : 9464 : bool rdt = false;
2511 : :
2512 : : /* Is this a derived type with recursive allocatable
2513 : : components? */
2514 : 18928 : c = (derived->attr.unlimited_polymorphic
2515 : 9464 : || derived->attr.abstract) ?
2516 : : NULL : derived->components;
2517 : 20440 : for (; c; c= c->next)
2518 : 11078 : if (c->ts.type == BT_DERIVED
2519 : 2489 : && c->ts.u.derived == derived)
2520 : : {
2521 : : rdt = true;
2522 : : break;
2523 : : }
2524 : :
2525 : 9464 : gfc_get_symbol (name, ns, &vtype);
2526 : 9464 : if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
2527 : : &gfc_current_locus))
2528 : 0 : goto cleanup;
2529 : 9464 : vtype->attr.access = ACCESS_PUBLIC;
2530 : 9464 : vtype->attr.vtype = 1;
2531 : 9464 : gfc_set_sym_referenced (vtype);
2532 : :
2533 : : /* Add component '_hash'. */
2534 : 9464 : if (!gfc_add_component (vtype, "_hash", &c))
2535 : 0 : goto cleanup;
2536 : 9464 : c->ts.type = BT_INTEGER;
2537 : 9464 : c->ts.kind = 4;
2538 : 9464 : c->attr.access = ACCESS_PRIVATE;
2539 : 18928 : c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2540 : 9464 : NULL, derived->hash_value);
2541 : :
2542 : : /* Add component '_size'. */
2543 : 9464 : if (!gfc_add_component (vtype, "_size", &c))
2544 : 0 : goto cleanup;
2545 : 9464 : c->ts.type = BT_INTEGER;
2546 : 9464 : c->ts.kind = gfc_size_kind;
2547 : 9464 : c->attr.access = ACCESS_PRIVATE;
2548 : : /* Remember the derived type in ts.u.derived,
2549 : : so that the correct initializer can be set later on
2550 : : (in gfc_conv_structure). */
2551 : 9464 : c->ts.u.derived = derived;
2552 : 9464 : c->initializer = gfc_get_int_expr (gfc_size_kind,
2553 : : NULL, 0);
2554 : :
2555 : : /* Add component _extends. */
2556 : 9464 : if (!gfc_add_component (vtype, "_extends", &c))
2557 : 0 : goto cleanup;
2558 : 9464 : c->attr.pointer = 1;
2559 : 9464 : c->attr.access = ACCESS_PRIVATE;
2560 : 9464 : if (!derived->attr.unlimited_polymorphic)
2561 : 8780 : parent = gfc_get_derived_super_type (derived);
2562 : : else
2563 : : parent = NULL;
2564 : :
2565 : 8780 : if (parent)
2566 : : {
2567 : 1302 : parent_vtab = gfc_find_derived_vtab (parent);
2568 : 1302 : c->ts.type = BT_DERIVED;
2569 : 1302 : c->ts.u.derived = parent_vtab->ts.u.derived;
2570 : 1302 : c->initializer = gfc_get_expr ();
2571 : 1302 : c->initializer->expr_type = EXPR_VARIABLE;
2572 : 1302 : gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
2573 : : 0, &c->initializer->symtree);
2574 : : }
2575 : : else
2576 : : {
2577 : 8162 : c->ts.type = BT_DERIVED;
2578 : 8162 : c->ts.u.derived = vtype;
2579 : 8162 : c->initializer = gfc_get_null_expr (NULL);
2580 : : }
2581 : :
2582 : 9464 : if (!derived->attr.unlimited_polymorphic
2583 : 8780 : && derived->components == NULL
2584 : 1040 : && !derived->attr.zero_comp)
2585 : : {
2586 : : /* At this point an error must have occurred.
2587 : : Prevent further errors on the vtype components. */
2588 : 3 : found_sym = vtab;
2589 : 3 : goto have_vtype;
2590 : : }
2591 : :
2592 : : /* Add component _def_init. */
2593 : 9461 : if (!gfc_add_component (vtype, "_def_init", &c))
2594 : 0 : goto cleanup;
2595 : 9461 : c->attr.pointer = 1;
2596 : 9461 : c->attr.artificial = 1;
2597 : 9461 : c->attr.access = ACCESS_PRIVATE;
2598 : 9461 : c->ts.type = BT_DERIVED;
2599 : 9461 : c->ts.u.derived = derived;
2600 : 9461 : if (derived->attr.unlimited_polymorphic
2601 : 9461 : || derived->attr.abstract)
2602 : 986 : c->initializer = gfc_get_null_expr (NULL);
2603 : : else
2604 : : {
2605 : : /* Construct default initialization variable. */
2606 : 8475 : free (name);
2607 : 8475 : name = xasprintf ("__def_init_%s", tname);
2608 : 8475 : gfc_get_symbol (name, ns, &def_init);
2609 : 8475 : def_init->attr.target = 1;
2610 : 8475 : def_init->attr.artificial = 1;
2611 : 8475 : def_init->attr.save = SAVE_IMPLICIT;
2612 : 8475 : def_init->attr.access = ACCESS_PUBLIC;
2613 : 8475 : def_init->attr.flavor = FL_VARIABLE;
2614 : 8475 : gfc_set_sym_referenced (def_init);
2615 : 8475 : def_init->ts.type = BT_DERIVED;
2616 : 8475 : def_init->ts.u.derived = derived;
2617 : 8475 : def_init->value = gfc_default_initializer (&def_init->ts);
2618 : :
2619 : 8475 : c->initializer = gfc_lval_expr_from_sym (def_init);
2620 : : }
2621 : :
2622 : : /* Add component _copy. */
2623 : 9461 : if (!gfc_add_component (vtype, "_copy", &c))
2624 : 0 : goto cleanup;
2625 : 9461 : c->attr.proc_pointer = 1;
2626 : 9461 : c->attr.access = ACCESS_PRIVATE;
2627 : 9461 : c->tb = XCNEW (gfc_typebound_proc);
2628 : 9461 : c->tb->ppc = 1;
2629 : 9461 : if (derived->attr.unlimited_polymorphic
2630 : 9461 : || derived->attr.abstract)
2631 : 986 : c->initializer = gfc_get_null_expr (NULL);
2632 : : else
2633 : : {
2634 : : /* Set up namespace. */
2635 : 8475 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2636 : 8475 : sub_ns->sibling = ns->contained;
2637 : 8475 : ns->contained = sub_ns;
2638 : 8475 : sub_ns->resolved = 1;
2639 : : /* Set up procedure symbol. */
2640 : 8475 : free (name);
2641 : 8475 : name = xasprintf ("__copy_%s", tname);
2642 : 8475 : gfc_get_symbol (name, sub_ns, ©);
2643 : 8475 : sub_ns->proc_name = copy;
2644 : 8475 : copy->attr.flavor = FL_PROCEDURE;
2645 : 8475 : copy->attr.subroutine = 1;
2646 : 8475 : copy->attr.pure = 1;
2647 : 8475 : copy->attr.artificial = 1;
2648 : 8475 : copy->attr.if_source = IFSRC_DECL;
2649 : : /* This is elemental so that arrays are automatically
2650 : : treated correctly by the scalarizer. */
2651 : 8475 : copy->attr.elemental = 1;
2652 : 8475 : if (ns->proc_name->attr.flavor == FL_MODULE)
2653 : 6918 : copy->module = ns->proc_name->name;
2654 : 8475 : gfc_set_sym_referenced (copy);
2655 : : /* Set up formal arguments. */
2656 : 8475 : gfc_get_symbol ("src", sub_ns, &src);
2657 : 8475 : src->ts.type = BT_DERIVED;
2658 : 8475 : src->ts.u.derived = derived;
2659 : 8475 : src->attr.flavor = FL_VARIABLE;
2660 : 8475 : src->attr.dummy = 1;
2661 : 8475 : src->attr.artificial = 1;
2662 : 8475 : src->attr.intent = INTENT_IN;
2663 : 8475 : gfc_set_sym_referenced (src);
2664 : 8475 : copy->formal = gfc_get_formal_arglist ();
2665 : 8475 : copy->formal->sym = src;
2666 : 8475 : gfc_get_symbol ("dst", sub_ns, &dst);
2667 : 8475 : dst->ts.type = BT_DERIVED;
2668 : 8475 : dst->ts.u.derived = derived;
2669 : 8475 : dst->attr.flavor = FL_VARIABLE;
2670 : 8475 : dst->attr.dummy = 1;
2671 : 8475 : dst->attr.artificial = 1;
2672 : 8475 : dst->attr.intent = INTENT_INOUT;
2673 : 8475 : gfc_set_sym_referenced (dst);
2674 : 8475 : copy->formal->next = gfc_get_formal_arglist ();
2675 : 8475 : copy->formal->next->sym = dst;
2676 : : /* Set up code. */
2677 : 8475 : sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
2678 : 8475 : sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
2679 : 8475 : sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
2680 : : /* Set initializer. */
2681 : 8475 : c->initializer = gfc_lval_expr_from_sym (copy);
2682 : 8475 : c->ts.interface = copy;
2683 : : }
2684 : :
2685 : : /* Add component _final, which contains a procedure pointer to
2686 : : a wrapper which handles both the freeing of allocatable
2687 : : components and the calls to finalization subroutines.
2688 : : Note: The actual wrapper function can only be generated
2689 : : at resolution time. */
2690 : 9461 : if (!gfc_add_component (vtype, "_final", &c))
2691 : 0 : goto cleanup;
2692 : 9461 : c->attr.proc_pointer = 1;
2693 : 9461 : c->attr.access = ACCESS_PRIVATE;
2694 : 9461 : c->attr.artificial = 1;
2695 : 9461 : c->tb = XCNEW (gfc_typebound_proc);
2696 : 9461 : c->tb->ppc = 1;
2697 : 9461 : generate_finalization_wrapper (derived, ns, tname, c);
2698 : :
2699 : : /* Add component _deallocate. */
2700 : 9461 : if (!gfc_add_component (vtype, "_deallocate", &c))
2701 : 0 : goto cleanup;
2702 : 9461 : c->attr.proc_pointer = 1;
2703 : 9461 : c->attr.access = ACCESS_PRIVATE;
2704 : 9461 : c->tb = XCNEW (gfc_typebound_proc);
2705 : 9461 : c->tb->ppc = 1;
2706 : 9461 : if (derived->attr.unlimited_polymorphic
2707 : 9461 : || derived->attr.abstract
2708 : 8475 : || !rdt)
2709 : 9359 : c->initializer = gfc_get_null_expr (NULL);
2710 : : else
2711 : : {
2712 : : /* Set up namespace. */
2713 : 102 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2714 : :
2715 : 102 : sub_ns->sibling = ns->contained;
2716 : 102 : ns->contained = sub_ns;
2717 : 102 : sub_ns->resolved = 1;
2718 : : /* Set up procedure symbol. */
2719 : 102 : free (name);
2720 : 102 : name = xasprintf ("__deallocate_%s", tname);
2721 : 102 : gfc_get_symbol (name, sub_ns, &dealloc);
2722 : 102 : sub_ns->proc_name = dealloc;
2723 : 102 : dealloc->attr.flavor = FL_PROCEDURE;
2724 : 102 : dealloc->attr.subroutine = 1;
2725 : 102 : dealloc->attr.pure = 1;
2726 : 102 : dealloc->attr.artificial = 1;
2727 : 102 : dealloc->attr.if_source = IFSRC_DECL;
2728 : :
2729 : 102 : if (ns->proc_name->attr.flavor == FL_MODULE)
2730 : 74 : dealloc->module = ns->proc_name->name;
2731 : 102 : gfc_set_sym_referenced (dealloc);
2732 : : /* Set up formal argument. */
2733 : 102 : gfc_get_symbol ("arg", sub_ns, &arg);
2734 : 102 : arg->ts.type = BT_DERIVED;
2735 : 102 : arg->ts.u.derived = derived;
2736 : 102 : arg->attr.flavor = FL_VARIABLE;
2737 : 102 : arg->attr.dummy = 1;
2738 : 102 : arg->attr.artificial = 1;
2739 : 102 : arg->attr.intent = INTENT_INOUT;
2740 : 102 : arg->attr.dimension = 1;
2741 : 102 : arg->attr.allocatable = 1;
2742 : 102 : arg->as = gfc_get_array_spec();
2743 : 102 : arg->as->type = AS_ASSUMED_SHAPE;
2744 : 102 : arg->as->rank = 1;
2745 : 102 : arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
2746 : : NULL, 1);
2747 : 102 : gfc_set_sym_referenced (arg);
2748 : 102 : dealloc->formal = gfc_get_formal_arglist ();
2749 : 102 : dealloc->formal->sym = arg;
2750 : : /* Set up code. */
2751 : 102 : sub_ns->code = gfc_get_code (EXEC_DEALLOCATE);
2752 : 102 : sub_ns->code->ext.alloc.list = gfc_get_alloc ();
2753 : 102 : sub_ns->code->ext.alloc.list->expr
2754 : 102 : = gfc_lval_expr_from_sym (arg);
2755 : : /* Set initializer. */
2756 : 102 : c->initializer = gfc_lval_expr_from_sym (dealloc);
2757 : 102 : c->ts.interface = dealloc;
2758 : : }
2759 : :
2760 : : /* Add procedure pointers for type-bound procedures. */
2761 : 9461 : if (!derived->attr.unlimited_polymorphic)
2762 : 8777 : add_procs_to_declared_vtab (derived, vtype);
2763 : : }
2764 : :
2765 : 0 : have_vtype:
2766 : 9464 : vtab->ts.u.derived = vtype;
2767 : 9464 : vtab->value = gfc_default_initializer (&vtab->ts);
2768 : : }
2769 : 71834 : free (name);
2770 : : }
2771 : :
2772 : 71834 : found_sym = vtab;
2773 : :
2774 : 71834 : cleanup:
2775 : : /* It is unexpected to have some symbols added at resolution or code
2776 : : generation time. We commit the changes in order to keep a clean state. */
2777 : 71834 : if (found_sym)
2778 : : {
2779 : 71834 : gfc_commit_symbol (vtab);
2780 : 71834 : if (vtype)
2781 : 9464 : gfc_commit_symbol (vtype);
2782 : 71834 : if (def_init)
2783 : 8475 : gfc_commit_symbol (def_init);
2784 : 71834 : if (copy)
2785 : 8475 : gfc_commit_symbol (copy);
2786 : 71834 : if (src)
2787 : 8475 : gfc_commit_symbol (src);
2788 : 71834 : if (dst)
2789 : 8475 : gfc_commit_symbol (dst);
2790 : 71834 : if (dealloc)
2791 : 102 : gfc_commit_symbol (dealloc);
2792 : 71834 : if (arg)
2793 : 102 : gfc_commit_symbol (arg);
2794 : : }
2795 : : else
2796 : 0 : gfc_undo_symbols ();
2797 : :
2798 : : return found_sym;
2799 : : }
2800 : :
2801 : :
2802 : : /* Check if a derived type is finalizable. That is the case if it
2803 : : (1) has a FINAL subroutine or
2804 : : (2) has a nonpointer nonallocatable component of finalizable type.
2805 : : If it is finalizable, return an expression containing the
2806 : : finalization wrapper. */
2807 : :
2808 : : bool
2809 : 50466 : gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
2810 : : {
2811 : 50466 : gfc_symbol *vtab;
2812 : 50466 : gfc_component *c;
2813 : :
2814 : : /* (1) Check for FINAL subroutines. */
2815 : 50466 : if (derived->f2k_derived && derived->f2k_derived->finalizers)
2816 : 4563 : goto yes;
2817 : :
2818 : : /* (2) Check for components of finalizable type. */
2819 : 129120 : for (c = derived->components; c; c = c->next)
2820 : 83676 : if (c->ts.type == BT_DERIVED
2821 : 18308 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
2822 : 89701 : && gfc_is_finalizable (c->ts.u.derived, NULL))
2823 : 459 : goto yes;
2824 : :
2825 : : return false;
2826 : :
2827 : 5022 : yes:
2828 : : /* Make sure vtab is generated. */
2829 : 5022 : vtab = gfc_find_derived_vtab (derived);
2830 : 5022 : if (final_expr)
2831 : : {
2832 : : /* Return finalizer expression. */
2833 : 710 : gfc_component *final;
2834 : 710 : final = vtab->ts.u.derived->components->next->next->next->next->next;
2835 : 710 : gcc_assert (strcmp (final->name, "_final") == 0);
2836 : 710 : gcc_assert (final->initializer
2837 : : && final->initializer->expr_type != EXPR_NULL);
2838 : 710 : *final_expr = final->initializer;
2839 : : }
2840 : : return true;
2841 : : }
2842 : :
2843 : :
2844 : : bool
2845 : 314677 : gfc_may_be_finalized (gfc_typespec ts)
2846 : : {
2847 : 314677 : return (ts.type == BT_CLASS || (ts.type == BT_DERIVED
2848 : 23564 : && ts.u.derived && gfc_is_finalizable (ts.u.derived, NULL)));
2849 : : }
2850 : :
2851 : :
2852 : : /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2853 : : needed to support unlimited polymorphism. */
2854 : :
2855 : : static gfc_symbol *
2856 : 5979 : find_intrinsic_vtab (gfc_typespec *ts)
2857 : : {
2858 : 5979 : gfc_namespace *ns;
2859 : 5979 : gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
2860 : 5979 : gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
2861 : :
2862 : : /* Find the top-level namespace. */
2863 : 7746 : for (ns = gfc_current_ns; ns; ns = ns->parent)
2864 : 7746 : if (!ns->parent)
2865 : : break;
2866 : :
2867 : 5979 : if (ns)
2868 : : {
2869 : 5979 : char tname[GFC_MAX_SYMBOL_LEN+1];
2870 : 5979 : char *name;
2871 : :
2872 : : /* Encode all types as TYPENAME_KIND_ including especially character
2873 : : arrays, whose length is now consistently stored in the _len component
2874 : : of the class-variable. */
2875 : 5979 : sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
2876 : 5979 : name = xasprintf ("__vtab_%s", tname);
2877 : :
2878 : : /* Look for the vtab symbol in the top-level namespace only. */
2879 : 5979 : gfc_find_symbol (name, ns, 0, &vtab);
2880 : :
2881 : 5979 : if (vtab == NULL)
2882 : : {
2883 : 814 : gfc_get_symbol (name, ns, &vtab);
2884 : 814 : vtab->ts.type = BT_DERIVED;
2885 : 814 : if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
2886 : : &gfc_current_locus))
2887 : 0 : goto cleanup;
2888 : 814 : vtab->attr.target = 1;
2889 : 814 : vtab->attr.save = SAVE_IMPLICIT;
2890 : 814 : vtab->attr.vtab = 1;
2891 : 814 : vtab->attr.access = ACCESS_PUBLIC;
2892 : 814 : gfc_set_sym_referenced (vtab);
2893 : 814 : free (name);
2894 : 814 : name = xasprintf ("__vtype_%s", tname);
2895 : :
2896 : 814 : gfc_find_symbol (name, ns, 0, &vtype);
2897 : 814 : if (vtype == NULL)
2898 : : {
2899 : 814 : gfc_component *c;
2900 : 814 : int hash;
2901 : 814 : gfc_namespace *sub_ns;
2902 : 814 : gfc_namespace *contained;
2903 : 814 : gfc_expr *e;
2904 : 814 : size_t e_size;
2905 : :
2906 : 814 : gfc_get_symbol (name, ns, &vtype);
2907 : 814 : if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
2908 : : &gfc_current_locus))
2909 : 0 : goto cleanup;
2910 : 814 : vtype->attr.access = ACCESS_PUBLIC;
2911 : 814 : vtype->attr.vtype = 1;
2912 : 814 : gfc_set_sym_referenced (vtype);
2913 : :
2914 : : /* Add component '_hash'. */
2915 : 814 : if (!gfc_add_component (vtype, "_hash", &c))
2916 : 0 : goto cleanup;
2917 : 814 : c->ts.type = BT_INTEGER;
2918 : 814 : c->ts.kind = 4;
2919 : 814 : c->attr.access = ACCESS_PRIVATE;
2920 : 814 : hash = gfc_intrinsic_hash_value (ts);
2921 : 814 : c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2922 : : NULL, hash);
2923 : :
2924 : : /* Add component '_size'. */
2925 : 814 : if (!gfc_add_component (vtype, "_size", &c))
2926 : 0 : goto cleanup;
2927 : 814 : c->ts.type = BT_INTEGER;
2928 : 814 : c->ts.kind = gfc_size_kind;
2929 : 814 : c->attr.access = ACCESS_PRIVATE;
2930 : :
2931 : : /* Build a minimal expression to make use of
2932 : : target-memory.cc/gfc_element_size for 'size'. Special handling
2933 : : for character arrays, that are not constant sized: to support
2934 : : len (str) * kind, only the kind information is stored in the
2935 : : vtab. */
2936 : 814 : e = gfc_get_expr ();
2937 : 814 : e->ts = *ts;
2938 : 814 : e->expr_type = EXPR_VARIABLE;
2939 : 814 : if (ts->type == BT_CHARACTER)
2940 : 257 : e_size = ts->kind;
2941 : : else
2942 : 557 : gfc_element_size (e, &e_size);
2943 : 814 : c->initializer = gfc_get_int_expr (gfc_size_kind,
2944 : : NULL,
2945 : : e_size);
2946 : 814 : gfc_free_expr (e);
2947 : :
2948 : : /* Add component _extends. */
2949 : 814 : if (!gfc_add_component (vtype, "_extends", &c))
2950 : 0 : goto cleanup;
2951 : 814 : c->attr.pointer = 1;
2952 : 814 : c->attr.access = ACCESS_PRIVATE;
2953 : 814 : c->ts.type = BT_VOID;
2954 : 814 : c->initializer = gfc_get_null_expr (NULL);
2955 : :
2956 : : /* Add component _def_init. */
2957 : 814 : if (!gfc_add_component (vtype, "_def_init", &c))
2958 : 0 : goto cleanup;
2959 : 814 : c->attr.pointer = 1;
2960 : 814 : c->attr.access = ACCESS_PRIVATE;
2961 : 814 : c->ts.type = BT_VOID;
2962 : 814 : c->initializer = gfc_get_null_expr (NULL);
2963 : :
2964 : : /* Add component _copy. */
2965 : 814 : if (!gfc_add_component (vtype, "_copy", &c))
2966 : 0 : goto cleanup;
2967 : 814 : c->attr.proc_pointer = 1;
2968 : 814 : c->attr.access = ACCESS_PRIVATE;
2969 : 814 : c->tb = XCNEW (gfc_typebound_proc);
2970 : 814 : c->tb->ppc = 1;
2971 : :
2972 : 814 : free (name);
2973 : 814 : if (ts->type != BT_CHARACTER)
2974 : 557 : name = xasprintf ("__copy_%s", tname);
2975 : : else
2976 : : {
2977 : : /* __copy is always the same for characters.
2978 : : Check to see if copy function already exists. */
2979 : 257 : name = xasprintf ("__copy_character_%d", ts->kind);
2980 : 257 : contained = ns->contained;
2981 : 1298 : for (; contained; contained = contained->sibling)
2982 : 1041 : if (contained->proc_name
2983 : 1041 : && strcmp (name, contained->proc_name->name) == 0)
2984 : : {
2985 : 0 : copy = contained->proc_name;
2986 : 0 : goto got_char_copy;
2987 : : }
2988 : : }
2989 : :
2990 : : /* Set up namespace. */
2991 : 814 : sub_ns = gfc_get_namespace (ns, 0);
2992 : 814 : sub_ns->sibling = ns->contained;
2993 : 814 : ns->contained = sub_ns;
2994 : 814 : sub_ns->resolved = 1;
2995 : : /* Set up procedure symbol. */
2996 : 814 : gfc_get_symbol (name, sub_ns, ©);
2997 : 814 : sub_ns->proc_name = copy;
2998 : 814 : copy->attr.flavor = FL_PROCEDURE;
2999 : 814 : copy->attr.subroutine = 1;
3000 : 814 : copy->attr.pure = 1;
3001 : 814 : copy->attr.if_source = IFSRC_DECL;
3002 : : /* This is elemental so that arrays are automatically
3003 : : treated correctly by the scalarizer. */
3004 : 814 : copy->attr.elemental = 1;
3005 : 814 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
3006 : 191 : copy->module = ns->proc_name->name;
3007 : 814 : gfc_set_sym_referenced (copy);
3008 : : /* Set up formal arguments. */
3009 : 814 : gfc_get_symbol ("src", sub_ns, &src);
3010 : 814 : src->ts.type = ts->type;
3011 : 814 : src->ts.kind = ts->kind;
3012 : 814 : src->attr.flavor = FL_VARIABLE;
3013 : 814 : src->attr.dummy = 1;
3014 : 814 : src->attr.intent = INTENT_IN;
3015 : 814 : gfc_set_sym_referenced (src);
3016 : 814 : copy->formal = gfc_get_formal_arglist ();
3017 : 814 : copy->formal->sym = src;
3018 : 814 : gfc_get_symbol ("dst", sub_ns, &dst);
3019 : 814 : dst->ts.type = ts->type;
3020 : 814 : dst->ts.kind = ts->kind;
3021 : 814 : dst->attr.flavor = FL_VARIABLE;
3022 : 814 : dst->attr.dummy = 1;
3023 : 814 : dst->attr.intent = INTENT_INOUT;
3024 : 814 : gfc_set_sym_referenced (dst);
3025 : 814 : copy->formal->next = gfc_get_formal_arglist ();
3026 : 814 : copy->formal->next->sym = dst;
3027 : : /* Set up code. */
3028 : 814 : sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
3029 : 814 : sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
3030 : 814 : sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
3031 : 814 : got_char_copy:
3032 : : /* Set initializer. */
3033 : 814 : c->initializer = gfc_lval_expr_from_sym (copy);
3034 : 814 : c->ts.interface = copy;
3035 : :
3036 : : /* Add component _final. */
3037 : 814 : if (!gfc_add_component (vtype, "_final", &c))
3038 : 0 : goto cleanup;
3039 : 814 : c->attr.proc_pointer = 1;
3040 : 814 : c->attr.access = ACCESS_PRIVATE;
3041 : 814 : c->attr.artificial = 1;
3042 : 814 : c->tb = XCNEW (gfc_typebound_proc);
3043 : 814 : c->tb->ppc = 1;
3044 : 814 : c->initializer = gfc_get_null_expr (NULL);
3045 : : }
3046 : 814 : vtab->ts.u.derived = vtype;
3047 : 814 : vtab->value = gfc_default_initializer (&vtab->ts);
3048 : : }
3049 : 5979 : free (name);
3050 : : }
3051 : :
3052 : 5979 : found_sym = vtab;
3053 : :
3054 : 5979 : cleanup:
3055 : : /* It is unexpected to have some symbols added at resolution or code
3056 : : generation time. We commit the changes in order to keep a clean state. */
3057 : 5979 : if (found_sym)
3058 : : {
3059 : 5979 : gfc_commit_symbol (vtab);
3060 : 5979 : if (vtype)
3061 : 814 : gfc_commit_symbol (vtype);
3062 : 5979 : if (copy)
3063 : 814 : gfc_commit_symbol (copy);
3064 : 5979 : if (src)
3065 : 814 : gfc_commit_symbol (src);
3066 : 5979 : if (dst)
3067 : 814 : gfc_commit_symbol (dst);
3068 : : }
3069 : : else
3070 : 0 : gfc_undo_symbols ();
3071 : :
3072 : 5979 : return found_sym;
3073 : : }
3074 : :
3075 : :
3076 : : /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
3077 : :
3078 : : gfc_symbol *
3079 : 17889 : gfc_find_vtab (gfc_typespec *ts)
3080 : : {
3081 : 17889 : switch (ts->type)
3082 : : {
3083 : : case BT_UNKNOWN:
3084 : : return NULL;
3085 : 6983 : case BT_DERIVED:
3086 : 6983 : return gfc_find_derived_vtab (ts->u.derived);
3087 : 4857 : case BT_CLASS:
3088 : 4857 : if (ts->u.derived->attr.is_class
3089 : 4853 : && ts->u.derived->components
3090 : 4853 : && ts->u.derived->components->ts.u.derived)
3091 : 4853 : return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
3092 : : else
3093 : : return NULL;
3094 : 5979 : default:
3095 : 5979 : return find_intrinsic_vtab (ts);
3096 : : }
3097 : : }
3098 : :
3099 : :
3100 : : /* General worker function to find either a type-bound procedure or a
3101 : : type-bound user operator. */
3102 : :
3103 : : static gfc_symtree*
3104 : 409596 : find_typebound_proc_uop (gfc_symbol* derived, bool* t,
3105 : : const char* name, bool noaccess, bool uop,
3106 : : locus* where)
3107 : : {
3108 : 409596 : gfc_symtree* res;
3109 : 409596 : gfc_symtree* root;
3110 : :
3111 : : /* Set default to failure. */
3112 : 409596 : if (t)
3113 : 390632 : *t = false;
3114 : :
3115 : 409596 : if (derived->f2k_derived)
3116 : : /* Set correct symbol-root. */
3117 : 309551 : root = (uop ? derived->f2k_derived->tb_uop_root
3118 : : : derived->f2k_derived->tb_sym_root);
3119 : : else
3120 : : return NULL;
3121 : :
3122 : : /* Try to find it in the current type's namespace. */
3123 : 309551 : res = gfc_find_symtree (root, name);
3124 : 309551 : if (res && res->n.tb && !res->n.tb->error)
3125 : : {
3126 : : /* We found one. */
3127 : 10187 : if (t)
3128 : 5765 : *t = true;
3129 : :
3130 : 10187 : if (!noaccess && derived->attr.use_assoc
3131 : 3168 : && res->n.tb->access == ACCESS_PRIVATE)
3132 : : {
3133 : 3 : if (where)
3134 : 2 : gfc_error ("%qs of %qs is PRIVATE at %L",
3135 : : name, derived->name, where);
3136 : 3 : if (t)
3137 : 3 : *t = false;
3138 : : }
3139 : :
3140 : 10187 : return res;
3141 : : }
3142 : :
3143 : : /* Otherwise, recurse on parent type if derived is an extension. */
3144 : 299364 : if (derived->attr.extension)
3145 : : {
3146 : 42812 : gfc_symbol* super_type;
3147 : 42812 : super_type = gfc_get_derived_super_type (derived);
3148 : 42812 : gcc_assert (super_type);
3149 : :
3150 : 42812 : return find_typebound_proc_uop (super_type, t, name,
3151 : 42812 : noaccess, uop, where);
3152 : : }
3153 : :
3154 : : /* Nothing found. */
3155 : : return NULL;
3156 : : }
3157 : :
3158 : :
3159 : : /* Find a type-bound procedure or user operator by name for a derived-type
3160 : : (looking recursively through the super-types). */
3161 : :
3162 : : gfc_symtree*
3163 : 366606 : gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
3164 : : const char* name, bool noaccess, locus* where)
3165 : : {
3166 : 366606 : return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
3167 : : }
3168 : :
3169 : : gfc_symtree*
3170 : 178 : gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
3171 : : const char* name, bool noaccess, locus* where)
3172 : : {
3173 : 178 : return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
3174 : : }
3175 : :
3176 : :
3177 : : /* Find a type-bound intrinsic operator looking recursively through the
3178 : : super-type hierarchy. */
3179 : :
3180 : : gfc_typebound_proc*
3181 : 20436 : gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
3182 : : gfc_intrinsic_op op, bool noaccess,
3183 : : locus* where)
3184 : : {
3185 : 20436 : gfc_typebound_proc* res;
3186 : :
3187 : : /* Set default to failure. */
3188 : 20436 : if (t)
3189 : 20435 : *t = false;
3190 : :
3191 : : /* Try to find it in the current type's namespace. */
3192 : 20436 : if (derived->f2k_derived)
3193 : 16796 : res = derived->f2k_derived->tb_op[op];
3194 : : else
3195 : : res = NULL;
3196 : :
3197 : : /* Check access. */
3198 : 16796 : if (res && !res->error)
3199 : : {
3200 : : /* We found one. */
3201 : 859 : if (t)
3202 : 858 : *t = true;
3203 : :
3204 : 859 : if (!noaccess && derived->attr.use_assoc
3205 : 724 : && res->access == ACCESS_PRIVATE)
3206 : : {
3207 : 2 : if (where)
3208 : 0 : gfc_error ("%qs of %qs is PRIVATE at %L",
3209 : : gfc_op2string (op), derived->name, where);
3210 : 2 : if (t)
3211 : 2 : *t = false;
3212 : : }
3213 : :
3214 : 859 : return res;
3215 : : }
3216 : :
3217 : : /* Otherwise, recurse on parent type if derived is an extension. */
3218 : 19577 : if (derived->attr.extension)
3219 : : {
3220 : 798 : gfc_symbol* super_type;
3221 : 798 : super_type = gfc_get_derived_super_type (derived);
3222 : 798 : gcc_assert (super_type);
3223 : :
3224 : 798 : return gfc_find_typebound_intrinsic_op (super_type, t, op,
3225 : 798 : noaccess, where);
3226 : : }
3227 : :
3228 : : /* Nothing found. */
3229 : : return NULL;
3230 : : }
3231 : :
3232 : :
3233 : : /* Get a typebound-procedure symtree or create and insert it if not yet
3234 : : present. This is like a very simplified version of gfc_get_sym_tree for
3235 : : tbp-symtrees rather than regular ones. */
3236 : :
3237 : : gfc_symtree*
3238 : 8126 : gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
3239 : : {
3240 : 8126 : gfc_symtree *result = gfc_find_symtree (*root, name);
3241 : 8126 : return result ? result : gfc_new_symtree (root, name);
3242 : : }
|
