Line data Source code
1 : /* Implementation of Fortran 2003 Polymorphism.
2 : Copyright (C) 2009-2026 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 12435 : insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
76 : {
77 12435 : gfc_ref *new_ref;
78 12435 : int wcnt, ecnt;
79 :
80 12435 : gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
81 :
82 12435 : gfc_find_component (ts->u.derived, name, true, true, &new_ref);
83 :
84 12435 : gfc_get_errors (&wcnt, &ecnt);
85 12435 : if (ecnt > 0 && !new_ref)
86 1 : return;
87 12434 : gcc_assert (new_ref->u.c.component);
88 :
89 12434 : while (new_ref->next)
90 0 : new_ref = new_ref->next;
91 12434 : new_ref->next = *ref;
92 :
93 12434 : if (new_ref->next)
94 : {
95 12434 : 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 12434 : gcc_assert (strcmp (name, "_data") == 0);
101 :
102 12434 : if (new_ref->next->type == REF_COMPONENT)
103 : next = new_ref->next;
104 11863 : else if (new_ref->next->type == REF_ARRAY
105 11863 : && new_ref->next->next
106 2426 : && new_ref->next->next->type == REF_COMPONENT)
107 : next = new_ref->next->next;
108 :
109 2928 : if (next != NULL)
110 : {
111 2928 : gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
112 : || new_ref->u.c.component->ts.type == BT_DERIVED);
113 2928 : next->u.c.sym = new_ref->u.c.component->ts.u.derived;
114 : }
115 : }
116 :
117 12434 : *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 1423547 : 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 1423547 : if (ts->type != BT_CLASS)
131 : return false;
132 :
133 : /* Accessing a class container with an array reference is certainly wrong. */
134 119645 : if (ref->type != REF_COMPONENT)
135 : return true;
136 :
137 : /* Accessing the class container's fields is fine. */
138 107781 : 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 16114 : if (first_ref_in_chain && ts->u.derived->attr.extension)
154 15543 : 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 4704131 : gfc_fix_class_refs (gfc_expr *e)
169 : {
170 4704131 : gfc_typespec *ts;
171 4704131 : gfc_ref **ref;
172 :
173 4704131 : if ((e->expr_type != EXPR_VARIABLE
174 2046774 : && e->expr_type != EXPR_FUNCTION)
175 2970730 : || (e->expr_type == EXPR_FUNCTION
176 313373 : && e->value.function.isym != NULL))
177 : return;
178 :
179 2708463 : if (e->expr_type == EXPR_VARIABLE)
180 2657357 : ts = &e->symtree->n.sym->ts;
181 : else
182 : {
183 51106 : gfc_symbol *func;
184 :
185 51106 : gcc_assert (e->expr_type == EXPR_FUNCTION);
186 51106 : if (e->value.function.esym != NULL)
187 : func = e->value.function.esym;
188 : else
189 1647 : func = e->symtree->n.sym;
190 :
191 51106 : if (func->result != NULL)
192 49775 : ts = &func->result->ts;
193 : else
194 1331 : ts = &func->ts;
195 : }
196 :
197 4132010 : for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
198 : {
199 1423547 : if (class_data_ref_missing (ts, *ref, ref == &e->ref))
200 12435 : insert_component_ref (ts, ref, "_data");
201 :
202 1423547 : if ((*ref)->type == REF_COMPONENT)
203 305282 : 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 64023 : gfc_add_component_ref (gfc_expr *e, const char *name)
213 : {
214 64023 : gfc_component *c;
215 64023 : gfc_ref **tail = &(e->ref);
216 64023 : gfc_ref *ref, *next = NULL;
217 64023 : gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
218 91291 : while (*tail != NULL)
219 : {
220 43201 : if ((*tail)->type == REF_COMPONENT)
221 : {
222 26308 : if (strcmp ((*tail)->u.c.component->name, "_data") == 0
223 1492 : && (*tail)->next
224 1492 : && (*tail)->next->type == REF_ARRAY
225 1408 : && (*tail)->next->next == NULL)
226 : return;
227 25170 : derived = (*tail)->u.c.component->ts.u.derived;
228 : }
229 42063 : if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
230 : break;
231 27268 : tail = &((*tail)->next);
232 : }
233 62885 : if (derived && derived->components && derived->components->next &&
234 62878 : derived->components->next->ts.type == BT_DERIVED &&
235 48690 : 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 62885 : if (*tail != NULL && strcmp (name, "_data") == 0)
243 : next = *tail;
244 : else
245 : /* Avoid losing memory. */
246 54386 : gfc_free_ref_list (*tail);
247 62885 : c = gfc_find_component (derived, name, true, true, tail);
248 :
249 62885 : if (c) {
250 62877 : for (ref = *tail; ref->next; ref = ref->next)
251 : ;
252 62877 : ref->next = next;
253 62877 : if (!next)
254 54378 : 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 5249 : gfc_add_class_array_ref (gfc_expr *e)
265 : {
266 5249 : int rank = CLASS_DATA (e)->as->rank;
267 5249 : int corank = CLASS_DATA (e)->as->corank;
268 5249 : gfc_array_spec *as = CLASS_DATA (e)->as;
269 5249 : gfc_ref *ref = NULL;
270 5249 : gfc_add_data_component (e);
271 5249 : e->rank = rank;
272 5249 : e->corank = corank;
273 10020 : for (ref = e->ref; ref; ref = ref->next)
274 10019 : if (!ref->next)
275 : break;
276 5249 : if (ref && ref->type != REF_ARRAY)
277 : {
278 1241 : ref->next = gfc_get_ref ();
279 1241 : ref = ref->next;
280 1241 : ref->type = REF_ARRAY;
281 1241 : ref->u.ar.type = AR_FULL;
282 1241 : ref->u.ar.as = as;
283 : }
284 5249 : }
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 7710 : class_array_ref_detected (gfc_ref *ref, bool *full_array)
294 : {
295 7710 : bool no_data = false;
296 7710 : bool with_data = false;
297 :
298 : /* An array reference with no _data component. */
299 7710 : if (ref && ref->type == REF_ARRAY
300 457 : && !ref->next
301 457 : && ref->u.ar.type != AR_ELEMENT)
302 : {
303 457 : if (full_array)
304 457 : *full_array = ref->u.ar.type == AR_FULL;
305 : no_data = true;
306 : }
307 :
308 : /* Cover cases where _data appears, with or without an array ref. */
309 7679 : if (ref && ref->type == REF_COMPONENT
310 7222 : && strcmp (ref->u.c.component->name, "_data") == 0)
311 : {
312 7216 : if (!ref->next)
313 : {
314 0 : with_data = true;
315 0 : if (full_array)
316 0 : *full_array = true;
317 : }
318 7216 : else if (ref->next && ref->next->type == REF_ARRAY
319 : && ref->type == REF_COMPONENT
320 7216 : && ref->next->u.ar.type != AR_ELEMENT)
321 : {
322 6783 : with_data = true;
323 6783 : if (full_array)
324 3003 : *full_array = ref->next->u.ar.type == AR_FULL;
325 : }
326 : }
327 :
328 7710 : 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 282454 : gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
337 : {
338 282454 : gfc_ref *ref;
339 :
340 282454 : if (!e->rank)
341 : return false;
342 :
343 243294 : if (full_array)
344 3490 : *full_array= false;
345 :
346 : /* Is this a class array object? ie. Is the symbol of type class? */
347 243294 : if (e->symtree
348 198817 : && e->symtree->n.sym->ts.type == BT_CLASS
349 7481 : && CLASS_DATA (e->symtree->n.sym)
350 7481 : && CLASS_DATA (e->symtree->n.sym)->attr.dimension
351 249722 : && class_array_ref_detected (e->ref, full_array))
352 : return true;
353 :
354 : /* Or is this a class array component reference? */
355 441805 : for (ref = e->ref; ref; ref = ref->next)
356 : {
357 205751 : if (ref->type == REF_COMPONENT
358 22215 : && ref->u.c.component->ts.type == BT_CLASS
359 1440 : && CLASS_DATA (ref->u.c.component)->attr.dimension
360 207033 : && 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 49832 : gfc_is_class_scalar_expr (gfc_expr *e)
375 : {
376 49832 : gfc_ref *ref;
377 :
378 49832 : if (e->rank)
379 : return false;
380 :
381 : /* Is this a class object? */
382 44298 : if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS
383 2237 : && CLASS_DATA (e->symtree->n.sym)
384 2237 : && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
385 1931 : && (e->ref == NULL
386 1488 : || (e->ref->type == REF_COMPONENT
387 1486 : && strcmp (e->ref->u.c.component->name, "_data") == 0
388 1163 : && (e->ref->next == NULL
389 37 : || (e->ref->next->type == REF_ARRAY
390 37 : && e->ref->next->u.ar.codimen > 0
391 37 : && e->ref->next->u.ar.dimen == 0
392 37 : && e->ref->next->next == NULL)))))
393 : return true;
394 :
395 : /* Or is the final reference BT_CLASS or _data? */
396 46428 : for (ref = e->ref; ref; ref = ref->next)
397 : {
398 4221 : if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS
399 601 : && CLASS_DATA (ref->u.c.component)
400 601 : && !CLASS_DATA (ref->u.c.component)->attr.dimension
401 535 : && (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 1628 : gfc_is_class_container_ref (gfc_expr *e)
423 : {
424 1628 : gfc_ref *ref;
425 1628 : bool result;
426 :
427 1628 : if (e->expr_type != EXPR_VARIABLE)
428 266 : return e->ts.type == BT_CLASS;
429 :
430 1362 : if (e->symtree->n.sym->ts.type == BT_CLASS)
431 : result = true;
432 : else
433 1134 : result = false;
434 :
435 2919 : for (ref = e->ref; ref; ref = ref->next)
436 : {
437 1557 : if (ref->type != REF_COMPONENT)
438 : result = false;
439 295 : else if (ref->u.c.component->ts.type == BT_CLASS)
440 : result = true;
441 : else
442 1557 : 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 3619 : gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
455 : {
456 3619 : gfc_expr *init;
457 3619 : gfc_component *comp;
458 3619 : gfc_symbol *vtab = NULL;
459 :
460 3619 : if (init_expr && init_expr->expr_type != EXPR_NULL)
461 1750 : vtab = gfc_find_vtab (&init_expr->ts);
462 : else
463 1869 : vtab = gfc_find_vtab (ts);
464 :
465 7238 : init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
466 3619 : &ts->u.derived->declared_at);
467 3619 : init->ts = *ts;
468 :
469 11427 : for (comp = ts->u.derived->components; comp; comp = comp->next)
470 : {
471 7808 : gfc_constructor *ctor = gfc_constructor_get();
472 7808 : if (strcmp (comp->name, "_vptr") == 0 && vtab)
473 3619 : ctor->expr = gfc_lval_expr_from_sym (vtab);
474 4189 : else if (init_expr && init_expr->expr_type != EXPR_NULL)
475 2006 : ctor->expr = gfc_copy_expr (init_expr);
476 : else
477 2183 : ctor->expr = gfc_get_null_expr (NULL);
478 7808 : gfc_constructor_append (&init->value.constructor, ctor);
479 : }
480 :
481 3619 : 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 115304 : get_unique_type_string (gfc_symbol *derived)
491 : {
492 115304 : const char *dt_name;
493 115304 : char *string;
494 115304 : size_t len;
495 115304 : if (derived->attr.unlimited_polymorphic)
496 : dt_name = "STAR";
497 : else
498 107789 : dt_name = gfc_dt_upper_string (derived->name);
499 115304 : len = strlen (dt_name) + 2;
500 115304 : if (derived->attr.unlimited_polymorphic)
501 : {
502 7515 : string = XNEWVEC (char, len);
503 7515 : sprintf (string, "_%s", dt_name);
504 : }
505 107789 : else if (derived->module)
506 : {
507 43725 : string = XNEWVEC (char, strlen (derived->module) + len);
508 43725 : sprintf (string, "%s_%s", derived->module, dt_name);
509 : }
510 64064 : else if (derived->ns->proc_name)
511 : {
512 63269 : string = XNEWVEC (char, strlen (derived->ns->proc_name->name) + len);
513 63269 : sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
514 : }
515 : else
516 : {
517 795 : string = XNEWVEC (char, len);
518 795 : sprintf (string, "_%s", dt_name);
519 : }
520 115304 : 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 98771 : get_unique_hashed_string (char *string, gfc_symbol *derived)
529 : {
530 : /* Provide sufficient space to hold "symbol.symbol_symbol". */
531 98771 : char *tmp;
532 98771 : 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 98771 : if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
538 : {
539 141 : int h = gfc_hash_value (derived);
540 141 : sprintf (string, "%X", h);
541 : }
542 : else
543 98630 : strcpy (string, tmp);
544 98771 : free (tmp);
545 98771 : }
546 :
547 :
548 : /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
549 :
550 : unsigned int
551 16533 : gfc_hash_value (gfc_symbol *sym)
552 : {
553 16533 : unsigned int hash = 0;
554 : /* Provide sufficient space to hold "symbol.symbol_symbol". */
555 16533 : char *c;
556 16533 : int i, len;
557 :
558 16533 : c = get_unique_type_string (sym);
559 16533 : len = strlen (c);
560 :
561 261396 : for (i = 0; i < len; i++)
562 244863 : hash = (hash << 6) + (hash << 16) - hash + c[i];
563 :
564 16533 : 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 16533 : 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 985 : gfc_intrinsic_hash_value (gfc_typespec *ts)
575 : {
576 985 : unsigned int hash = 0;
577 985 : const char *c = gfc_typename (ts, true);
578 985 : int i, len;
579 :
580 985 : len = strlen (c);
581 :
582 10741 : for (i = 0; i < len; i++)
583 9756 : 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 985 : 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 traverses 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 373 : gfc_get_len_component (gfc_expr *e, int k)
599 : {
600 373 : gfc_expr *ptr;
601 373 : gfc_ref *ref, **last;
602 :
603 373 : ptr = gfc_copy_expr (e);
604 :
605 : /* We need to remove the last _data component ref from ptr. */
606 373 : last = &(ptr->ref);
607 373 : ref = ptr->ref;
608 373 : while (ref)
609 : {
610 373 : if (!ref->next
611 373 : && ref->type == REF_COMPONENT
612 373 : && strcmp ("_data", ref->u.c.component->name)== 0)
613 : {
614 373 : gfc_free_ref_list (ref);
615 373 : *last = NULL;
616 373 : 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 373 : gfc_add_len_component (ptr);
623 373 : if (k != ptr->ts.kind)
624 : {
625 373 : gfc_typespec ts;
626 373 : gfc_clear_ts (&ts);
627 373 : ts.type = BT_INTEGER;
628 373 : ts.kind = k;
629 373 : gfc_convert_type_warn (ptr, &ts, 2, 0);
630 : }
631 373 : 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 13857 : gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
645 : gfc_array_spec **as)
646 : {
647 13857 : char tname[GFC_MAX_SYMBOL_LEN+1];
648 13857 : char *name;
649 13857 : gfc_typespec *orig_ts = ts;
650 13857 : gfc_symbol *fclass;
651 13857 : gfc_symbol *vtab;
652 13857 : gfc_component *c;
653 13857 : gfc_namespace *ns;
654 13857 : int rank;
655 :
656 13857 : gcc_assert (as);
657 :
658 : /* We cannot build the class container now. */
659 13857 : 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 13856 : 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 13855 : 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 6688 : attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
679 14133 : || attr->select_type_temporary || attr->associate_var;
680 :
681 13855 : 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 13785 : rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
687 :
688 13785 : if (!ts->u.derived)
689 : return false;
690 :
691 13780 : get_unique_hashed_string (tname, ts->u.derived);
692 13780 : if ((*as) && attr->allocatable)
693 2157 : name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
694 11623 : else if ((*as) && attr->pointer)
695 1313 : name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
696 10310 : else if ((*as))
697 1341 : name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
698 8969 : else if (attr->pointer)
699 1849 : name = xasprintf ("__class_%s_p", tname);
700 7120 : else if (attr->allocatable)
701 2308 : name = xasprintf ("__class_%s_a", tname);
702 : else
703 4812 : name = xasprintf ("__class_%s_t", tname);
704 :
705 13780 : if (ts->u.derived->attr.unlimited_polymorphic)
706 : {
707 : /* Find the top-level namespace. */
708 5129 : for (ns = gfc_current_ns; ns; ns = ns->parent)
709 5129 : if (!ns->parent)
710 : break;
711 : }
712 : else
713 11001 : 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 13780 : if (attr->dummy && (*as)
721 2029 : && ((!attr->codimension
722 1859 : && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
723 1790 : || (attr->codimension
724 170 : && !((*as)->cotype == AS_DEFERRED
725 : || (*as)->cotype == AS_ASSUMED_RANK))))
726 : {
727 340 : char *sname;
728 340 : ns = gfc_current_ns;
729 340 : 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 340 : 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 13440 : gfc_find_symbol (name, ns, 0, &fclass);
742 :
743 13780 : if (fclass == NULL)
744 : {
745 8380 : gfc_symtree *st;
746 : /* If not there, create a new symbol. */
747 8380 : fclass = gfc_new_symbol (name, ns);
748 8380 : st = gfc_new_symtree (&ns->sym_root, name);
749 8380 : st->n.sym = fclass;
750 8380 : gfc_set_sym_referenced (fclass);
751 8380 : fclass->refs++;
752 8380 : fclass->ts.type = BT_UNKNOWN;
753 8380 : if (!ts->u.derived->attr.unlimited_polymorphic)
754 6685 : fclass->attr.abstract = ts->u.derived->attr.abstract;
755 8380 : fclass->f2k_derived = gfc_get_namespace (NULL, 0);
756 8380 : if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
757 : &gfc_current_locus))
758 : return false;
759 :
760 : /* Add component '_data'. */
761 8380 : if (!gfc_add_component (fclass, "_data", &c))
762 : return false;
763 8380 : c->ts = *ts;
764 8380 : c->ts.type = BT_DERIVED;
765 8380 : c->attr.access = ACCESS_PRIVATE;
766 8380 : c->ts.u.derived = ts->u.derived;
767 8380 : c->attr.class_pointer = attr->pointer;
768 6575 : c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
769 11330 : || attr->select_type_temporary;
770 8380 : c->attr.allocatable = attr->allocatable;
771 8380 : c->attr.dimension = attr->dimension;
772 8380 : c->attr.codimension = attr->codimension;
773 8380 : c->attr.abstract = fclass->attr.abstract;
774 8380 : c->as = (*as);
775 8380 : c->initializer = NULL;
776 :
777 : /* Add component '_vptr'. */
778 8380 : if (!gfc_add_component (fclass, "_vptr", &c))
779 : return false;
780 8380 : c->ts.type = BT_DERIVED;
781 8380 : c->attr.access = ACCESS_PRIVATE;
782 8380 : c->attr.pointer = 1;
783 :
784 8380 : if (ts->u.derived->attr.unlimited_polymorphic)
785 : {
786 1695 : vtab = gfc_find_derived_vtab (ts->u.derived);
787 1695 : gcc_assert (vtab);
788 1695 : 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 1695 : if (!gfc_add_component (fclass, "_len", &c))
794 : return false;
795 1695 : c->ts.type = BT_INTEGER;
796 1695 : c->ts.kind = gfc_charlen_int_kind;
797 1695 : c->attr.access = ACCESS_PRIVATE;
798 1695 : c->attr.artificial = 1;
799 : }
800 : else
801 : /* Build vtab later. */
802 6685 : c->ts.u.derived = NULL;
803 : }
804 :
805 13780 : 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 11001 : 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 11001 : fclass->attr.extension = ts->u.derived->attr.extension + 1;
817 11001 : fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
818 11001 : fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
819 : }
820 :
821 13780 : fclass->attr.is_class = 1;
822 13780 : orig_ts->u.derived = fclass;
823 13780 : attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
824 13780 : (*as) = NULL;
825 13780 : free (name);
826 13780 : 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 4881 : add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
885 : {
886 4881 : gfc_component *c;
887 4881 : bool is_abstract = false;
888 :
889 4881 : 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 4881 : if (c && c->tb && c->tb->u.specific
894 1338 : && c->tb->u.specific->n.sym->attr.abstract)
895 4881 : 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 4881 : if (tb->non_overridable && !tb->overridden && !is_abstract && c)
902 7 : return;
903 :
904 4874 : if (c == NULL)
905 : {
906 : /* Add procedure component. */
907 3525 : if (!gfc_add_component (vtype, name, &c))
908 : return;
909 :
910 3525 : if (!c->tb)
911 3525 : c->tb = XCNEW (gfc_typebound_proc);
912 3525 : *c->tb = *tb;
913 3525 : c->tb->ppc = 1;
914 3525 : c->attr.procedure = 1;
915 3525 : c->attr.proc_pointer = 1;
916 3525 : c->attr.flavor = FL_PROCEDURE;
917 3525 : c->attr.access = ACCESS_PRIVATE;
918 3525 : c->attr.external = 1;
919 3525 : c->attr.untyped = 1;
920 3525 : c->attr.if_source = IFSRC_IFBODY;
921 : }
922 1349 : else if (c->attr.proc_pointer && c->tb)
923 : {
924 1349 : *c->tb = *tb;
925 1349 : c->tb->ppc = 1;
926 : }
927 :
928 4874 : if (tb->u.specific)
929 : {
930 4856 : gfc_symbol *ifc = tb->u.specific->n.sym;
931 4856 : c->ts.interface = ifc;
932 4856 : if (!tb->deferred)
933 4125 : c->initializer = gfc_get_variable_expr (tb->u.specific);
934 4856 : 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 4792 : add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
943 : {
944 4792 : if (!st)
945 : return;
946 :
947 4792 : if (st->left)
948 1196 : add_procs_to_declared_vtab1 (st->left, vtype);
949 :
950 4792 : if (st->right)
951 1185 : add_procs_to_declared_vtab1 (st->right, vtype);
952 :
953 4792 : if (st->n.tb && !st->n.tb->error
954 4730 : && !st->n.tb->is_generic && st->n.tb->u.specific)
955 4059 : 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 1588 : copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
963 : {
964 1588 : gfc_component *cmp;
965 1588 : gfc_symbol *vtab;
966 :
967 1588 : vtab = gfc_find_derived_vtab (declared);
968 :
969 13562 : for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
970 : {
971 11974 : if (gfc_find_component (vtype, cmp->name, true, true, NULL))
972 11152 : continue;
973 :
974 822 : add_proc_comp (vtype, cmp->name, cmp->tb);
975 : }
976 1588 : }
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 10704 : has_finalizer_component (gfc_symbol *derived)
985 : {
986 10704 : gfc_component *c;
987 :
988 23309 : for (c = derived->components; c; c = c->next)
989 12647 : if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
990 2054 : && c->attr.flavor != FL_PROCEDURE)
991 : {
992 2048 : if (c->ts.u.derived->f2k_derived
993 1945 : && 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 2006 : if (!gfc_compare_derived_types (derived, c->ts.u.derived)
1000 2006 : && has_finalizer_component (c->ts.u.derived))
1001 : return true;
1002 : }
1003 : return false;
1004 : }
1005 :
1006 :
1007 : static bool
1008 8346 : comp_is_finalizable (gfc_component *comp)
1009 : {
1010 8346 : if (comp->attr.proc_pointer)
1011 : return false;
1012 8268 : else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
1013 : return true;
1014 1332 : else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
1015 5402 : && (comp->ts.u.derived->attr.alloc_comp
1016 552 : || has_finalizer_component (comp->ts.u.derived)
1017 552 : || (comp->ts.u.derived->f2k_derived
1018 528 : && comp->ts.u.derived->f2k_derived->finalizers)))
1019 : return true;
1020 3251 : else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1021 744 : && CLASS_DATA (comp)->attr.allocatable)
1022 : return true;
1023 : else
1024 2535 : 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 bool
1038 4254 : 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 4254 : gfc_expr *e;
1043 4254 : gfc_ref *ref;
1044 4254 : gfc_was_finalized *f;
1045 :
1046 4254 : if (!comp_is_finalizable (comp))
1047 : return false;
1048 :
1049 : /* If this expression with this component has been finalized
1050 : already in this namespace, there is nothing to do. */
1051 4372 : for (f = sub_ns->was_finalized; f; f = f->next)
1052 : {
1053 1273 : if (f->e == expr && f->c == comp)
1054 : return false;
1055 : }
1056 :
1057 3099 : e = gfc_copy_expr (expr);
1058 3099 : if (!e->ref)
1059 2634 : e->ref = ref = gfc_get_ref ();
1060 : else
1061 : {
1062 626 : for (ref = e->ref; ref->next; ref = ref->next)
1063 : ;
1064 465 : ref->next = gfc_get_ref ();
1065 465 : ref = ref->next;
1066 : }
1067 3099 : ref->type = REF_COMPONENT;
1068 3099 : ref->u.c.sym = derived;
1069 3099 : ref->u.c.component = comp;
1070 3099 : e->ts = comp->ts;
1071 :
1072 3099 : if (comp->attr.dimension || comp->attr.codimension
1073 1346 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1074 385 : && (CLASS_DATA (comp)->attr.dimension
1075 247 : || CLASS_DATA (comp)->attr.codimension)))
1076 : {
1077 1899 : ref->next = gfc_get_ref ();
1078 1899 : ref->next->type = REF_ARRAY;
1079 1899 : ref->next->u.ar.dimen = 0;
1080 1899 : ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
1081 : : comp->as;
1082 1899 : e->rank = ref->next->u.ar.as->rank;
1083 1899 : e->corank = ref->next->u.ar.as->corank;
1084 1919 : ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
1085 : }
1086 :
1087 : /* Call DEALLOCATE (comp, stat=ignore). */
1088 3099 : if (comp->attr.allocatable
1089 847 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1090 385 : && CLASS_DATA (comp)->attr.allocatable))
1091 : {
1092 2637 : gfc_code *dealloc, *block = NULL;
1093 :
1094 : /* Add IF (fini_coarray). */
1095 2637 : if (comp->attr.codimension
1096 2619 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1097 385 : && CLASS_DATA (comp)->attr.codimension))
1098 : {
1099 32 : block = gfc_get_code (EXEC_IF);
1100 32 : if (*code)
1101 : {
1102 32 : (*code)->next = block;
1103 32 : (*code) = (*code)->next;
1104 : }
1105 : else
1106 : (*code) = block;
1107 :
1108 32 : block->block = gfc_get_code (EXEC_IF);
1109 32 : block = block->block;
1110 32 : block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
1111 : }
1112 :
1113 2637 : dealloc = gfc_get_code (EXEC_DEALLOCATE);
1114 :
1115 2637 : dealloc->ext.alloc.list = gfc_get_alloc ();
1116 2637 : dealloc->ext.alloc.list->expr = e;
1117 2637 : dealloc->expr1 = gfc_lval_expr_from_sym (stat);
1118 :
1119 2637 : gfc_code *cond = gfc_get_code (EXEC_IF);
1120 2637 : cond->block = gfc_get_code (EXEC_IF);
1121 2637 : cond->block->expr1 = gfc_get_expr ();
1122 2637 : cond->block->expr1->expr_type = EXPR_FUNCTION;
1123 2637 : cond->block->expr1->where = gfc_current_locus;
1124 2637 : gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
1125 2637 : cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1126 2637 : cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
1127 2637 : cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
1128 2637 : gfc_commit_symbol (cond->block->expr1->symtree->n.sym);
1129 2637 : cond->block->expr1->ts.type = BT_LOGICAL;
1130 2637 : cond->block->expr1->ts.kind = gfc_default_logical_kind;
1131 2637 : cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED);
1132 2637 : cond->block->expr1->value.function.actual = gfc_get_actual_arglist ();
1133 : /* EXPR only adds nonpointer, nonallocatable components to its base
1134 : pointer, so testing the base suffices. */
1135 2637 : cond->block->expr1->value.function.actual->expr
1136 2637 : = gfc_lval_expr_from_sym (expr->symtree->n.sym);
1137 2637 : cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist ();
1138 2637 : cond->block->next = dealloc;
1139 :
1140 2637 : if (block)
1141 32 : block->next = cond;
1142 2605 : else if (*code)
1143 : {
1144 2605 : (*code)->next = cond;
1145 2605 : (*code) = (*code)->next;
1146 : }
1147 : else
1148 0 : (*code) = cond;
1149 :
1150 : }
1151 462 : else if (comp->ts.type == BT_DERIVED
1152 462 : && comp->ts.u.derived->f2k_derived
1153 462 : && comp->ts.u.derived->f2k_derived->finalizers)
1154 : {
1155 : /* Call FINAL_WRAPPER (comp); */
1156 95 : gfc_code *final_wrap;
1157 95 : gfc_symbol *vtab, *byte_stride;
1158 95 : gfc_expr *scalar, *size_expr, *fini_coarray_expr;
1159 95 : gfc_component *c;
1160 :
1161 95 : vtab = gfc_find_derived_vtab (comp->ts.u.derived);
1162 570 : for (c = vtab->ts.u.derived->components; c; c = c->next)
1163 570 : if (strcmp (c->name, "_final") == 0)
1164 : break;
1165 :
1166 95 : gcc_assert (c);
1167 :
1168 : /* Set scalar argument for storage_size. A leading underscore in
1169 : the name prevents an unwanted finalization. */
1170 95 : gfc_get_symbol ("_comp_byte_stride", sub_ns, &byte_stride);
1171 95 : byte_stride->ts = e->ts;
1172 95 : byte_stride->attr.flavor = FL_VARIABLE;
1173 95 : byte_stride->attr.value = 1;
1174 95 : byte_stride->attr.artificial = 1;
1175 95 : gfc_set_sym_referenced (byte_stride);
1176 95 : gfc_commit_symbol (byte_stride);
1177 95 : scalar = gfc_lval_expr_from_sym (byte_stride);
1178 :
1179 95 : final_wrap = gfc_get_code (EXEC_CALL);
1180 95 : final_wrap->symtree = c->initializer->symtree;
1181 95 : final_wrap->resolved_sym = c->initializer->symtree->n.sym;
1182 95 : final_wrap->ext.actual = gfc_get_actual_arglist ();
1183 95 : final_wrap->ext.actual->expr = e;
1184 :
1185 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1186 95 : size_expr = gfc_get_expr ();
1187 95 : size_expr->where = gfc_current_locus;
1188 95 : size_expr->expr_type = EXPR_OP;
1189 95 : size_expr->value.op.op = INTRINSIC_DIVIDE;
1190 :
1191 : /* STORAGE_SIZE (array,kind=c_intptr_t). */
1192 95 : size_expr->value.op.op1
1193 95 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
1194 : "storage_size", gfc_current_locus, 2,
1195 : scalar,
1196 : gfc_get_int_expr (gfc_index_integer_kind,
1197 : NULL, 0));
1198 :
1199 : /* NUMERIC_STORAGE_SIZE. */
1200 95 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
1201 : gfc_character_storage_size);
1202 95 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
1203 95 : size_expr->ts = size_expr->value.op.op1->ts;
1204 :
1205 : /* Which provides the argument 'byte_stride'..... */
1206 95 : final_wrap->ext.actual->next = gfc_get_actual_arglist ();
1207 95 : final_wrap->ext.actual->next->expr = size_expr;
1208 :
1209 : /* ...and last of all the 'fini_coarray' argument. */
1210 95 : fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
1211 95 : final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
1212 95 : final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
1213 :
1214 95 : if (*code)
1215 : {
1216 95 : (*code)->next = final_wrap;
1217 95 : (*code) = (*code)->next;
1218 : }
1219 : else
1220 : (*code) = final_wrap;
1221 95 : }
1222 : else
1223 : {
1224 367 : gfc_component *c;
1225 367 : bool ret = false;
1226 :
1227 1006 : for (c = comp->ts.u.derived->components; c; c = c->next)
1228 639 : ret |= finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray,
1229 : code, sub_ns);
1230 : /* Only free the expression, if it has never been used. */
1231 367 : if (!ret)
1232 0 : gfc_free_expr (e);
1233 : }
1234 :
1235 : /* Record that this was finalized already in this namespace. */
1236 3099 : f = sub_ns->was_finalized;
1237 3099 : sub_ns->was_finalized = XCNEW (gfc_was_finalized);
1238 3099 : sub_ns->was_finalized->e = expr;
1239 3099 : sub_ns->was_finalized->c = comp;
1240 3099 : sub_ns->was_finalized->next = f;
1241 3099 : return true;
1242 : }
1243 :
1244 :
1245 : /* Generate code equivalent to
1246 : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1247 : + offset, c_ptr), ptr). */
1248 :
1249 : static gfc_code *
1250 2772 : finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
1251 : gfc_expr *offset, gfc_namespace *sub_ns)
1252 : {
1253 2772 : gfc_code *block;
1254 2772 : gfc_expr *expr, *expr2;
1255 :
1256 : /* C_F_POINTER(). */
1257 2772 : block = gfc_get_code (EXEC_CALL);
1258 2772 : gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
1259 2772 : block->resolved_sym = block->symtree->n.sym;
1260 2772 : block->resolved_sym->attr.flavor = FL_PROCEDURE;
1261 2772 : block->resolved_sym->attr.intrinsic = 1;
1262 2772 : block->resolved_sym->attr.subroutine = 1;
1263 2772 : block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
1264 2772 : block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
1265 2772 : block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
1266 2772 : gfc_commit_symbol (block->resolved_sym);
1267 :
1268 : /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
1269 2772 : block->ext.actual = gfc_get_actual_arglist ();
1270 2772 : block->ext.actual->next = gfc_get_actual_arglist ();
1271 2772 : block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
1272 : NULL, 0);
1273 2772 : block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
1274 :
1275 : /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
1276 :
1277 : /* TRANSFER's first argument: C_LOC (array). */
1278 2772 : expr = gfc_get_expr ();
1279 2772 : expr->expr_type = EXPR_FUNCTION;
1280 2772 : gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
1281 2772 : expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1282 2772 : expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
1283 2772 : expr->symtree->n.sym->attr.intrinsic = 1;
1284 2772 : expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
1285 2772 : expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
1286 2772 : expr->value.function.actual = gfc_get_actual_arglist ();
1287 2772 : expr->value.function.actual->expr
1288 2772 : = gfc_lval_expr_from_sym (array);
1289 2772 : expr->symtree->n.sym->result = expr->symtree->n.sym;
1290 2772 : gfc_commit_symbol (expr->symtree->n.sym);
1291 2772 : expr->ts.type = BT_INTEGER;
1292 2772 : expr->ts.kind = gfc_index_integer_kind;
1293 2772 : expr->where = gfc_current_locus;
1294 :
1295 : /* TRANSFER. */
1296 2772 : expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
1297 : gfc_current_locus, 3, expr,
1298 : gfc_get_int_expr (gfc_index_integer_kind,
1299 : NULL, 0), NULL);
1300 2772 : expr2->ts.type = BT_INTEGER;
1301 2772 : expr2->ts.kind = gfc_index_integer_kind;
1302 :
1303 : /* <array addr> + <offset>. */
1304 2772 : block->ext.actual->expr = gfc_get_expr ();
1305 2772 : block->ext.actual->expr->expr_type = EXPR_OP;
1306 2772 : block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
1307 2772 : block->ext.actual->expr->value.op.op1 = expr2;
1308 2772 : block->ext.actual->expr->value.op.op2 = offset;
1309 2772 : block->ext.actual->expr->ts = expr->ts;
1310 2772 : block->ext.actual->expr->where = gfc_current_locus;
1311 :
1312 : /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
1313 2772 : block->ext.actual->next = gfc_get_actual_arglist ();
1314 2772 : block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
1315 2772 : block->ext.actual->next->next = gfc_get_actual_arglist ();
1316 :
1317 2772 : return block;
1318 : }
1319 :
1320 :
1321 : /* Calculates the offset to the (idx+1)th element of an array, taking the
1322 : stride into account. It generates the code:
1323 : offset = 0
1324 : do idx2 = 1, rank
1325 : offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1326 : end do
1327 : offset = offset * byte_stride. */
1328 :
1329 : static gfc_code*
1330 2526 : finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
1331 : gfc_symbol *strides, gfc_symbol *sizes,
1332 : gfc_symbol *byte_stride, gfc_expr *rank,
1333 : gfc_code *block, gfc_namespace *sub_ns)
1334 : {
1335 2526 : gfc_iterator *iter;
1336 2526 : gfc_expr *expr, *expr2;
1337 :
1338 : /* offset = 0. */
1339 2526 : block->next = gfc_get_code (EXEC_ASSIGN);
1340 2526 : block = block->next;
1341 2526 : block->expr1 = gfc_lval_expr_from_sym (offset);
1342 2526 : block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1343 :
1344 : /* Create loop. */
1345 2526 : iter = gfc_get_iterator ();
1346 2526 : iter->var = gfc_lval_expr_from_sym (idx2);
1347 2526 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1348 2526 : iter->end = gfc_copy_expr (rank);
1349 2526 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1350 2526 : block->next = gfc_get_code (EXEC_DO);
1351 2526 : block = block->next;
1352 2526 : block->ext.iterator = iter;
1353 2526 : block->block = gfc_get_code (EXEC_DO);
1354 :
1355 : /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1356 : * strides(idx2). */
1357 :
1358 : /* mod (idx, sizes(idx2)). */
1359 2526 : expr = gfc_lval_expr_from_sym (sizes);
1360 2526 : expr->ref = gfc_get_ref ();
1361 2526 : expr->ref->type = REF_ARRAY;
1362 2526 : expr->ref->u.ar.as = sizes->as;
1363 2526 : expr->ref->u.ar.type = AR_ELEMENT;
1364 2526 : expr->ref->u.ar.dimen = 1;
1365 2526 : expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1366 2526 : expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
1367 2526 : expr->where = sizes->declared_at;
1368 :
1369 2526 : expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
1370 : gfc_current_locus, 2,
1371 : gfc_lval_expr_from_sym (idx), expr);
1372 2526 : expr->ts = idx->ts;
1373 :
1374 : /* (...) / sizes(idx2-1). */
1375 2526 : expr2 = gfc_get_expr ();
1376 2526 : expr2->expr_type = EXPR_OP;
1377 2526 : expr2->value.op.op = INTRINSIC_DIVIDE;
1378 2526 : expr2->value.op.op1 = expr;
1379 2526 : expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
1380 2526 : expr2->value.op.op2->ref = gfc_get_ref ();
1381 2526 : expr2->value.op.op2->ref->type = REF_ARRAY;
1382 2526 : expr2->value.op.op2->ref->u.ar.as = sizes->as;
1383 2526 : expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1384 2526 : expr2->value.op.op2->ref->u.ar.dimen = 1;
1385 2526 : expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1386 2526 : expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
1387 2526 : expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
1388 2526 : expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
1389 2526 : expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
1390 2526 : expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
1391 2526 : = gfc_lval_expr_from_sym (idx2);
1392 2526 : expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
1393 2526 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1394 2526 : expr2->value.op.op2->ref->u.ar.start[0]->ts
1395 2526 : = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
1396 2526 : expr2->ts = idx->ts;
1397 2526 : expr2->where = gfc_current_locus;
1398 :
1399 : /* ... * strides(idx2). */
1400 2526 : expr = gfc_get_expr ();
1401 2526 : expr->expr_type = EXPR_OP;
1402 2526 : expr->value.op.op = INTRINSIC_TIMES;
1403 2526 : expr->value.op.op1 = expr2;
1404 2526 : expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
1405 2526 : expr->value.op.op2->ref = gfc_get_ref ();
1406 2526 : expr->value.op.op2->ref->type = REF_ARRAY;
1407 2526 : expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1408 2526 : expr->value.op.op2->ref->u.ar.dimen = 1;
1409 2526 : expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1410 2526 : expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
1411 2526 : expr->value.op.op2->ref->u.ar.as = strides->as;
1412 2526 : expr->ts = idx->ts;
1413 2526 : expr->where = gfc_current_locus;
1414 :
1415 : /* offset = offset + ... */
1416 2526 : block->block->next = gfc_get_code (EXEC_ASSIGN);
1417 2526 : block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
1418 2526 : block->block->next->expr2 = gfc_get_expr ();
1419 2526 : block->block->next->expr2->expr_type = EXPR_OP;
1420 2526 : block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
1421 2526 : block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
1422 2526 : block->block->next->expr2->value.op.op2 = expr;
1423 2526 : block->block->next->expr2->ts = idx->ts;
1424 2526 : block->block->next->expr2->where = gfc_current_locus;
1425 :
1426 : /* After the loop: offset = offset * byte_stride. */
1427 2526 : block->next = gfc_get_code (EXEC_ASSIGN);
1428 2526 : block = block->next;
1429 2526 : block->expr1 = gfc_lval_expr_from_sym (offset);
1430 2526 : block->expr2 = gfc_get_expr ();
1431 2526 : block->expr2->expr_type = EXPR_OP;
1432 2526 : block->expr2->value.op.op = INTRINSIC_TIMES;
1433 2526 : block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
1434 2526 : block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
1435 2526 : block->expr2->ts = block->expr2->value.op.op1->ts;
1436 2526 : block->expr2->where = gfc_current_locus;
1437 2526 : return block;
1438 : }
1439 :
1440 :
1441 : /* Insert code of the following form:
1442 :
1443 : block
1444 : integer(c_intptr_t) :: i
1445 :
1446 : if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1447 : && (is_contiguous || !final_rank3->attr.contiguous
1448 : || final_rank3->as->type != AS_ASSUMED_SHAPE))
1449 : || 0 == STORAGE_SIZE (array)) then
1450 : call final_rank3 (array)
1451 : else
1452 : block
1453 : integer(c_intptr_t) :: offset, j
1454 : type(t) :: tmp(shape (array))
1455 :
1456 : do i = 0, size (array)-1
1457 : offset = obtain_offset(i, strides, sizes, byte_stride)
1458 : addr = transfer (c_loc (array), addr) + offset
1459 : call c_f_pointer (transfer (addr, cptr), ptr)
1460 :
1461 : addr = transfer (c_loc (tmp), addr)
1462 : + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1463 : call c_f_pointer (transfer (addr, cptr), ptr2)
1464 : ptr2 = ptr
1465 : end do
1466 : call final_rank3 (tmp)
1467 : end block
1468 : end if
1469 : block */
1470 :
1471 : static void
1472 132 : finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
1473 : gfc_symbol *array, gfc_symbol *byte_stride,
1474 : gfc_symbol *idx, gfc_symbol *ptr,
1475 : gfc_symbol *nelem,
1476 : gfc_symbol *strides, gfc_symbol *sizes,
1477 : gfc_symbol *idx2, gfc_symbol *offset,
1478 : gfc_symbol *is_contiguous, gfc_expr *rank,
1479 : gfc_namespace *sub_ns)
1480 : {
1481 132 : gfc_symbol *tmp_array, *ptr2;
1482 132 : gfc_expr *size_expr, *offset2, *expr;
1483 132 : gfc_namespace *ns;
1484 132 : gfc_iterator *iter;
1485 132 : gfc_code *block2;
1486 132 : int i;
1487 :
1488 132 : block->next = gfc_get_code (EXEC_IF);
1489 132 : block = block->next;
1490 :
1491 132 : block->block = gfc_get_code (EXEC_IF);
1492 132 : block = block->block;
1493 :
1494 : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1495 132 : size_expr = gfc_get_expr ();
1496 132 : size_expr->where = gfc_current_locus;
1497 132 : size_expr->expr_type = EXPR_OP;
1498 132 : size_expr->value.op.op = INTRINSIC_DIVIDE;
1499 :
1500 : /* STORAGE_SIZE (array,kind=c_intptr_t). */
1501 132 : size_expr->value.op.op1
1502 132 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
1503 : "storage_size", gfc_current_locus, 2,
1504 : gfc_lval_expr_from_sym (array),
1505 : gfc_get_int_expr (gfc_index_integer_kind,
1506 : NULL, 0));
1507 :
1508 : /* NUMERIC_STORAGE_SIZE. */
1509 132 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
1510 : gfc_character_storage_size);
1511 132 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
1512 132 : size_expr->ts = size_expr->value.op.op1->ts;
1513 :
1514 : /* IF condition: (stride == size_expr
1515 : && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1516 : || is_contiguous)
1517 : || 0 == size_expr. */
1518 132 : block->expr1 = gfc_get_expr ();
1519 132 : block->expr1->ts.type = BT_LOGICAL;
1520 132 : block->expr1->ts.kind = gfc_default_logical_kind;
1521 132 : block->expr1->expr_type = EXPR_OP;
1522 132 : block->expr1->where = gfc_current_locus;
1523 :
1524 132 : block->expr1->value.op.op = INTRINSIC_OR;
1525 :
1526 : /* byte_stride == size_expr */
1527 132 : expr = gfc_get_expr ();
1528 132 : expr->ts.type = BT_LOGICAL;
1529 132 : expr->ts.kind = gfc_default_logical_kind;
1530 132 : expr->expr_type = EXPR_OP;
1531 132 : expr->where = gfc_current_locus;
1532 132 : expr->value.op.op = INTRINSIC_EQ;
1533 132 : expr->value.op.op1
1534 132 : = gfc_lval_expr_from_sym (byte_stride);
1535 132 : expr->value.op.op2 = size_expr;
1536 :
1537 : /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1538 : add is_contiguous check. */
1539 :
1540 132 : if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
1541 112 : || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
1542 : {
1543 26 : gfc_expr *expr2;
1544 26 : expr2 = gfc_get_expr ();
1545 26 : expr2->ts.type = BT_LOGICAL;
1546 26 : expr2->ts.kind = gfc_default_logical_kind;
1547 26 : expr2->expr_type = EXPR_OP;
1548 26 : expr2->where = gfc_current_locus;
1549 26 : expr2->value.op.op = INTRINSIC_AND;
1550 26 : expr2->value.op.op1 = expr;
1551 26 : expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
1552 26 : expr = expr2;
1553 : }
1554 :
1555 132 : block->expr1->value.op.op1 = expr;
1556 :
1557 : /* 0 == size_expr */
1558 132 : block->expr1->value.op.op2 = gfc_get_expr ();
1559 132 : block->expr1->value.op.op2->ts.type = BT_LOGICAL;
1560 132 : block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
1561 132 : block->expr1->value.op.op2->expr_type = EXPR_OP;
1562 132 : block->expr1->value.op.op2->where = gfc_current_locus;
1563 132 : block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
1564 264 : block->expr1->value.op.op2->value.op.op1 =
1565 132 : gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1566 132 : block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
1567 :
1568 : /* IF body: call final subroutine. */
1569 132 : block->next = gfc_get_code (EXEC_CALL);
1570 132 : block->next->symtree = fini->proc_tree;
1571 132 : block->next->resolved_sym = fini->proc_tree->n.sym;
1572 132 : block->next->ext.actual = gfc_get_actual_arglist ();
1573 132 : block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
1574 :
1575 : /* ELSE. */
1576 :
1577 132 : block->block = gfc_get_code (EXEC_IF);
1578 132 : block = block->block;
1579 :
1580 : /* BLOCK ... END BLOCK. */
1581 132 : block->next = gfc_get_code (EXEC_BLOCK);
1582 132 : block = block->next;
1583 :
1584 132 : ns = gfc_build_block_ns (sub_ns);
1585 132 : block->ext.block.ns = ns;
1586 132 : block->ext.block.assoc = NULL;
1587 :
1588 132 : gfc_get_symbol ("ptr2", ns, &ptr2);
1589 132 : ptr2->ts.type = BT_DERIVED;
1590 132 : ptr2->ts.u.derived = array->ts.u.derived;
1591 132 : ptr2->attr.flavor = FL_VARIABLE;
1592 132 : ptr2->attr.pointer = 1;
1593 132 : ptr2->attr.artificial = 1;
1594 132 : gfc_set_sym_referenced (ptr2);
1595 132 : gfc_commit_symbol (ptr2);
1596 :
1597 132 : gfc_get_symbol ("tmp_array", ns, &tmp_array);
1598 132 : tmp_array->ts.type = BT_DERIVED;
1599 132 : tmp_array->ts.u.derived = array->ts.u.derived;
1600 132 : tmp_array->attr.flavor = FL_VARIABLE;
1601 132 : tmp_array->attr.dimension = 1;
1602 132 : tmp_array->attr.artificial = 1;
1603 132 : tmp_array->as = gfc_get_array_spec();
1604 132 : tmp_array->attr.intent = INTENT_INOUT;
1605 132 : tmp_array->as->type = AS_EXPLICIT;
1606 132 : tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
1607 :
1608 344 : for (i = 0; i < tmp_array->as->rank; i++)
1609 : {
1610 212 : gfc_expr *shape_expr;
1611 212 : tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
1612 : NULL, 1);
1613 : /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1614 212 : shape_expr
1615 424 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
1616 : gfc_current_locus, 3,
1617 : gfc_lval_expr_from_sym (array),
1618 : gfc_get_int_expr (gfc_default_integer_kind,
1619 212 : NULL, i+1),
1620 : gfc_get_int_expr (gfc_default_integer_kind,
1621 : NULL,
1622 : gfc_index_integer_kind));
1623 212 : shape_expr->ts.kind = gfc_index_integer_kind;
1624 212 : tmp_array->as->upper[i] = shape_expr;
1625 : }
1626 132 : gfc_set_sym_referenced (tmp_array);
1627 132 : gfc_commit_symbol (tmp_array);
1628 :
1629 : /* Create loop. */
1630 132 : iter = gfc_get_iterator ();
1631 132 : iter->var = gfc_lval_expr_from_sym (idx);
1632 132 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1633 132 : iter->end = gfc_lval_expr_from_sym (nelem);
1634 132 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1635 :
1636 132 : block = gfc_get_code (EXEC_DO);
1637 132 : ns->code = block;
1638 132 : block->ext.iterator = iter;
1639 132 : block->block = gfc_get_code (EXEC_DO);
1640 :
1641 : /* Offset calculation for the new array: idx * size of type (in bytes). */
1642 132 : offset2 = gfc_get_expr ();
1643 132 : offset2->expr_type = EXPR_OP;
1644 132 : offset2->where = gfc_current_locus;
1645 132 : offset2->value.op.op = INTRINSIC_TIMES;
1646 132 : offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
1647 132 : offset2->value.op.op2 = gfc_copy_expr (size_expr);
1648 132 : offset2->ts = byte_stride->ts;
1649 :
1650 : /* Offset calculation of "array". */
1651 264 : block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
1652 132 : byte_stride, rank, block->block, sub_ns);
1653 :
1654 : /* Create code for
1655 : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1656 : + idx * stride, c_ptr), ptr). */
1657 132 : block2->next = finalization_scalarizer (array, ptr,
1658 : gfc_lval_expr_from_sym (offset),
1659 : sub_ns);
1660 132 : block2 = block2->next;
1661 132 : block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
1662 132 : block2 = block2->next;
1663 :
1664 : /* ptr2 = ptr. */
1665 132 : block2->next = gfc_get_code (EXEC_ASSIGN);
1666 132 : block2 = block2->next;
1667 132 : block2->expr1 = gfc_lval_expr_from_sym (ptr2);
1668 132 : block2->expr2 = gfc_lval_expr_from_sym (ptr);
1669 :
1670 : /* Call now the user's final subroutine. */
1671 132 : block->next = gfc_get_code (EXEC_CALL);
1672 132 : block = block->next;
1673 132 : block->symtree = fini->proc_tree;
1674 132 : block->resolved_sym = fini->proc_tree->n.sym;
1675 132 : block->ext.actual = gfc_get_actual_arglist ();
1676 132 : block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
1677 :
1678 132 : if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
1679 : return;
1680 :
1681 : /* Copy back. */
1682 :
1683 : /* Loop. */
1684 114 : iter = gfc_get_iterator ();
1685 114 : iter->var = gfc_lval_expr_from_sym (idx);
1686 114 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1687 114 : iter->end = gfc_lval_expr_from_sym (nelem);
1688 114 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1689 :
1690 114 : block->next = gfc_get_code (EXEC_DO);
1691 114 : block = block->next;
1692 114 : block->ext.iterator = iter;
1693 114 : block->block = gfc_get_code (EXEC_DO);
1694 :
1695 : /* Offset calculation of "array". */
1696 114 : block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
1697 : byte_stride, rank, block->block, sub_ns);
1698 :
1699 : /* Create code for
1700 : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1701 : + offset, c_ptr), ptr). */
1702 114 : block2->next = finalization_scalarizer (array, ptr,
1703 : gfc_lval_expr_from_sym (offset),
1704 : sub_ns);
1705 114 : block2 = block2->next;
1706 114 : block2->next = finalization_scalarizer (tmp_array, ptr2,
1707 : gfc_copy_expr (offset2), sub_ns);
1708 114 : block2 = block2->next;
1709 :
1710 : /* ptr = ptr2. */
1711 114 : block2->next = gfc_get_code (EXEC_ASSIGN);
1712 114 : block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
1713 114 : block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
1714 : }
1715 :
1716 :
1717 : /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1718 : derived type "derived". The function first calls the appropriate FINAL
1719 : subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1720 : components (but not the inherited ones). Last, it calls the wrapper
1721 : subroutine of the parent. The generated wrapper procedure takes as argument
1722 : an assumed-rank array.
1723 : If neither allocatable components nor FINAL subroutines exists, the vtab
1724 : will contain a NULL pointer.
1725 : The generated function has the form
1726 : _final(assumed-rank array, stride, skip_corarray)
1727 : where the array has to be contiguous (except of the lowest dimension). The
1728 : stride (in bytes) is used to allow different sizes for ancestor types by
1729 : skipping over the additionally added components in the scalarizer. If
1730 : "fini_coarray" is false, coarray components are not finalized to allow for
1731 : the correct semantic with intrinsic assignment. */
1732 :
1733 : static void
1734 11231 : generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
1735 : const char *tname, gfc_component *vtab_final)
1736 : {
1737 11231 : gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
1738 11231 : gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
1739 11231 : gfc_symbol *result = NULL;
1740 11231 : gfc_component *comp;
1741 11231 : gfc_namespace *sub_ns;
1742 11231 : gfc_code *last_code, *block;
1743 11231 : char *name;
1744 11231 : char *result_name;
1745 11231 : bool finalizable_comp = false;
1746 11231 : gfc_expr *ancestor_wrapper = NULL, *rank;
1747 11231 : gfc_iterator *iter;
1748 :
1749 11231 : if (derived->attr.unlimited_polymorphic || derived->error)
1750 : {
1751 832 : vtab_final->initializer = gfc_get_null_expr (NULL);
1752 8683 : return;
1753 : }
1754 :
1755 : /* Search for the ancestor's finalizers. */
1756 1461 : if (derived->attr.extension && derived->components
1757 11860 : && (!derived->components->ts.u.derived->attr.abstract
1758 317 : || has_finalizer_component (derived)))
1759 : {
1760 1144 : gfc_symbol *vtab;
1761 1144 : gfc_component *comp;
1762 :
1763 1144 : vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
1764 6864 : for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
1765 6864 : if (comp->name[0] == '_' && comp->name[1] == 'f')
1766 : {
1767 1144 : ancestor_wrapper = comp->initializer;
1768 1144 : break;
1769 : }
1770 : }
1771 :
1772 : /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1773 : components: Return a NULL() expression; we defer this a bit to have
1774 : an interface declaration. */
1775 1144 : if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
1776 10212 : && !derived->attr.alloc_comp
1777 8193 : && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
1778 8973 : && !has_finalizer_component (derived))
1779 : {
1780 7787 : vtab_final->initializer = gfc_get_null_expr (NULL);
1781 7787 : gcc_assert (vtab_final->ts.interface == NULL);
1782 : return;
1783 : }
1784 : else
1785 : /* Check whether there are new allocatable components. */
1786 6891 : for (comp = derived->components; comp; comp = comp->next)
1787 : {
1788 4279 : if (comp == derived->components && derived->attr.extension
1789 382 : && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
1790 187 : continue;
1791 :
1792 4092 : finalizable_comp |= comp_is_finalizable (comp);
1793 : }
1794 :
1795 : /* If there is no new finalizer and no new allocatable, return with
1796 : an expr to the ancestor's one. */
1797 2612 : if (!finalizable_comp
1798 470 : && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
1799 : {
1800 64 : gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
1801 : && ancestor_wrapper->expr_type == EXPR_VARIABLE);
1802 64 : vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
1803 64 : vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
1804 64 : return;
1805 : }
1806 :
1807 : /* We now create a wrapper, which does the following:
1808 : 1. Call the suitable finalization subroutine for this type
1809 : 2. Loop over all noninherited allocatable components and noninherited
1810 : components with allocatable components and DEALLOCATE those; this will
1811 : take care of finalizers, coarray deregistering and allocatable
1812 : nested components.
1813 : 3. Call the ancestor's finalizer. */
1814 :
1815 : /* Declare the wrapper function; it takes an assumed-rank array
1816 : and a VALUE logical as arguments. */
1817 :
1818 : /* Set up the namespace. */
1819 2548 : sub_ns = gfc_get_namespace (ns, 0);
1820 2548 : sub_ns->sibling = ns->contained;
1821 2548 : ns->contained = sub_ns;
1822 2548 : sub_ns->resolved = 1;
1823 :
1824 : /* Set up the procedure symbol. */
1825 2548 : name = xasprintf ("__final_%s", tname);
1826 2548 : gfc_get_symbol (name, sub_ns, &final);
1827 2548 : sub_ns->proc_name = final;
1828 2548 : final->attr.flavor = FL_PROCEDURE;
1829 2548 : final->attr.function = 1;
1830 2548 : final->attr.pure = 0;
1831 2548 : final->attr.recursive = 1;
1832 2548 : final->ts.type = BT_INTEGER;
1833 2548 : final->ts.kind = 4;
1834 2548 : final->attr.artificial = 1;
1835 2548 : final->attr.always_explicit = 1;
1836 2548 : final->attr.if_source = IFSRC_DECL;
1837 2548 : if (ns->proc_name->attr.flavor == FL_MODULE)
1838 2158 : final->module = ns->proc_name->name;
1839 :
1840 : /* Create a separate result symbol instead of using final->result = final.
1841 : Self-referencing result symbols (final->result = final) create a cycle
1842 : in the symbol structure that causes an ICE in gimplify_call_expr when
1843 : the finalizer wrapper is used as a procedure pointer initializer. */
1844 2548 : result_name = xasprintf ("__result_%s", tname);
1845 2548 : if (gfc_get_symbol (result_name, sub_ns, &result) != 0)
1846 0 : gfc_internal_error ("Failed to create finalizer result symbol");
1847 2548 : free (result_name);
1848 :
1849 2548 : if (!gfc_add_flavor (&result->attr, FL_VARIABLE, result->name,
1850 : &gfc_current_locus)
1851 2548 : || !gfc_add_result (&result->attr, result->name, &gfc_current_locus))
1852 0 : gfc_internal_error ("Failed to set finalizer result attributes");
1853 :
1854 2548 : result->ts = final->ts;
1855 2548 : result->attr.artificial = 1;
1856 2548 : gfc_set_sym_referenced (result);
1857 2548 : gfc_commit_symbol (result);
1858 2548 : final->result = result;
1859 2548 : gfc_set_sym_referenced (final);
1860 2548 : gfc_commit_symbol (final);
1861 :
1862 : /* Set up formal argument. */
1863 2548 : gfc_get_symbol ("array", sub_ns, &array);
1864 2548 : array->ts.type = BT_DERIVED;
1865 2548 : array->ts.u.derived = derived;
1866 2548 : array->attr.flavor = FL_VARIABLE;
1867 2548 : array->attr.dummy = 1;
1868 2548 : array->attr.contiguous = 1;
1869 2548 : array->attr.dimension = 1;
1870 2548 : array->attr.artificial = 1;
1871 2548 : array->as = gfc_get_array_spec();
1872 2548 : array->as->type = AS_ASSUMED_RANK;
1873 2548 : array->as->rank = -1;
1874 2548 : array->attr.intent = INTENT_INOUT;
1875 2548 : gfc_set_sym_referenced (array);
1876 2548 : final->formal = gfc_get_formal_arglist ();
1877 2548 : final->formal->sym = array;
1878 2548 : gfc_commit_symbol (array);
1879 :
1880 : /* Set up formal argument. */
1881 2548 : gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
1882 2548 : byte_stride->ts.type = BT_INTEGER;
1883 2548 : byte_stride->ts.kind = gfc_index_integer_kind;
1884 2548 : byte_stride->attr.flavor = FL_VARIABLE;
1885 2548 : byte_stride->attr.dummy = 1;
1886 2548 : byte_stride->attr.value = 1;
1887 2548 : byte_stride->attr.artificial = 1;
1888 2548 : gfc_set_sym_referenced (byte_stride);
1889 2548 : final->formal->next = gfc_get_formal_arglist ();
1890 2548 : final->formal->next->sym = byte_stride;
1891 2548 : gfc_commit_symbol (byte_stride);
1892 :
1893 : /* Set up formal argument. */
1894 2548 : gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
1895 2548 : fini_coarray->ts.type = BT_LOGICAL;
1896 2548 : fini_coarray->ts.kind = 1;
1897 2548 : fini_coarray->attr.flavor = FL_VARIABLE;
1898 2548 : fini_coarray->attr.dummy = 1;
1899 2548 : fini_coarray->attr.value = 1;
1900 2548 : fini_coarray->attr.artificial = 1;
1901 2548 : gfc_set_sym_referenced (fini_coarray);
1902 2548 : final->formal->next->next = gfc_get_formal_arglist ();
1903 2548 : final->formal->next->next->sym = fini_coarray;
1904 2548 : gfc_commit_symbol (fini_coarray);
1905 :
1906 : /* Local variables. */
1907 :
1908 2548 : gfc_get_symbol ("idx", sub_ns, &idx);
1909 2548 : idx->ts.type = BT_INTEGER;
1910 2548 : idx->ts.kind = gfc_index_integer_kind;
1911 2548 : idx->attr.flavor = FL_VARIABLE;
1912 2548 : idx->attr.artificial = 1;
1913 2548 : gfc_set_sym_referenced (idx);
1914 2548 : gfc_commit_symbol (idx);
1915 :
1916 2548 : gfc_get_symbol ("idx2", sub_ns, &idx2);
1917 2548 : idx2->ts.type = BT_INTEGER;
1918 2548 : idx2->ts.kind = gfc_index_integer_kind;
1919 2548 : idx2->attr.flavor = FL_VARIABLE;
1920 2548 : idx2->attr.artificial = 1;
1921 2548 : gfc_set_sym_referenced (idx2);
1922 2548 : gfc_commit_symbol (idx2);
1923 :
1924 2548 : gfc_get_symbol ("offset", sub_ns, &offset);
1925 2548 : offset->ts.type = BT_INTEGER;
1926 2548 : offset->ts.kind = gfc_index_integer_kind;
1927 2548 : offset->attr.flavor = FL_VARIABLE;
1928 2548 : offset->attr.artificial = 1;
1929 2548 : gfc_set_sym_referenced (offset);
1930 2548 : gfc_commit_symbol (offset);
1931 :
1932 : /* Create RANK expression. */
1933 2548 : rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
1934 : gfc_current_locus, 1,
1935 : gfc_lval_expr_from_sym (array));
1936 2548 : if (rank->ts.kind != idx->ts.kind)
1937 2548 : gfc_convert_type_warn (rank, &idx->ts, 2, 0);
1938 :
1939 : /* Create is_contiguous variable. */
1940 2548 : gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
1941 2548 : is_contiguous->ts.type = BT_LOGICAL;
1942 2548 : is_contiguous->ts.kind = gfc_default_logical_kind;
1943 2548 : is_contiguous->attr.flavor = FL_VARIABLE;
1944 2548 : is_contiguous->attr.artificial = 1;
1945 2548 : gfc_set_sym_referenced (is_contiguous);
1946 2548 : gfc_commit_symbol (is_contiguous);
1947 :
1948 : /* Create "sizes(0..rank)" variable, which contains the multiplied
1949 : up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1950 : sizes(2) = sizes(1) * extent(dim=2) etc. */
1951 2548 : gfc_get_symbol ("sizes", sub_ns, &sizes);
1952 2548 : sizes->ts.type = BT_INTEGER;
1953 2548 : sizes->ts.kind = gfc_index_integer_kind;
1954 2548 : sizes->attr.flavor = FL_VARIABLE;
1955 2548 : sizes->attr.dimension = 1;
1956 2548 : sizes->attr.artificial = 1;
1957 2548 : sizes->as = gfc_get_array_spec();
1958 2548 : sizes->attr.intent = INTENT_INOUT;
1959 2548 : sizes->as->type = AS_EXPLICIT;
1960 2548 : sizes->as->rank = 1;
1961 2548 : sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1962 2548 : sizes->as->upper[0] = gfc_copy_expr (rank);
1963 2548 : gfc_set_sym_referenced (sizes);
1964 2548 : gfc_commit_symbol (sizes);
1965 :
1966 : /* Create "strides(1..rank)" variable, which contains the strides per
1967 : dimension. */
1968 2548 : gfc_get_symbol ("strides", sub_ns, &strides);
1969 2548 : strides->ts.type = BT_INTEGER;
1970 2548 : strides->ts.kind = gfc_index_integer_kind;
1971 2548 : strides->attr.flavor = FL_VARIABLE;
1972 2548 : strides->attr.dimension = 1;
1973 2548 : strides->attr.artificial = 1;
1974 2548 : strides->as = gfc_get_array_spec();
1975 2548 : strides->attr.intent = INTENT_INOUT;
1976 2548 : strides->as->type = AS_EXPLICIT;
1977 2548 : strides->as->rank = 1;
1978 2548 : strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1979 2548 : strides->as->upper[0] = gfc_copy_expr (rank);
1980 2548 : gfc_set_sym_referenced (strides);
1981 2548 : gfc_commit_symbol (strides);
1982 :
1983 :
1984 : /* Set return value to 0. */
1985 2548 : last_code = gfc_get_code (EXEC_ASSIGN);
1986 2548 : last_code->expr1 = gfc_lval_expr_from_sym (result);
1987 2548 : last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
1988 2548 : sub_ns->code = last_code;
1989 :
1990 : /* Set: is_contiguous = .true. */
1991 2548 : last_code->next = gfc_get_code (EXEC_ASSIGN);
1992 2548 : last_code = last_code->next;
1993 2548 : last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
1994 2548 : last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
1995 : &gfc_current_locus, true);
1996 :
1997 : /* Set: sizes(0) = 1. */
1998 2548 : last_code->next = gfc_get_code (EXEC_ASSIGN);
1999 2548 : last_code = last_code->next;
2000 2548 : last_code->expr1 = gfc_lval_expr_from_sym (sizes);
2001 2548 : last_code->expr1->ref = gfc_get_ref ();
2002 2548 : last_code->expr1->ref->type = REF_ARRAY;
2003 2548 : last_code->expr1->ref->u.ar.type = AR_ELEMENT;
2004 2548 : last_code->expr1->ref->u.ar.dimen = 1;
2005 2548 : last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2006 2548 : last_code->expr1->ref->u.ar.start[0]
2007 2548 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
2008 2548 : last_code->expr1->ref->u.ar.as = sizes->as;
2009 2548 : last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2010 :
2011 : /* Create:
2012 : DO idx = 1, rank
2013 : strides(idx) = _F._stride (array, dim=idx)
2014 : sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
2015 : if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
2016 : END DO. */
2017 :
2018 : /* Create loop. */
2019 2548 : iter = gfc_get_iterator ();
2020 2548 : iter->var = gfc_lval_expr_from_sym (idx);
2021 2548 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2022 2548 : iter->end = gfc_copy_expr (rank);
2023 2548 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2024 2548 : last_code->next = gfc_get_code (EXEC_DO);
2025 2548 : last_code = last_code->next;
2026 2548 : last_code->ext.iterator = iter;
2027 2548 : last_code->block = gfc_get_code (EXEC_DO);
2028 :
2029 : /* strides(idx) = _F._stride(array,dim=idx). */
2030 2548 : last_code->block->next = gfc_get_code (EXEC_ASSIGN);
2031 2548 : block = last_code->block->next;
2032 :
2033 2548 : block->expr1 = gfc_lval_expr_from_sym (strides);
2034 2548 : block->expr1->ref = gfc_get_ref ();
2035 2548 : block->expr1->ref->type = REF_ARRAY;
2036 2548 : block->expr1->ref->u.ar.type = AR_ELEMENT;
2037 2548 : block->expr1->ref->u.ar.dimen = 1;
2038 2548 : block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2039 2548 : block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
2040 2548 : block->expr1->ref->u.ar.as = strides->as;
2041 :
2042 2548 : block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
2043 : gfc_current_locus, 2,
2044 : gfc_lval_expr_from_sym (array),
2045 : gfc_lval_expr_from_sym (idx));
2046 :
2047 : /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
2048 2548 : block->next = gfc_get_code (EXEC_ASSIGN);
2049 2548 : block = block->next;
2050 :
2051 : /* sizes(idx) = ... */
2052 2548 : block->expr1 = gfc_lval_expr_from_sym (sizes);
2053 2548 : block->expr1->ref = gfc_get_ref ();
2054 2548 : block->expr1->ref->type = REF_ARRAY;
2055 2548 : block->expr1->ref->u.ar.type = AR_ELEMENT;
2056 2548 : block->expr1->ref->u.ar.dimen = 1;
2057 2548 : block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2058 2548 : block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
2059 2548 : block->expr1->ref->u.ar.as = sizes->as;
2060 :
2061 2548 : block->expr2 = gfc_get_expr ();
2062 2548 : block->expr2->expr_type = EXPR_OP;
2063 2548 : block->expr2->value.op.op = INTRINSIC_TIMES;
2064 2548 : block->expr2->where = gfc_current_locus;
2065 :
2066 : /* sizes(idx-1). */
2067 2548 : block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
2068 2548 : block->expr2->value.op.op1->ref = gfc_get_ref ();
2069 2548 : block->expr2->value.op.op1->ref->type = REF_ARRAY;
2070 2548 : block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
2071 2548 : block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
2072 2548 : block->expr2->value.op.op1->ref->u.ar.dimen = 1;
2073 2548 : block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2074 2548 : block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
2075 2548 : block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
2076 2548 : block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus;
2077 2548 : block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
2078 2548 : block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
2079 2548 : = gfc_lval_expr_from_sym (idx);
2080 2548 : block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
2081 2548 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2082 2548 : block->expr2->value.op.op1->ref->u.ar.start[0]->ts
2083 2548 : = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
2084 :
2085 : /* size(array, dim=idx, kind=index_kind). */
2086 5096 : block->expr2->value.op.op2
2087 2548 : = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
2088 : gfc_current_locus, 3,
2089 : gfc_lval_expr_from_sym (array),
2090 : gfc_lval_expr_from_sym (idx),
2091 : gfc_get_int_expr (gfc_index_integer_kind,
2092 : NULL,
2093 : gfc_index_integer_kind));
2094 2548 : block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
2095 2548 : block->expr2->ts = idx->ts;
2096 :
2097 : /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
2098 2548 : block->next = gfc_get_code (EXEC_IF);
2099 2548 : block = block->next;
2100 :
2101 2548 : block->block = gfc_get_code (EXEC_IF);
2102 2548 : block = block->block;
2103 :
2104 : /* if condition: strides(idx) /= sizes(idx-1). */
2105 2548 : block->expr1 = gfc_get_expr ();
2106 2548 : block->expr1->ts.type = BT_LOGICAL;
2107 2548 : block->expr1->ts.kind = gfc_default_logical_kind;
2108 2548 : block->expr1->expr_type = EXPR_OP;
2109 2548 : block->expr1->where = gfc_current_locus;
2110 2548 : block->expr1->value.op.op = INTRINSIC_NE;
2111 :
2112 2548 : block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
2113 2548 : block->expr1->value.op.op1->ref = gfc_get_ref ();
2114 2548 : block->expr1->value.op.op1->ref->type = REF_ARRAY;
2115 2548 : block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
2116 2548 : block->expr1->value.op.op1->ref->u.ar.dimen = 1;
2117 2548 : block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2118 2548 : block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
2119 2548 : block->expr1->value.op.op1->ref->u.ar.as = strides->as;
2120 :
2121 2548 : block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
2122 2548 : block->expr1->value.op.op2->ref = gfc_get_ref ();
2123 2548 : block->expr1->value.op.op2->ref->type = REF_ARRAY;
2124 2548 : block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
2125 2548 : block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
2126 2548 : block->expr1->value.op.op2->ref->u.ar.dimen = 1;
2127 2548 : block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2128 2548 : block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
2129 2548 : block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
2130 2548 : block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
2131 2548 : block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
2132 2548 : block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
2133 2548 : = gfc_lval_expr_from_sym (idx);
2134 2548 : block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
2135 2548 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2136 2548 : block->expr1->value.op.op2->ref->u.ar.start[0]->ts
2137 2548 : = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
2138 :
2139 : /* if body: is_contiguous = .false. */
2140 2548 : block->next = gfc_get_code (EXEC_ASSIGN);
2141 2548 : block = block->next;
2142 2548 : block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
2143 2548 : block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
2144 : &gfc_current_locus, false);
2145 :
2146 : /* Obtain the size (number of elements) of "array" MINUS ONE,
2147 : which is used in the scalarization. */
2148 2548 : gfc_get_symbol ("nelem", sub_ns, &nelem);
2149 2548 : nelem->ts.type = BT_INTEGER;
2150 2548 : nelem->ts.kind = gfc_index_integer_kind;
2151 2548 : nelem->attr.flavor = FL_VARIABLE;
2152 2548 : nelem->attr.artificial = 1;
2153 2548 : gfc_set_sym_referenced (nelem);
2154 2548 : gfc_commit_symbol (nelem);
2155 :
2156 : /* nelem = sizes (rank) - 1. */
2157 2548 : last_code->next = gfc_get_code (EXEC_ASSIGN);
2158 2548 : last_code = last_code->next;
2159 :
2160 2548 : last_code->expr1 = gfc_lval_expr_from_sym (nelem);
2161 :
2162 2548 : last_code->expr2 = gfc_get_expr ();
2163 2548 : last_code->expr2->expr_type = EXPR_OP;
2164 2548 : last_code->expr2->value.op.op = INTRINSIC_MINUS;
2165 2548 : last_code->expr2->value.op.op2
2166 2548 : = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2167 2548 : last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
2168 2548 : last_code->expr2->where = gfc_current_locus;
2169 :
2170 2548 : last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
2171 2548 : last_code->expr2->value.op.op1->ref = gfc_get_ref ();
2172 2548 : last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
2173 2548 : last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
2174 2548 : last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
2175 2548 : last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
2176 2548 : last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
2177 2548 : last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
2178 :
2179 : /* Call final subroutines. We now generate code like:
2180 : use iso_c_binding
2181 : integer, pointer :: ptr
2182 : type(c_ptr) :: cptr
2183 : integer(c_intptr_t) :: i, addr
2184 :
2185 : select case (rank (array))
2186 : case (3)
2187 : ! If needed, the array is packed
2188 : call final_rank3 (array)
2189 : case default:
2190 : do i = 0, size (array)-1
2191 : addr = transfer (c_loc (array), addr) + i * stride
2192 : call c_f_pointer (transfer (addr, cptr), ptr)
2193 : call elemental_final (ptr)
2194 : end do
2195 : end select */
2196 :
2197 2548 : if (derived->f2k_derived && derived->f2k_derived->finalizers)
2198 : {
2199 496 : gfc_finalizer *fini, *fini_elem = NULL;
2200 :
2201 496 : gfc_get_symbol ("ptr1", sub_ns, &ptr);
2202 496 : ptr->ts.type = BT_DERIVED;
2203 496 : ptr->ts.u.derived = derived;
2204 496 : ptr->attr.flavor = FL_VARIABLE;
2205 496 : ptr->attr.pointer = 1;
2206 496 : ptr->attr.artificial = 1;
2207 496 : gfc_set_sym_referenced (ptr);
2208 496 : gfc_commit_symbol (ptr);
2209 :
2210 496 : fini = derived->f2k_derived->finalizers;
2211 :
2212 : /* Assumed rank finalizers can be called directly. The call takes care
2213 : of setting up the descriptor. resolve_finalizers has already checked
2214 : that this is the only finalizer for this kind/type (F2018: C790). */
2215 496 : if (fini->proc_tree && fini->proc_tree->n.sym->formal->sym->as
2216 112 : && fini->proc_tree->n.sym->formal->sym->as->type == AS_ASSUMED_RANK)
2217 : {
2218 6 : last_code->next = gfc_get_code (EXEC_CALL);
2219 6 : last_code->next->symtree = fini->proc_tree;
2220 6 : last_code->next->resolved_sym = fini->proc_tree->n.sym;
2221 6 : last_code->next->ext.actual = gfc_get_actual_arglist ();
2222 6 : last_code->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
2223 :
2224 6 : last_code = last_code->next;
2225 6 : goto finish_assumed_rank;
2226 : }
2227 :
2228 : /* SELECT CASE (RANK (array)). */
2229 490 : last_code->next = gfc_get_code (EXEC_SELECT);
2230 490 : last_code = last_code->next;
2231 490 : last_code->expr1 = gfc_copy_expr (rank);
2232 490 : block = NULL;
2233 :
2234 :
2235 1075 : for (; fini; fini = fini->next)
2236 : {
2237 585 : gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */
2238 585 : if (fini->proc_tree->n.sym->attr.elemental)
2239 : {
2240 138 : fini_elem = fini;
2241 138 : continue;
2242 : }
2243 :
2244 : /* CASE (fini_rank). */
2245 447 : if (block)
2246 : {
2247 82 : block->block = gfc_get_code (EXEC_SELECT);
2248 82 : block = block->block;
2249 : }
2250 : else
2251 : {
2252 365 : block = gfc_get_code (EXEC_SELECT);
2253 365 : last_code->block = block;
2254 : }
2255 447 : block->ext.block.case_list = gfc_get_case ();
2256 447 : block->ext.block.case_list->where = gfc_current_locus;
2257 447 : if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
2258 132 : block->ext.block.case_list->low
2259 132 : = gfc_get_int_expr (gfc_default_integer_kind, NULL,
2260 132 : fini->proc_tree->n.sym->formal->sym->as->rank);
2261 : else
2262 315 : block->ext.block.case_list->low
2263 315 : = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2264 447 : block->ext.block.case_list->high
2265 447 : = gfc_copy_expr (block->ext.block.case_list->low);
2266 :
2267 : /* CALL fini_rank (array) - possibly with packing. */
2268 447 : if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
2269 132 : finalizer_insert_packed_call (block, fini, array, byte_stride,
2270 : idx, ptr, nelem, strides,
2271 : sizes, idx2, offset, is_contiguous,
2272 : rank, sub_ns);
2273 : else
2274 : {
2275 315 : block->next = gfc_get_code (EXEC_CALL);
2276 315 : block->next->symtree = fini->proc_tree;
2277 315 : block->next->resolved_sym = fini->proc_tree->n.sym;
2278 315 : block->next->ext.actual = gfc_get_actual_arglist ();
2279 315 : block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
2280 : }
2281 : }
2282 :
2283 : /* Elemental call - scalarized. */
2284 490 : if (fini_elem)
2285 : {
2286 : /* CASE DEFAULT. */
2287 138 : if (block)
2288 : {
2289 13 : block->block = gfc_get_code (EXEC_SELECT);
2290 13 : block = block->block;
2291 : }
2292 : else
2293 : {
2294 125 : block = gfc_get_code (EXEC_SELECT);
2295 125 : last_code->block = block;
2296 : }
2297 138 : block->ext.block.case_list = gfc_get_case ();
2298 :
2299 : /* Create loop. */
2300 138 : iter = gfc_get_iterator ();
2301 138 : iter->var = gfc_lval_expr_from_sym (idx);
2302 138 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
2303 138 : iter->end = gfc_lval_expr_from_sym (nelem);
2304 138 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2305 138 : block->next = gfc_get_code (EXEC_DO);
2306 138 : block = block->next;
2307 138 : block->ext.iterator = iter;
2308 138 : block->block = gfc_get_code (EXEC_DO);
2309 :
2310 : /* Offset calculation. */
2311 138 : block = finalization_get_offset (idx, idx2, offset, strides, sizes,
2312 : byte_stride, rank, block->block,
2313 : sub_ns);
2314 :
2315 : /* Create code for
2316 : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2317 : + offset, c_ptr), ptr). */
2318 138 : block->next
2319 138 : = finalization_scalarizer (array, ptr,
2320 : gfc_lval_expr_from_sym (offset),
2321 : sub_ns);
2322 138 : block = block->next;
2323 :
2324 : /* CALL final_elemental (array). */
2325 138 : block->next = gfc_get_code (EXEC_CALL);
2326 138 : block = block->next;
2327 138 : block->symtree = fini_elem->proc_tree;
2328 138 : block->resolved_sym = fini_elem->proc_sym;
2329 138 : block->ext.actual = gfc_get_actual_arglist ();
2330 138 : block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
2331 : }
2332 : }
2333 :
2334 2052 : finish_assumed_rank:
2335 :
2336 : /* Finalize and deallocate allocatable components. The same manual
2337 : scalarization is used as above. */
2338 :
2339 2548 : if (finalizable_comp)
2340 : {
2341 2142 : gfc_symbol *stat;
2342 2142 : gfc_code *block = NULL;
2343 2142 : gfc_expr *ptr_expr;
2344 :
2345 2142 : if (!ptr)
2346 : {
2347 2052 : gfc_get_symbol ("ptr2", sub_ns, &ptr);
2348 2052 : ptr->ts.type = BT_DERIVED;
2349 2052 : ptr->ts.u.derived = derived;
2350 2052 : ptr->attr.flavor = FL_VARIABLE;
2351 2052 : ptr->attr.pointer = 1;
2352 2052 : ptr->attr.artificial = 1;
2353 2052 : gfc_set_sym_referenced (ptr);
2354 2052 : gfc_commit_symbol (ptr);
2355 : }
2356 :
2357 2142 : gfc_get_symbol ("ignore", sub_ns, &stat);
2358 2142 : stat->attr.flavor = FL_VARIABLE;
2359 2142 : stat->attr.artificial = 1;
2360 2142 : stat->ts.type = BT_INTEGER;
2361 2142 : stat->ts.kind = gfc_default_integer_kind;
2362 2142 : gfc_set_sym_referenced (stat);
2363 2142 : gfc_commit_symbol (stat);
2364 :
2365 : /* Create loop. */
2366 2142 : iter = gfc_get_iterator ();
2367 2142 : iter->var = gfc_lval_expr_from_sym (idx);
2368 2142 : iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
2369 2142 : iter->end = gfc_lval_expr_from_sym (nelem);
2370 2142 : iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2371 2142 : last_code->next = gfc_get_code (EXEC_DO);
2372 2142 : last_code = last_code->next;
2373 2142 : last_code->ext.iterator = iter;
2374 2142 : last_code->block = gfc_get_code (EXEC_DO);
2375 :
2376 : /* Offset calculation. */
2377 2142 : block = finalization_get_offset (idx, idx2, offset, strides, sizes,
2378 : byte_stride, rank, last_code->block,
2379 : sub_ns);
2380 :
2381 : /* Create code for
2382 : CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2383 : + idx * stride, c_ptr), ptr). */
2384 2142 : block->next = finalization_scalarizer (array, ptr,
2385 : gfc_lval_expr_from_sym(offset),
2386 : sub_ns);
2387 2142 : block = block->next;
2388 :
2389 2142 : ptr_expr = gfc_lval_expr_from_sym (ptr);
2390 5819 : for (comp = derived->components; comp; comp = comp->next)
2391 : {
2392 3677 : if (comp == derived->components && derived->attr.extension
2393 251 : && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
2394 62 : continue;
2395 :
2396 3615 : finalize_component (ptr_expr, derived, comp, stat, fini_coarray,
2397 : &block, sub_ns);
2398 3615 : if (!last_code->block->next)
2399 0 : last_code->block->next = block;
2400 : }
2401 :
2402 : }
2403 :
2404 : /* Call the finalizer of the ancestor. */
2405 2548 : if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
2406 : {
2407 123 : last_code->next = gfc_get_code (EXEC_CALL);
2408 123 : last_code = last_code->next;
2409 123 : last_code->symtree = ancestor_wrapper->symtree;
2410 123 : last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
2411 :
2412 123 : last_code->ext.actual = gfc_get_actual_arglist ();
2413 123 : last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
2414 123 : last_code->ext.actual->next = gfc_get_actual_arglist ();
2415 123 : last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
2416 123 : last_code->ext.actual->next->next = gfc_get_actual_arglist ();
2417 123 : last_code->ext.actual->next->next->expr
2418 123 : = gfc_lval_expr_from_sym (fini_coarray);
2419 : }
2420 :
2421 2548 : gfc_free_expr (rank);
2422 2548 : vtab_final->initializer = gfc_lval_expr_from_sym (final);
2423 2548 : vtab_final->ts.interface = final;
2424 2548 : free (name);
2425 : }
2426 :
2427 :
2428 : /* Add procedure pointers for all type-bound procedures to a vtab. */
2429 :
2430 : static void
2431 11988 : add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
2432 : {
2433 11988 : gfc_symbol* super_type;
2434 :
2435 11988 : super_type = gfc_get_derived_super_type (derived);
2436 :
2437 11988 : if (super_type && (super_type != derived))
2438 : {
2439 : /* Make sure that the PPCs appear in the same order as in the parent. */
2440 1588 : copy_vtab_proc_comps (super_type, vtype);
2441 : /* Only needed to get the PPC initializers right. */
2442 1588 : add_procs_to_declared_vtab (super_type, vtype);
2443 : }
2444 :
2445 11988 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
2446 2363 : add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
2447 :
2448 11988 : if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
2449 48 : add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
2450 11988 : }
2451 :
2452 :
2453 : /* Find or generate the symbol for a derived type's vtab. */
2454 :
2455 : gfc_symbol *
2456 85023 : gfc_find_derived_vtab (gfc_symbol *derived)
2457 : {
2458 85023 : gfc_namespace *ns;
2459 85023 : gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
2460 85023 : gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
2461 85023 : gfc_gsymbol *gsym = NULL;
2462 85023 : gfc_symbol *dealloc = NULL, *arg = NULL;
2463 :
2464 85023 : if (derived->attr.pdt_template)
2465 : return NULL;
2466 :
2467 : /* Find the top-level namespace, stopping at module/submodule boundaries.
2468 : A submodule's namespace may have its parent pointer set to the ancestor
2469 : module namespace for host-association purposes; we must not escape that
2470 : boundary, because vtables for types defined in a submodule belong in
2471 : the submodule namespace, not in its parent module. */
2472 103918 : for (ns = gfc_current_ns; ns; ns = ns->parent)
2473 103918 : if (!ns->parent
2474 19391 : || (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE))
2475 : break;
2476 :
2477 : /* If the type is a class container, use the underlying derived type. */
2478 84991 : if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
2479 10939 : derived = gfc_get_derived_super_type (derived);
2480 :
2481 10939 : if (!derived)
2482 : return NULL;
2483 :
2484 84991 : if (!derived->name)
2485 : return NULL;
2486 :
2487 : /* Find the gsymbol for the module of use associated derived types. */
2488 84991 : if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
2489 38306 : && !derived->attr.vtype && !derived->attr.is_class)
2490 38306 : gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
2491 : else
2492 : gsym = NULL;
2493 :
2494 : /* Work in the gsymbol namespace if the top-level namespace is a module.
2495 : This ensures that the vtable is unique, which is required since we use
2496 : its address in SELECT TYPE. */
2497 99213 : gfc_namespace *module_ns = ns;
2498 38306 : if (gsym && gsym->ns && ns && ns->proc_name
2499 29581 : && ns->proc_name->attr.flavor == FL_MODULE)
2500 : ns = gsym->ns;
2501 :
2502 60907 : if (ns)
2503 : {
2504 84991 : char tname[GFC_MAX_SYMBOL_LEN+1];
2505 84991 : char *name;
2506 :
2507 84991 : get_unique_hashed_string (tname, derived);
2508 84991 : name = xasprintf ("__vtab_%s", tname);
2509 :
2510 : /* Look for the vtab symbol in various namespaces. */
2511 84991 : if (gsym && gsym->ns)
2512 : {
2513 29581 : gfc_find_symbol (name, gsym->ns, 0, &vtab);
2514 29581 : if (vtab)
2515 29070 : ns = gsym->ns;
2516 : }
2517 84991 : if (vtab == NULL)
2518 55921 : gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
2519 84991 : if (vtab == NULL)
2520 23620 : gfc_find_symbol (name, ns, 0, &vtab);
2521 84991 : if (vtab == NULL)
2522 11301 : gfc_find_symbol (name, derived->ns, 0, &vtab);
2523 : /* If all else fails, look in the module/submodule namespace so that
2524 : the module variable and procedure body translations find the same
2525 : frontend symbol and backend decl. */
2526 84991 : if (vtab == NULL && module_ns != ns)
2527 3 : gfc_find_symbol (name, module_ns, 0, &vtab);
2528 :
2529 : /* Fix up a stale non-use-associated duplicate vtab. */
2530 84991 : if (vtab
2531 73756 : && (derived->attr.use_assoc || derived->attr.used_in_submodule)
2532 36763 : && !vtab->attr.use_assoc && !vtab->module)
2533 : {
2534 1437 : vtab->attr.use_assoc = 1;
2535 1437 : vtab->module = derived->module;
2536 : }
2537 :
2538 84991 : if (vtab == NULL)
2539 : {
2540 11235 : gfc_get_symbol (name, ns, &vtab);
2541 11235 : vtab->ts.type = BT_DERIVED;
2542 11235 : if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
2543 : &gfc_current_locus))
2544 0 : goto cleanup;
2545 11235 : vtab->attr.target = 1;
2546 11235 : vtab->attr.save = SAVE_IMPLICIT;
2547 11235 : vtab->attr.vtab = 1;
2548 11235 : vtab->attr.access = ACCESS_PUBLIC;
2549 11235 : vtab->attr.artificial = 1;
2550 11235 : gfc_set_sym_referenced (vtab);
2551 11235 : free (name);
2552 11235 : name = xasprintf ("__vtype_%s", tname);
2553 :
2554 11235 : gfc_find_symbol (name, ns, 0, &vtype);
2555 11235 : if (vtype == NULL)
2556 : {
2557 11235 : gfc_component *c;
2558 11235 : gfc_symbol *parent = NULL, *parent_vtab = NULL;
2559 :
2560 11235 : gfc_get_symbol (name, ns, &vtype);
2561 11235 : if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
2562 : &gfc_current_locus))
2563 0 : goto cleanup;
2564 11235 : vtype->attr.access = ACCESS_PUBLIC;
2565 11235 : vtype->attr.vtype = 1;
2566 11235 : gfc_set_sym_referenced (vtype);
2567 :
2568 : /* Add component '_hash'. */
2569 11235 : if (!gfc_add_component (vtype, "_hash", &c))
2570 0 : goto cleanup;
2571 11235 : c->ts.type = BT_INTEGER;
2572 11235 : c->ts.kind = 4;
2573 11235 : c->attr.access = ACCESS_PRIVATE;
2574 22470 : c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2575 11235 : NULL, derived->hash_value);
2576 :
2577 : /* Add component '_size'. */
2578 11235 : if (!gfc_add_component (vtype, "_size", &c))
2579 0 : goto cleanup;
2580 11235 : c->ts.type = BT_INTEGER;
2581 11235 : c->ts.kind = gfc_size_kind;
2582 11235 : c->attr.access = ACCESS_PRIVATE;
2583 : /* Remember the derived type in ts.u.derived,
2584 : so that the correct initializer can be set later on
2585 : (in gfc_conv_structure). */
2586 11235 : c->ts.u.derived = derived;
2587 11235 : c->initializer = gfc_get_int_expr (gfc_size_kind,
2588 : NULL, 0);
2589 :
2590 : /* Add component _extends. */
2591 11235 : if (!gfc_add_component (vtype, "_extends", &c))
2592 0 : goto cleanup;
2593 11235 : c->attr.pointer = 1;
2594 11235 : c->attr.access = ACCESS_PRIVATE;
2595 11235 : if (!derived->attr.unlimited_polymorphic)
2596 10404 : parent = gfc_get_derived_super_type (derived);
2597 : else
2598 : parent = NULL;
2599 :
2600 10404 : if (parent)
2601 : {
2602 1461 : parent_vtab = gfc_find_derived_vtab (parent);
2603 1461 : c->ts.type = BT_DERIVED;
2604 1461 : c->ts.u.derived = parent_vtab->ts.u.derived;
2605 1461 : c->initializer = gfc_get_expr ();
2606 1461 : c->initializer->expr_type = EXPR_VARIABLE;
2607 1461 : gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
2608 : 0, &c->initializer->symtree);
2609 : }
2610 : else
2611 : {
2612 9774 : c->ts.type = BT_DERIVED;
2613 9774 : c->ts.u.derived = vtype;
2614 9774 : c->initializer = gfc_get_null_expr (NULL);
2615 : }
2616 :
2617 11235 : if (!derived->attr.unlimited_polymorphic
2618 10404 : && derived->components == NULL
2619 1113 : && !derived->attr.zero_comp)
2620 : {
2621 : /* At this point an error must have occurred.
2622 : Prevent further errors on the vtype components. */
2623 4 : found_sym = vtab;
2624 4 : goto have_vtype;
2625 : }
2626 :
2627 : /* Add component _def_init. */
2628 11231 : if (!gfc_add_component (vtype, "_def_init", &c))
2629 0 : goto cleanup;
2630 11231 : c->attr.pointer = 1;
2631 11231 : c->attr.artificial = 1;
2632 11231 : c->attr.access = ACCESS_PRIVATE;
2633 11231 : c->ts.type = BT_DERIVED;
2634 11231 : c->ts.u.derived = derived;
2635 11231 : if (derived->attr.unlimited_polymorphic
2636 10400 : || derived->attr.abstract)
2637 1148 : c->initializer = gfc_get_null_expr (NULL);
2638 : else
2639 : {
2640 : /* Construct default initialization variable. */
2641 10083 : free (name);
2642 10083 : name = xasprintf ("__def_init_%s", tname);
2643 10083 : gfc_get_symbol (name, ns, &def_init);
2644 10083 : def_init->attr.target = 1;
2645 10083 : def_init->attr.artificial = 1;
2646 10083 : def_init->attr.save = SAVE_IMPLICIT;
2647 10083 : def_init->attr.access = ACCESS_PUBLIC;
2648 10083 : def_init->attr.flavor = FL_VARIABLE;
2649 10083 : gfc_set_sym_referenced (def_init);
2650 10083 : def_init->ts.type = BT_DERIVED;
2651 10083 : def_init->ts.u.derived = derived;
2652 10083 : def_init->value = gfc_default_initializer (&def_init->ts);
2653 :
2654 10083 : c->initializer = gfc_lval_expr_from_sym (def_init);
2655 : }
2656 :
2657 : /* Add component _copy. */
2658 11231 : if (!gfc_add_component (vtype, "_copy", &c))
2659 0 : goto cleanup;
2660 11231 : c->attr.proc_pointer = 1;
2661 11231 : c->attr.access = ACCESS_PRIVATE;
2662 11231 : c->attr.artificial = 1;
2663 11231 : c->tb = XCNEW (gfc_typebound_proc);
2664 11231 : c->tb->ppc = 1;
2665 11231 : if (derived->attr.unlimited_polymorphic
2666 10400 : || derived->attr.abstract)
2667 1148 : c->initializer = gfc_get_null_expr (NULL);
2668 : else
2669 : {
2670 : /* Set up namespace. */
2671 10083 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2672 10083 : sub_ns->sibling = ns->contained;
2673 10083 : ns->contained = sub_ns;
2674 10083 : sub_ns->resolved = 1;
2675 : /* Set up procedure symbol. */
2676 10083 : free (name);
2677 10083 : name = xasprintf ("__copy_%s", tname);
2678 10083 : gfc_get_symbol (name, sub_ns, ©);
2679 10083 : sub_ns->proc_name = copy;
2680 10083 : copy->attr.flavor = FL_PROCEDURE;
2681 10083 : copy->attr.subroutine = 1;
2682 10083 : copy->attr.pure = 1;
2683 10083 : copy->attr.artificial = 1;
2684 10083 : copy->attr.if_source = IFSRC_DECL;
2685 : /* This is elemental so that arrays are automatically
2686 : treated correctly by the scalarizer. */
2687 10083 : copy->attr.elemental = 1;
2688 10083 : if (ns->proc_name->attr.flavor == FL_MODULE)
2689 8200 : copy->module = ns->proc_name->name;
2690 10083 : gfc_set_sym_referenced (copy);
2691 : /* Set up formal arguments. */
2692 10083 : gfc_get_symbol ("src", sub_ns, &src);
2693 10083 : src->ts.type = BT_DERIVED;
2694 10083 : src->ts.u.derived = derived;
2695 10083 : src->attr.flavor = FL_VARIABLE;
2696 10083 : src->attr.dummy = 1;
2697 10083 : src->attr.artificial = 1;
2698 10083 : src->attr.intent = INTENT_IN;
2699 10083 : gfc_set_sym_referenced (src);
2700 10083 : copy->formal = gfc_get_formal_arglist ();
2701 10083 : copy->formal->sym = src;
2702 10083 : gfc_get_symbol ("dst", sub_ns, &dst);
2703 10083 : dst->ts.type = BT_DERIVED;
2704 10083 : dst->ts.u.derived = derived;
2705 10083 : dst->attr.flavor = FL_VARIABLE;
2706 10083 : dst->attr.dummy = 1;
2707 10083 : dst->attr.artificial = 1;
2708 10083 : dst->attr.intent = INTENT_INOUT;
2709 10083 : gfc_set_sym_referenced (dst);
2710 10083 : copy->formal->next = gfc_get_formal_arglist ();
2711 10083 : copy->formal->next->sym = dst;
2712 : /* Set up code. */
2713 10083 : sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
2714 10083 : sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
2715 10083 : sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
2716 : /* Set initializer. */
2717 10083 : c->initializer = gfc_lval_expr_from_sym (copy);
2718 10083 : c->ts.interface = copy;
2719 : }
2720 :
2721 : /* Add component _final, which contains a procedure pointer to
2722 : a wrapper which handles both the freeing of allocatable
2723 : components and the calls to finalization subroutines.
2724 : Note: The actual wrapper function can only be generated
2725 : at resolution time. */
2726 11231 : if (!gfc_add_component (vtype, "_final", &c))
2727 0 : goto cleanup;
2728 11231 : c->attr.proc_pointer = 1;
2729 11231 : c->attr.access = ACCESS_PRIVATE;
2730 11231 : c->attr.artificial = 1;
2731 11231 : c->tb = XCNEW (gfc_typebound_proc);
2732 11231 : c->tb->ppc = 1;
2733 11231 : generate_finalization_wrapper (derived, ns, tname, c);
2734 :
2735 : /* Add component _deallocate. */
2736 11231 : if (!gfc_add_component (vtype, "_deallocate", &c))
2737 0 : goto cleanup;
2738 11231 : c->attr.proc_pointer = 1;
2739 11231 : c->attr.access = ACCESS_PRIVATE;
2740 11231 : c->attr.artificial = 1;
2741 11231 : c->tb = XCNEW (gfc_typebound_proc);
2742 11231 : c->tb->ppc = 1;
2743 11231 : if (derived->attr.unlimited_polymorphic || derived->attr.abstract
2744 10083 : || !derived->attr.recursive)
2745 10958 : c->initializer = gfc_get_null_expr (NULL);
2746 : else
2747 : {
2748 : /* Set up namespace. */
2749 273 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2750 :
2751 273 : sub_ns->sibling = ns->contained;
2752 273 : ns->contained = sub_ns;
2753 273 : sub_ns->resolved = 1;
2754 : /* Set up procedure symbol. */
2755 273 : free (name);
2756 273 : name = xasprintf ("__deallocate_%s", tname);
2757 273 : gfc_get_symbol (name, sub_ns, &dealloc);
2758 273 : sub_ns->proc_name = dealloc;
2759 273 : dealloc->attr.flavor = FL_PROCEDURE;
2760 273 : dealloc->attr.subroutine = 1;
2761 273 : dealloc->attr.pure = 1;
2762 273 : dealloc->attr.artificial = 1;
2763 273 : dealloc->attr.if_source = IFSRC_DECL;
2764 :
2765 273 : if (ns->proc_name->attr.flavor == FL_MODULE)
2766 185 : dealloc->module = ns->proc_name->name;
2767 273 : gfc_set_sym_referenced (dealloc);
2768 : /* Set up formal argument. */
2769 273 : gfc_get_symbol ("arg", sub_ns, &arg);
2770 273 : arg->ts.type = BT_DERIVED;
2771 273 : arg->ts.u.derived = derived;
2772 273 : arg->attr.flavor = FL_VARIABLE;
2773 273 : arg->attr.dummy = 1;
2774 273 : arg->attr.artificial = 1;
2775 273 : arg->attr.intent = INTENT_INOUT;
2776 273 : arg->attr.dimension = 1;
2777 273 : arg->attr.allocatable = 1;
2778 273 : arg->as = gfc_get_array_spec();
2779 273 : arg->as->type = AS_ASSUMED_SHAPE;
2780 273 : arg->as->rank = 1;
2781 273 : arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
2782 : NULL, 1);
2783 273 : gfc_set_sym_referenced (arg);
2784 273 : dealloc->formal = gfc_get_formal_arglist ();
2785 273 : dealloc->formal->sym = arg;
2786 : /* Set up code. */
2787 273 : sub_ns->code = gfc_get_code (EXEC_DEALLOCATE);
2788 273 : sub_ns->code->ext.alloc.list = gfc_get_alloc ();
2789 273 : sub_ns->code->ext.alloc.list->expr
2790 273 : = gfc_lval_expr_from_sym (arg);
2791 : /* Set initializer. */
2792 273 : c->initializer = gfc_lval_expr_from_sym (dealloc);
2793 273 : c->ts.interface = dealloc;
2794 : }
2795 :
2796 : /* Add procedure pointers for type-bound procedures. */
2797 11231 : if (!derived->attr.unlimited_polymorphic)
2798 10400 : add_procs_to_declared_vtab (derived, vtype);
2799 : }
2800 :
2801 0 : have_vtype:
2802 11235 : vtab->ts.u.derived = vtype;
2803 11235 : vtab->value = gfc_default_initializer (&vtab->ts);
2804 : }
2805 84991 : free (name);
2806 : }
2807 :
2808 84991 : found_sym = vtab;
2809 :
2810 84991 : cleanup:
2811 : /* It is unexpected to have some symbols added at resolution or code
2812 : generation time. We commit the changes in order to keep a clean state. */
2813 84991 : if (found_sym)
2814 : {
2815 84991 : gfc_commit_symbol (vtab);
2816 84991 : if (vtype)
2817 11235 : gfc_commit_symbol (vtype);
2818 84991 : if (def_init)
2819 10083 : gfc_commit_symbol (def_init);
2820 84991 : if (copy)
2821 10083 : gfc_commit_symbol (copy);
2822 84991 : if (src)
2823 10083 : gfc_commit_symbol (src);
2824 84991 : if (dst)
2825 10083 : gfc_commit_symbol (dst);
2826 84991 : if (dealloc)
2827 273 : gfc_commit_symbol (dealloc);
2828 84991 : if (arg)
2829 273 : gfc_commit_symbol (arg);
2830 : }
2831 : else
2832 0 : gfc_undo_symbols ();
2833 :
2834 : return found_sym;
2835 : }
2836 :
2837 :
2838 : /* Check if a derived type is finalizable. That is the case if it
2839 : (1) has a FINAL subroutine or
2840 : (2) has a nonpointer nonallocatable component of finalizable type.
2841 : If it is finalizable, return an expression containing the
2842 : finalization wrapper. */
2843 :
2844 : bool
2845 109415 : gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
2846 : {
2847 109415 : gfc_symbol *vtab;
2848 109415 : gfc_component *c;
2849 :
2850 : /* (1) Check for FINAL subroutines. */
2851 109415 : if (derived->f2k_derived && derived->f2k_derived->finalizers)
2852 7467 : goto yes;
2853 :
2854 : /* (2) Check for components of finalizable type. */
2855 263384 : for (c = derived->components; c; c = c->next)
2856 162028 : if (c->ts.type == BT_DERIVED
2857 27996 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
2858 171489 : && gfc_is_finalizable (c->ts.u.derived, NULL))
2859 592 : goto yes;
2860 :
2861 : return false;
2862 :
2863 8059 : yes:
2864 : /* Make sure vtab is generated. */
2865 8059 : vtab = gfc_find_derived_vtab (derived);
2866 8059 : if (final_expr)
2867 : {
2868 : /* Return finalizer expression. */
2869 1020 : gfc_component *final;
2870 1020 : final = vtab->ts.u.derived->components->next->next->next->next->next;
2871 1020 : gcc_assert (strcmp (final->name, "_final") == 0);
2872 1020 : gcc_assert (final->initializer
2873 : && final->initializer->expr_type != EXPR_NULL);
2874 1020 : *final_expr = final->initializer;
2875 :
2876 : /* Fix up a stale non-use-associated duplicate vtab. */
2877 1020 : if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
2878 710 : && (*final_expr)->expr_type == EXPR_VARIABLE
2879 710 : && (*final_expr)->symtree)
2880 : {
2881 710 : gfc_symbol *final_sym = (*final_expr)->symtree->n.sym;
2882 710 : if (final_sym && !final_sym->attr.use_assoc && !final_sym->module)
2883 : {
2884 6 : final_sym->attr.use_assoc = 1;
2885 6 : final_sym->module = derived->module;
2886 : }
2887 : }
2888 : }
2889 : return true;
2890 : }
2891 :
2892 :
2893 : bool
2894 531203 : gfc_may_be_finalized (gfc_typespec ts)
2895 : {
2896 531203 : return (ts.type == BT_CLASS || (ts.type == BT_DERIVED
2897 72638 : && ts.u.derived && gfc_is_finalizable (ts.u.derived, NULL)));
2898 : }
2899 :
2900 :
2901 : /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2902 : needed to support unlimited polymorphism. */
2903 :
2904 : static gfc_symbol *
2905 7108 : find_intrinsic_vtab (gfc_typespec *ts)
2906 : {
2907 7108 : gfc_namespace *ns;
2908 7108 : gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
2909 7108 : gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
2910 :
2911 : /* Find the top-level namespace. */
2912 10157 : for (ns = gfc_current_ns; ns; ns = ns->parent)
2913 10157 : if (!ns->parent)
2914 : break;
2915 :
2916 7108 : if (ns)
2917 : {
2918 7108 : char tname[GFC_MAX_SYMBOL_LEN+1];
2919 7108 : char *name;
2920 :
2921 : /* Encode all types as TYPENAME_KIND_ including especially character
2922 : arrays, whose length is now consistently stored in the _len component
2923 : of the class-variable. */
2924 7108 : sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
2925 7108 : name = xasprintf ("__vtab_%s", tname);
2926 :
2927 : /* Look for the vtab symbol in the top-level namespace only. */
2928 7108 : gfc_find_symbol (name, ns, 0, &vtab);
2929 :
2930 7108 : if (vtab == NULL)
2931 : {
2932 985 : gfc_get_symbol (name, ns, &vtab);
2933 985 : vtab->ts.type = BT_DERIVED;
2934 985 : if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
2935 : &gfc_current_locus))
2936 0 : goto cleanup;
2937 985 : vtab->attr.target = 1;
2938 985 : vtab->attr.save = SAVE_IMPLICIT;
2939 985 : vtab->attr.vtab = 1;
2940 985 : vtab->attr.access = ACCESS_PUBLIC;
2941 985 : gfc_set_sym_referenced (vtab);
2942 985 : free (name);
2943 985 : name = xasprintf ("__vtype_%s", tname);
2944 :
2945 985 : gfc_find_symbol (name, ns, 0, &vtype);
2946 985 : if (vtype == NULL)
2947 : {
2948 985 : gfc_component *c;
2949 985 : int hash;
2950 985 : gfc_namespace *sub_ns;
2951 985 : gfc_namespace *contained;
2952 985 : gfc_expr *e;
2953 985 : size_t e_size;
2954 :
2955 985 : gfc_get_symbol (name, ns, &vtype);
2956 985 : if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
2957 : &gfc_current_locus))
2958 0 : goto cleanup;
2959 985 : vtype->attr.access = ACCESS_PUBLIC;
2960 985 : vtype->attr.vtype = 1;
2961 985 : gfc_set_sym_referenced (vtype);
2962 :
2963 : /* Add component '_hash'. */
2964 985 : if (!gfc_add_component (vtype, "_hash", &c))
2965 0 : goto cleanup;
2966 985 : c->ts.type = BT_INTEGER;
2967 985 : c->ts.kind = 4;
2968 985 : c->attr.access = ACCESS_PRIVATE;
2969 985 : hash = gfc_intrinsic_hash_value (ts);
2970 985 : c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2971 : NULL, hash);
2972 :
2973 : /* Add component '_size'. */
2974 985 : if (!gfc_add_component (vtype, "_size", &c))
2975 0 : goto cleanup;
2976 985 : c->ts.type = BT_INTEGER;
2977 985 : c->ts.kind = gfc_size_kind;
2978 985 : c->attr.access = ACCESS_PRIVATE;
2979 :
2980 : /* Build a minimal expression to make use of
2981 : target-memory.cc/gfc_element_size for 'size'. Special handling
2982 : for character arrays, that are not constant sized: to support
2983 : len (str) * kind, only the kind information is stored in the
2984 : vtab. */
2985 985 : e = gfc_get_expr ();
2986 985 : e->ts = *ts;
2987 985 : e->expr_type = EXPR_VARIABLE;
2988 985 : if (ts->type == BT_CHARACTER)
2989 281 : e_size = ts->kind;
2990 : else
2991 704 : gfc_element_size (e, &e_size);
2992 985 : c->initializer = gfc_get_int_expr (gfc_size_kind,
2993 : NULL,
2994 : e_size);
2995 985 : gfc_free_expr (e);
2996 :
2997 : /* Add component _extends. */
2998 985 : if (!gfc_add_component (vtype, "_extends", &c))
2999 0 : goto cleanup;
3000 985 : c->attr.pointer = 1;
3001 985 : c->attr.access = ACCESS_PRIVATE;
3002 985 : c->ts.type = BT_VOID;
3003 985 : c->initializer = gfc_get_null_expr (NULL);
3004 :
3005 : /* Add component _def_init. */
3006 985 : if (!gfc_add_component (vtype, "_def_init", &c))
3007 0 : goto cleanup;
3008 985 : c->attr.pointer = 1;
3009 985 : c->attr.access = ACCESS_PRIVATE;
3010 985 : c->ts.type = BT_VOID;
3011 985 : c->initializer = gfc_get_null_expr (NULL);
3012 :
3013 : /* Add component _copy. */
3014 985 : if (!gfc_add_component (vtype, "_copy", &c))
3015 0 : goto cleanup;
3016 985 : c->attr.proc_pointer = 1;
3017 985 : c->attr.access = ACCESS_PRIVATE;
3018 985 : c->attr.artificial = 1;
3019 985 : c->tb = XCNEW (gfc_typebound_proc);
3020 985 : c->tb->ppc = 1;
3021 :
3022 985 : free (name);
3023 985 : if (ts->type != BT_CHARACTER)
3024 704 : name = xasprintf ("__copy_%s", tname);
3025 : else
3026 : {
3027 : /* __copy is always the same for characters.
3028 : Check to see if copy function already exists. */
3029 281 : name = xasprintf ("__copy_character_%d", ts->kind);
3030 281 : contained = ns->contained;
3031 1376 : for (; contained; contained = contained->sibling)
3032 1095 : if (contained->proc_name
3033 1095 : && strcmp (name, contained->proc_name->name) == 0)
3034 : {
3035 0 : copy = contained->proc_name;
3036 0 : goto got_char_copy;
3037 : }
3038 : }
3039 :
3040 : /* Set up namespace. */
3041 985 : sub_ns = gfc_get_namespace (ns, 0);
3042 985 : sub_ns->sibling = ns->contained;
3043 985 : ns->contained = sub_ns;
3044 985 : sub_ns->resolved = 1;
3045 : /* Set up procedure symbol. */
3046 985 : gfc_get_symbol (name, sub_ns, ©);
3047 985 : sub_ns->proc_name = copy;
3048 985 : copy->attr.flavor = FL_PROCEDURE;
3049 985 : copy->attr.subroutine = 1;
3050 985 : copy->attr.pure = 1;
3051 985 : copy->attr.if_source = IFSRC_DECL;
3052 : /* This is elemental so that arrays are automatically
3053 : treated correctly by the scalarizer. */
3054 985 : copy->attr.elemental = 1;
3055 985 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
3056 217 : copy->module = ns->proc_name->name;
3057 985 : gfc_set_sym_referenced (copy);
3058 : /* Set up formal arguments. */
3059 985 : gfc_get_symbol ("src", sub_ns, &src);
3060 985 : src->ts.type = ts->type;
3061 985 : src->ts.kind = ts->kind;
3062 985 : src->attr.flavor = FL_VARIABLE;
3063 985 : src->attr.dummy = 1;
3064 985 : src->attr.intent = INTENT_IN;
3065 985 : gfc_set_sym_referenced (src);
3066 985 : copy->formal = gfc_get_formal_arglist ();
3067 985 : copy->formal->sym = src;
3068 985 : gfc_get_symbol ("dst", sub_ns, &dst);
3069 985 : dst->ts.type = ts->type;
3070 985 : dst->ts.kind = ts->kind;
3071 985 : dst->attr.flavor = FL_VARIABLE;
3072 985 : dst->attr.dummy = 1;
3073 985 : dst->attr.intent = INTENT_INOUT;
3074 985 : gfc_set_sym_referenced (dst);
3075 985 : copy->formal->next = gfc_get_formal_arglist ();
3076 985 : copy->formal->next->sym = dst;
3077 : /* Set up code. */
3078 985 : sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
3079 985 : sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
3080 985 : sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
3081 985 : got_char_copy:
3082 : /* Set initializer. */
3083 985 : c->initializer = gfc_lval_expr_from_sym (copy);
3084 985 : c->ts.interface = copy;
3085 :
3086 : /* Add component _final. */
3087 985 : if (!gfc_add_component (vtype, "_final", &c))
3088 0 : goto cleanup;
3089 985 : c->attr.proc_pointer = 1;
3090 985 : c->attr.access = ACCESS_PRIVATE;
3091 985 : c->attr.artificial = 1;
3092 985 : c->tb = XCNEW (gfc_typebound_proc);
3093 985 : c->tb->ppc = 1;
3094 985 : c->initializer = gfc_get_null_expr (NULL);
3095 : }
3096 985 : vtab->ts.u.derived = vtype;
3097 985 : vtab->value = gfc_default_initializer (&vtab->ts);
3098 : }
3099 7108 : free (name);
3100 : }
3101 :
3102 7108 : found_sym = vtab;
3103 :
3104 7108 : cleanup:
3105 : /* It is unexpected to have some symbols added at resolution or code
3106 : generation time. We commit the changes in order to keep a clean state. */
3107 7108 : if (found_sym)
3108 : {
3109 7108 : gfc_commit_symbol (vtab);
3110 7108 : if (vtype)
3111 985 : gfc_commit_symbol (vtype);
3112 7108 : if (copy)
3113 985 : gfc_commit_symbol (copy);
3114 7108 : if (src)
3115 985 : gfc_commit_symbol (src);
3116 7108 : if (dst)
3117 985 : gfc_commit_symbol (dst);
3118 : }
3119 : else
3120 0 : gfc_undo_symbols ();
3121 :
3122 7108 : return found_sym;
3123 : }
3124 :
3125 :
3126 : /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
3127 :
3128 : gfc_symbol *
3129 21438 : gfc_find_vtab (gfc_typespec *ts)
3130 : {
3131 21438 : switch (ts->type)
3132 : {
3133 : case BT_UNKNOWN:
3134 : return NULL;
3135 8759 : case BT_DERIVED:
3136 8759 : return gfc_find_derived_vtab (ts->u.derived);
3137 5489 : case BT_CLASS:
3138 5489 : if (ts->u.derived->attr.is_class
3139 5485 : && ts->u.derived->components
3140 5485 : && ts->u.derived->components->ts.u.derived)
3141 5485 : return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
3142 : else
3143 : return NULL;
3144 7108 : default:
3145 7108 : return find_intrinsic_vtab (ts);
3146 : }
3147 : }
3148 :
3149 :
3150 : /* General worker function to find either a type-bound procedure or a
3151 : type-bound user operator. */
3152 :
3153 : static gfc_symtree*
3154 446642 : find_typebound_proc_uop (gfc_symbol* derived, bool* t,
3155 : const char* name, bool noaccess, bool uop,
3156 : locus* where)
3157 : {
3158 498749 : gfc_symtree* res;
3159 498749 : gfc_symtree* root;
3160 :
3161 : /* Set default to failure. */
3162 498749 : if (t)
3163 474396 : *t = false;
3164 :
3165 498749 : if (derived->f2k_derived)
3166 : /* Set correct symbol-root. */
3167 379663 : root = (uop ? derived->f2k_derived->tb_uop_root
3168 : : derived->f2k_derived->tb_sym_root);
3169 : else
3170 : return NULL;
3171 :
3172 : /* Try to find it in the current type's namespace. */
3173 379663 : res = gfc_find_symtree (root, name);
3174 379663 : if (res && res->n.tb && !res->n.tb->error)
3175 : {
3176 : /* We found one. */
3177 10686 : if (t)
3178 6110 : *t = true;
3179 :
3180 10686 : if (!noaccess && derived->attr.use_assoc
3181 3499 : && res->n.tb->access == ACCESS_PRIVATE)
3182 : {
3183 3 : if (where)
3184 2 : gfc_error ("%qs of %qs is PRIVATE at %L",
3185 : name, derived->name, where);
3186 3 : if (t)
3187 3 : *t = false;
3188 : }
3189 :
3190 : return res;
3191 : }
3192 :
3193 : /* Otherwise, recurse on parent type if derived is an extension. */
3194 368977 : if (derived->attr.extension)
3195 : {
3196 52107 : gfc_symbol* super_type;
3197 52107 : super_type = gfc_get_derived_super_type (derived);
3198 52107 : gcc_assert (super_type);
3199 :
3200 : return find_typebound_proc_uop (super_type, t, name,
3201 : noaccess, uop, where);
3202 : }
3203 :
3204 : /* Nothing found. */
3205 : return NULL;
3206 : }
3207 :
3208 :
3209 : /* Find a type-bound procedure or user operator by name for a derived-type
3210 : (looking recursively through the super-types). */
3211 :
3212 : gfc_symtree*
3213 446390 : gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
3214 : const char* name, bool noaccess, locus* where)
3215 : {
3216 446390 : return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
3217 : }
3218 :
3219 : gfc_symtree*
3220 252 : gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
3221 : const char* name, bool noaccess, locus* where)
3222 : {
3223 252 : return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
3224 : }
3225 :
3226 :
3227 : /* Find a type-bound intrinsic operator looking recursively through the
3228 : super-type hierarchy. */
3229 :
3230 : gfc_typebound_proc*
3231 22627 : gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
3232 : gfc_intrinsic_op op, bool noaccess,
3233 : locus* where)
3234 : {
3235 23562 : gfc_typebound_proc* res;
3236 :
3237 : /* Set default to failure. */
3238 23562 : if (t)
3239 23561 : *t = false;
3240 :
3241 : /* Try to find it in the current type's namespace. */
3242 23562 : if (derived->f2k_derived)
3243 19475 : res = derived->f2k_derived->tb_op[op];
3244 : else
3245 : res = NULL;
3246 :
3247 : /* Check access. */
3248 19475 : if (res && !res->error)
3249 : {
3250 : /* We found one. */
3251 904 : if (t)
3252 903 : *t = true;
3253 :
3254 904 : if (!noaccess && derived->attr.use_assoc
3255 761 : && res->access == ACCESS_PRIVATE)
3256 : {
3257 2 : if (where)
3258 0 : gfc_error ("%qs of %qs is PRIVATE at %L",
3259 : gfc_op2string (op), derived->name, where);
3260 2 : if (t)
3261 2 : *t = false;
3262 : }
3263 :
3264 : return res;
3265 : }
3266 :
3267 : /* Otherwise, recurse on parent type if derived is an extension. */
3268 22658 : if (derived->attr.extension)
3269 : {
3270 935 : gfc_symbol* super_type;
3271 935 : super_type = gfc_get_derived_super_type (derived);
3272 935 : gcc_assert (super_type);
3273 :
3274 : return gfc_find_typebound_intrinsic_op (super_type, t, op,
3275 : noaccess, where);
3276 : }
3277 :
3278 : /* Nothing found. */
3279 : return NULL;
3280 : }
3281 :
3282 :
3283 : /* Get a typebound-procedure symtree or create and insert it if not yet
3284 : present. This is like a very simplified version of gfc_get_sym_tree for
3285 : tbp-symtrees rather than regular ones. */
3286 :
3287 : gfc_symtree*
3288 9348 : gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
3289 : {
3290 9348 : gfc_symtree *result = gfc_find_symtree (*root, name);
3291 9348 : return result ? result : gfc_new_symtree (root, name);
3292 : }
|
