]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/class.c
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
re PR fortran/59493 ([OOP] ICE: Segfault on Class(*) pointer association)
[thirdparty/gcc.git] / gcc / fortran / class.c
1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2013 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.c -- 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 For each derived type we set up a "vtable" entry, i.e. a structure with the
38 following fields:
39 * _hash: A hash value serving as a unique identifier for this type.
40 * _size: The size in bytes of the derived type.
41 * _extends: A pointer to the vtable entry of the parent derived type.
42 * _def_init: A pointer to a default initialized variable of this type.
43 * _copy: A procedure pointer to a copying procedure.
44 * _final: A procedure pointer to a wrapper function, which frees
45 allocatable components and calls FINAL subroutines.
46
47 After these follow procedure pointer components for the specific
48 type-bound procedures. */
49
50
51 #include "config.h"
52 #include "system.h"
53 #include "coretypes.h"
54 #include "gfortran.h"
55 #include "constructor.h"
56 #include "target-memory.h"
57
58 /* Inserts a derived type component reference in a data reference chain.
59 TS: base type of the ref chain so far, in which we will pick the component
60 REF: the address of the GFC_REF pointer to update
61 NAME: name of the component to insert
62 Note that component insertion makes sense only if we are at the end of
63 the chain (*REF == NULL) or if we are adding a missing "_data" component
64 to access the actual contents of a class object. */
65
66 static void
67 insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
68 {
69 gfc_symbol *type_sym;
70 gfc_ref *new_ref;
71
72 gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
73 type_sym = ts->u.derived;
74
75 new_ref = gfc_get_ref ();
76 new_ref->type = REF_COMPONENT;
77 new_ref->next = *ref;
78 new_ref->u.c.sym = type_sym;
79 new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
80 gcc_assert (new_ref->u.c.component);
81
82 if (new_ref->next)
83 {
84 gfc_ref *next = NULL;
85
86 /* We need to update the base type in the trailing reference chain to
87 that of the new component. */
88
89 gcc_assert (strcmp (name, "_data") == 0);
90
91 if (new_ref->next->type == REF_COMPONENT)
92 next = new_ref->next;
93 else if (new_ref->next->type == REF_ARRAY
94 && new_ref->next->next
95 && new_ref->next->next->type == REF_COMPONENT)
96 next = new_ref->next->next;
97
98 if (next != NULL)
99 {
100 gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
101 || new_ref->u.c.component->ts.type == BT_DERIVED);
102 next->u.c.sym = new_ref->u.c.component->ts.u.derived;
103 }
104 }
105
106 *ref = new_ref;
107 }
108
109
110 /* Tells whether we need to add a "_data" reference to access REF subobject
111 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
112 object accessed by REF is a variable; in other words it is a full object,
113 not a subobject. */
114
115 static bool
116 class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
117 {
118 /* Only class containers may need the "_data" reference. */
119 if (ts->type != BT_CLASS)
120 return false;
121
122 /* Accessing a class container with an array reference is certainly wrong. */
123 if (ref->type != REF_COMPONENT)
124 return true;
125
126 /* Accessing the class container's fields is fine. */
127 if (ref->u.c.component->name[0] == '_')
128 return false;
129
130 /* At this point we have a class container with a non class container's field
131 component reference. We don't want to add the "_data" component if we are
132 at the first reference and the symbol's type is an extended derived type.
133 In that case, conv_parent_component_references will do the right thing so
134 it is not absolutely necessary. Omitting it prevents a regression (see
135 class_41.f03) in the interface mapping mechanism. When evaluating string
136 lengths depending on dummy arguments, we create a fake symbol with a type
137 equal to that of the dummy type. However, because of type extension,
138 the backend type (corresponding to the actual argument) can have a
139 different (extended) type. Adding the "_data" component explicitly, using
140 the base type, confuses the gfc_conv_component_ref code which deals with
141 the extended type. */
142 if (first_ref_in_chain && ts->u.derived->attr.extension)
143 return false;
144
145 /* We have a class container with a non class container's field component
146 reference that doesn't fall into the above. */
147 return true;
148 }
149
150
151 /* Browse through a data reference chain and add the missing "_data" references
152 when a subobject of a class object is accessed without it.
153 Note that it doesn't add the "_data" reference when the class container
154 is the last element in the reference chain. */
155
156 void
157 gfc_fix_class_refs (gfc_expr *e)
158 {
159 gfc_typespec *ts;
160 gfc_ref **ref;
161
162 if ((e->expr_type != EXPR_VARIABLE
163 && e->expr_type != EXPR_FUNCTION)
164 || (e->expr_type == EXPR_FUNCTION
165 && e->value.function.isym != NULL))
166 return;
167
168 if (e->expr_type == EXPR_VARIABLE)
169 ts = &e->symtree->n.sym->ts;
170 else
171 {
172 gfc_symbol *func;
173
174 gcc_assert (e->expr_type == EXPR_FUNCTION);
175 if (e->value.function.esym != NULL)
176 func = e->value.function.esym;
177 else
178 func = e->symtree->n.sym;
179
180 if (func->result != NULL)
181 ts = &func->result->ts;
182 else
183 ts = &func->ts;
184 }
185
186 for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
187 {
188 if (class_data_ref_missing (ts, *ref, ref == &e->ref))
189 insert_component_ref (ts, ref, "_data");
190
191 if ((*ref)->type == REF_COMPONENT)
192 ts = &(*ref)->u.c.component->ts;
193 }
194 }
195
196
197 /* Insert a reference to the component of the given name.
198 Only to be used with CLASS containers and vtables. */
199
200 void
201 gfc_add_component_ref (gfc_expr *e, const char *name)
202 {
203 gfc_ref **tail = &(e->ref);
204 gfc_ref *next = NULL;
205 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
206 while (*tail != NULL)
207 {
208 if ((*tail)->type == REF_COMPONENT)
209 {
210 if (strcmp ((*tail)->u.c.component->name, "_data") == 0
211 && (*tail)->next
212 && (*tail)->next->type == REF_ARRAY
213 && (*tail)->next->next == NULL)
214 return;
215 derived = (*tail)->u.c.component->ts.u.derived;
216 }
217 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
218 break;
219 tail = &((*tail)->next);
220 }
221 if (*tail != NULL && strcmp (name, "_data") == 0)
222 next = *tail;
223 (*tail) = gfc_get_ref();
224 (*tail)->next = next;
225 (*tail)->type = REF_COMPONENT;
226 (*tail)->u.c.sym = derived;
227 (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
228 gcc_assert((*tail)->u.c.component);
229 if (!next)
230 e->ts = (*tail)->u.c.component->ts;
231 }
232
233
234 /* This is used to add both the _data component reference and an array
235 reference to class expressions. Used in translation of intrinsic
236 array inquiry functions. */
237
238 void
239 gfc_add_class_array_ref (gfc_expr *e)
240 {
241 int rank = CLASS_DATA (e)->as->rank;
242 gfc_array_spec *as = CLASS_DATA (e)->as;
243 gfc_ref *ref = NULL;
244 gfc_add_component_ref (e, "_data");
245 e->rank = rank;
246 for (ref = e->ref; ref; ref = ref->next)
247 if (!ref->next)
248 break;
249 if (ref->type != REF_ARRAY)
250 {
251 ref->next = gfc_get_ref ();
252 ref = ref->next;
253 ref->type = REF_ARRAY;
254 ref->u.ar.type = AR_FULL;
255 ref->u.ar.as = as;
256 }
257 }
258
259
260 /* Unfortunately, class array expressions can appear in various conditions;
261 with and without both _data component and an arrayspec. This function
262 deals with that variability. The previous reference to 'ref' is to a
263 class array. */
264
265 static bool
266 class_array_ref_detected (gfc_ref *ref, bool *full_array)
267 {
268 bool no_data = false;
269 bool with_data = false;
270
271 /* An array reference with no _data component. */
272 if (ref && ref->type == REF_ARRAY
273 && !ref->next
274 && ref->u.ar.type != AR_ELEMENT)
275 {
276 if (full_array)
277 *full_array = ref->u.ar.type == AR_FULL;
278 no_data = true;
279 }
280
281 /* Cover cases where _data appears, with or without an array ref. */
282 if (ref && ref->type == REF_COMPONENT
283 && strcmp (ref->u.c.component->name, "_data") == 0)
284 {
285 if (!ref->next)
286 {
287 with_data = true;
288 if (full_array)
289 *full_array = true;
290 }
291 else if (ref->next && ref->next->type == REF_ARRAY
292 && !ref->next->next
293 && ref->type == REF_COMPONENT
294 && ref->next->type == REF_ARRAY
295 && ref->next->u.ar.type != AR_ELEMENT)
296 {
297 with_data = true;
298 if (full_array)
299 *full_array = ref->next->u.ar.type == AR_FULL;
300 }
301 }
302
303 return no_data || with_data;
304 }
305
306
307 /* Returns true if the expression contains a reference to a class
308 array. Notice that class array elements return false. */
309
310 bool
311 gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
312 {
313 gfc_ref *ref;
314
315 if (!e->rank)
316 return false;
317
318 if (full_array)
319 *full_array= false;
320
321 /* Is this a class array object? ie. Is the symbol of type class? */
322 if (e->symtree
323 && e->symtree->n.sym->ts.type == BT_CLASS
324 && CLASS_DATA (e->symtree->n.sym)
325 && CLASS_DATA (e->symtree->n.sym)->attr.dimension
326 && class_array_ref_detected (e->ref, full_array))
327 return true;
328
329 /* Or is this a class array component reference? */
330 for (ref = e->ref; ref; ref = ref->next)
331 {
332 if (ref->type == REF_COMPONENT
333 && ref->u.c.component->ts.type == BT_CLASS
334 && CLASS_DATA (ref->u.c.component)->attr.dimension
335 && class_array_ref_detected (ref->next, full_array))
336 return true;
337 }
338
339 return false;
340 }
341
342
343 /* Returns true if the expression is a reference to a class
344 scalar. This function is necessary because such expressions
345 can be dressed with a reference to the _data component and so
346 have a type other than BT_CLASS. */
347
348 bool
349 gfc_is_class_scalar_expr (gfc_expr *e)
350 {
351 gfc_ref *ref;
352
353 if (e->rank)
354 return false;
355
356 /* Is this a class object? */
357 if (e->symtree
358 && e->symtree->n.sym->ts.type == BT_CLASS
359 && CLASS_DATA (e->symtree->n.sym)
360 && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
361 && (e->ref == NULL
362 || (strcmp (e->ref->u.c.component->name, "_data") == 0
363 && e->ref->next == NULL)))
364 return true;
365
366 /* Or is the final reference BT_CLASS or _data? */
367 for (ref = e->ref; ref; ref = ref->next)
368 {
369 if (ref->type == REF_COMPONENT
370 && ref->u.c.component->ts.type == BT_CLASS
371 && CLASS_DATA (ref->u.c.component)
372 && !CLASS_DATA (ref->u.c.component)->attr.dimension
373 && (ref->next == NULL
374 || (strcmp (ref->next->u.c.component->name, "_data") == 0
375 && ref->next->next == NULL)))
376 return true;
377 }
378
379 return false;
380 }
381
382
383 /* Tells whether the expression E is a reference to a (scalar) class container.
384 Scalar because array class containers usually have an array reference after
385 them, and gfc_fix_class_refs will add the missing "_data" component reference
386 in that case. */
387
388 bool
389 gfc_is_class_container_ref (gfc_expr *e)
390 {
391 gfc_ref *ref;
392 bool result;
393
394 if (e->expr_type != EXPR_VARIABLE)
395 return e->ts.type == BT_CLASS;
396
397 if (e->symtree->n.sym->ts.type == BT_CLASS)
398 result = true;
399 else
400 result = false;
401
402 for (ref = e->ref; ref; ref = ref->next)
403 {
404 if (ref->type != REF_COMPONENT)
405 result = false;
406 else if (ref->u.c.component->ts.type == BT_CLASS)
407 result = true;
408 else
409 result = false;
410 }
411
412 return result;
413 }
414
415
416 /* Build an initializer for CLASS pointers,
417 initializing the _data component to the init_expr (or NULL) and the _vptr
418 component to the corresponding type (or the declared type, given by ts). */
419
420 gfc_expr *
421 gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
422 {
423 gfc_expr *init;
424 gfc_component *comp;
425 gfc_symbol *vtab = NULL;
426
427 if (init_expr && init_expr->expr_type != EXPR_NULL)
428 vtab = gfc_find_vtab (&init_expr->ts);
429 else
430 vtab = gfc_find_vtab (ts);
431
432 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
433 &ts->u.derived->declared_at);
434 init->ts = *ts;
435
436 for (comp = ts->u.derived->components; comp; comp = comp->next)
437 {
438 gfc_constructor *ctor = gfc_constructor_get();
439 if (strcmp (comp->name, "_vptr") == 0 && vtab)
440 ctor->expr = gfc_lval_expr_from_sym (vtab);
441 else if (init_expr && init_expr->expr_type != EXPR_NULL)
442 ctor->expr = gfc_copy_expr (init_expr);
443 else
444 ctor->expr = gfc_get_null_expr (NULL);
445 gfc_constructor_append (&init->value.constructor, ctor);
446 }
447
448 return init;
449 }
450
451
452 /* Create a unique string identifier for a derived type, composed of its name
453 and module name. This is used to construct unique names for the class
454 containers and vtab symbols. */
455
456 static void
457 get_unique_type_string (char *string, gfc_symbol *derived)
458 {
459 char dt_name[GFC_MAX_SYMBOL_LEN+1];
460 if (derived->attr.unlimited_polymorphic)
461 strcpy (dt_name, "STAR");
462 else
463 strcpy (dt_name, derived->name);
464 dt_name[0] = TOUPPER (dt_name[0]);
465 if (derived->attr.unlimited_polymorphic)
466 sprintf (string, "_%s", dt_name);
467 else if (derived->module)
468 sprintf (string, "%s_%s", derived->module, dt_name);
469 else if (derived->ns->proc_name)
470 sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
471 else
472 sprintf (string, "_%s", dt_name);
473 }
474
475
476 /* A relative of 'get_unique_type_string' which makes sure the generated
477 string will not be too long (replacing it by a hash string if needed). */
478
479 static void
480 get_unique_hashed_string (char *string, gfc_symbol *derived)
481 {
482 char tmp[2*GFC_MAX_SYMBOL_LEN+2];
483 get_unique_type_string (&tmp[0], derived);
484 /* If string is too long, use hash value in hex representation (allow for
485 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
486 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
487 where %d is the (co)rank which can be up to n = 15. */
488 if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
489 {
490 int h = gfc_hash_value (derived);
491 sprintf (string, "%X", h);
492 }
493 else
494 strcpy (string, tmp);
495 }
496
497
498 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
499
500 unsigned int
501 gfc_hash_value (gfc_symbol *sym)
502 {
503 unsigned int hash = 0;
504 char c[2*(GFC_MAX_SYMBOL_LEN+1)];
505 int i, len;
506
507 get_unique_type_string (&c[0], sym);
508 len = strlen (c);
509
510 for (i = 0; i < len; i++)
511 hash = (hash << 6) + (hash << 16) - hash + c[i];
512
513 /* Return the hash but take the modulus for the sake of module read,
514 even though this slightly increases the chance of collision. */
515 return (hash % 100000000);
516 }
517
518
519 /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
520
521 unsigned int
522 gfc_intrinsic_hash_value (gfc_typespec *ts)
523 {
524 unsigned int hash = 0;
525 const char *c = gfc_typename (ts);
526 int i, len;
527
528 len = strlen (c);
529
530 for (i = 0; i < len; i++)
531 hash = (hash << 6) + (hash << 16) - hash + c[i];
532
533 /* Return the hash but take the modulus for the sake of module read,
534 even though this slightly increases the chance of collision. */
535 return (hash % 100000000);
536 }
537
538
539 /* Build a polymorphic CLASS entity, using the symbol that comes from
540 build_sym. A CLASS entity is represented by an encapsulating type,
541 which contains the declared type as '_data' component, plus a pointer
542 component '_vptr' which determines the dynamic type. */
543
544 bool
545 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
546 gfc_array_spec **as, bool delayed_vtab)
547 {
548 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
549 gfc_symbol *fclass;
550 gfc_symbol *vtab;
551 gfc_component *c;
552 gfc_namespace *ns;
553 int rank;
554
555 gcc_assert (as);
556
557 if (*as && (*as)->type == AS_ASSUMED_SIZE)
558 {
559 gfc_error ("Assumed size polymorphic objects or components, such "
560 "as that at %C, have not yet been implemented");
561 return false;
562 }
563
564 if (attr->class_ok)
565 /* Class container has already been built. */
566 return true;
567
568 attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
569 || attr->select_type_temporary || attr->associate_var;
570
571 if (!attr->class_ok)
572 /* We can not build the class container yet. */
573 return true;
574
575 /* Determine the name of the encapsulating type. */
576 rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
577 get_unique_hashed_string (tname, ts->u.derived);
578 if ((*as) && attr->allocatable)
579 sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
580 else if ((*as) && attr->pointer)
581 sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
582 else if ((*as))
583 sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
584 else if (attr->pointer)
585 sprintf (name, "__class_%s_p", tname);
586 else if (attr->allocatable)
587 sprintf (name, "__class_%s_a", tname);
588 else
589 sprintf (name, "__class_%s", tname);
590
591 if (ts->u.derived->attr.unlimited_polymorphic)
592 {
593 /* Find the top-level namespace. */
594 for (ns = gfc_current_ns; ns; ns = ns->parent)
595 if (!ns->parent)
596 break;
597 }
598 else
599 ns = ts->u.derived->ns;
600
601 gfc_find_symbol (name, ns, 0, &fclass);
602 if (fclass == NULL)
603 {
604 gfc_symtree *st;
605 /* If not there, create a new symbol. */
606 fclass = gfc_new_symbol (name, ns);
607 st = gfc_new_symtree (&ns->sym_root, name);
608 st->n.sym = fclass;
609 gfc_set_sym_referenced (fclass);
610 fclass->refs++;
611 fclass->ts.type = BT_UNKNOWN;
612 if (!ts->u.derived->attr.unlimited_polymorphic)
613 fclass->attr.abstract = ts->u.derived->attr.abstract;
614 fclass->f2k_derived = gfc_get_namespace (NULL, 0);
615 if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
616 &gfc_current_locus))
617 return false;
618
619 /* Add component '_data'. */
620 if (!gfc_add_component (fclass, "_data", &c))
621 return false;
622 c->ts = *ts;
623 c->ts.type = BT_DERIVED;
624 c->attr.access = ACCESS_PRIVATE;
625 c->ts.u.derived = ts->u.derived;
626 c->attr.class_pointer = attr->pointer;
627 c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
628 || attr->select_type_temporary;
629 c->attr.allocatable = attr->allocatable;
630 c->attr.dimension = attr->dimension;
631 c->attr.codimension = attr->codimension;
632 c->attr.abstract = fclass->attr.abstract;
633 c->as = (*as);
634 c->initializer = NULL;
635
636 /* Add component '_vptr'. */
637 if (!gfc_add_component (fclass, "_vptr", &c))
638 return false;
639 c->ts.type = BT_DERIVED;
640 if (delayed_vtab
641 || (ts->u.derived->f2k_derived
642 && ts->u.derived->f2k_derived->finalizers))
643 c->ts.u.derived = NULL;
644 else
645 {
646 vtab = gfc_find_derived_vtab (ts->u.derived);
647 gcc_assert (vtab);
648 c->ts.u.derived = vtab->ts.u.derived;
649 }
650 c->attr.access = ACCESS_PRIVATE;
651 c->attr.pointer = 1;
652 }
653
654 if (!ts->u.derived->attr.unlimited_polymorphic)
655 {
656 /* Since the extension field is 8 bit wide, we can only have
657 up to 255 extension levels. */
658 if (ts->u.derived->attr.extension == 255)
659 {
660 gfc_error ("Maximum extension level reached with type '%s' at %L",
661 ts->u.derived->name, &ts->u.derived->declared_at);
662 return false;
663 }
664
665 fclass->attr.extension = ts->u.derived->attr.extension + 1;
666 fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
667 fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
668 }
669
670 fclass->attr.is_class = 1;
671 ts->u.derived = fclass;
672 attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
673 (*as) = NULL;
674 return true;
675 }
676
677
678 /* Add a procedure pointer component to the vtype
679 to represent a specific type-bound procedure. */
680
681 static void
682 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
683 {
684 gfc_component *c;
685
686 if (tb->non_overridable)
687 return;
688
689 c = gfc_find_component (vtype, name, true, true);
690
691 if (c == NULL)
692 {
693 /* Add procedure component. */
694 if (!gfc_add_component (vtype, name, &c))
695 return;
696
697 if (!c->tb)
698 c->tb = XCNEW (gfc_typebound_proc);
699 *c->tb = *tb;
700 c->tb->ppc = 1;
701 c->attr.procedure = 1;
702 c->attr.proc_pointer = 1;
703 c->attr.flavor = FL_PROCEDURE;
704 c->attr.access = ACCESS_PRIVATE;
705 c->attr.external = 1;
706 c->attr.untyped = 1;
707 c->attr.if_source = IFSRC_IFBODY;
708 }
709 else if (c->attr.proc_pointer && c->tb)
710 {
711 *c->tb = *tb;
712 c->tb->ppc = 1;
713 }
714
715 if (tb->u.specific)
716 {
717 c->ts.interface = tb->u.specific->n.sym;
718 if (!tb->deferred)
719 c->initializer = gfc_get_variable_expr (tb->u.specific);
720 }
721 }
722
723
724 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
725
726 static void
727 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
728 {
729 if (!st)
730 return;
731
732 if (st->left)
733 add_procs_to_declared_vtab1 (st->left, vtype);
734
735 if (st->right)
736 add_procs_to_declared_vtab1 (st->right, vtype);
737
738 if (st->n.tb && !st->n.tb->error
739 && !st->n.tb->is_generic && st->n.tb->u.specific)
740 add_proc_comp (vtype, st->name, st->n.tb);
741 }
742
743
744 /* Copy procedure pointers components from the parent type. */
745
746 static void
747 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
748 {
749 gfc_component *cmp;
750 gfc_symbol *vtab;
751
752 vtab = gfc_find_derived_vtab (declared);
753
754 for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
755 {
756 if (gfc_find_component (vtype, cmp->name, true, true))
757 continue;
758
759 add_proc_comp (vtype, cmp->name, cmp->tb);
760 }
761 }
762
763
764 /* Returns true if any of its nonpointer nonallocatable components or
765 their nonpointer nonallocatable subcomponents has a finalization
766 subroutine. */
767
768 static bool
769 has_finalizer_component (gfc_symbol *derived)
770 {
771 gfc_component *c;
772
773 for (c = derived->components; c; c = c->next)
774 {
775 if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived
776 && c->ts.u.derived->f2k_derived->finalizers)
777 return true;
778
779 if (c->ts.type == BT_DERIVED
780 && !c->attr.pointer && !c->attr.allocatable
781 && has_finalizer_component (c->ts.u.derived))
782 return true;
783 }
784 return false;
785 }
786
787
788 /* Call DEALLOCATE for the passed component if it is allocatable, if it is
789 neither allocatable nor a pointer but has a finalizer, call it. If it
790 is a nonpointer component with allocatable components or has finalizers, walk
791 them. Either of them is required; other nonallocatables and pointers aren't
792 handled gracefully.
793 Note: If the component is allocatable, the DEALLOCATE handling takes care
794 of calling the appropriate finalizers, coarray deregistering, and
795 deallocation of allocatable subcomponents. */
796
797 static void
798 finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
799 gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code)
800 {
801 gfc_expr *e;
802 gfc_ref *ref;
803
804 if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS
805 && !comp->attr.allocatable)
806 return;
807
808 if ((comp->ts.type == BT_DERIVED && comp->attr.pointer)
809 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
810 && CLASS_DATA (comp)->attr.pointer))
811 return;
812
813 if (comp->ts.type == BT_DERIVED && !comp->attr.allocatable
814 && (comp->ts.u.derived->f2k_derived == NULL
815 || comp->ts.u.derived->f2k_derived->finalizers == NULL)
816 && !has_finalizer_component (comp->ts.u.derived))
817 return;
818
819 e = gfc_copy_expr (expr);
820 if (!e->ref)
821 e->ref = ref = gfc_get_ref ();
822 else
823 {
824 for (ref = e->ref; ref->next; ref = ref->next)
825 ;
826 ref->next = gfc_get_ref ();
827 ref = ref->next;
828 }
829 ref->type = REF_COMPONENT;
830 ref->u.c.sym = derived;
831 ref->u.c.component = comp;
832 e->ts = comp->ts;
833
834 if (comp->attr.dimension || comp->attr.codimension
835 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
836 && (CLASS_DATA (comp)->attr.dimension
837 || CLASS_DATA (comp)->attr.codimension)))
838 {
839 ref->next = gfc_get_ref ();
840 ref->next->type = REF_ARRAY;
841 ref->next->u.ar.dimen = 0;
842 ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
843 : comp->as;
844 e->rank = ref->next->u.ar.as->rank;
845 ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
846 }
847
848 /* Call DEALLOCATE (comp, stat=ignore). */
849 if (comp->attr.allocatable
850 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
851 && CLASS_DATA (comp)->attr.allocatable))
852 {
853 gfc_code *dealloc, *block = NULL;
854
855 /* Add IF (fini_coarray). */
856 if (comp->attr.codimension
857 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
858 && CLASS_DATA (comp)->attr.allocatable))
859 {
860 block = gfc_get_code (EXEC_IF);
861 if (*code)
862 {
863 (*code)->next = block;
864 (*code) = (*code)->next;
865 }
866 else
867 (*code) = block;
868
869 block->block = gfc_get_code (EXEC_IF);
870 block = block->block;
871 block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
872 }
873
874 dealloc = gfc_get_code (EXEC_DEALLOCATE);
875
876 dealloc->ext.alloc.list = gfc_get_alloc ();
877 dealloc->ext.alloc.list->expr = e;
878 dealloc->expr1 = gfc_lval_expr_from_sym (stat);
879
880 if (block)
881 block->next = dealloc;
882 else if (*code)
883 {
884 (*code)->next = dealloc;
885 (*code) = (*code)->next;
886 }
887 else
888 (*code) = dealloc;
889 }
890 else if (comp->ts.type == BT_DERIVED
891 && comp->ts.u.derived->f2k_derived
892 && comp->ts.u.derived->f2k_derived->finalizers)
893 {
894 /* Call FINAL_WRAPPER (comp); */
895 gfc_code *final_wrap;
896 gfc_symbol *vtab;
897 gfc_component *c;
898
899 vtab = gfc_find_derived_vtab (comp->ts.u.derived);
900 for (c = vtab->ts.u.derived->components; c; c = c->next)
901 if (strcmp (c->name, "_final") == 0)
902 break;
903
904 gcc_assert (c);
905 final_wrap = gfc_get_code (EXEC_CALL);
906 final_wrap->symtree = c->initializer->symtree;
907 final_wrap->resolved_sym = c->initializer->symtree->n.sym;
908 final_wrap->ext.actual = gfc_get_actual_arglist ();
909 final_wrap->ext.actual->expr = e;
910
911 if (*code)
912 {
913 (*code)->next = final_wrap;
914 (*code) = (*code)->next;
915 }
916 else
917 (*code) = final_wrap;
918 }
919 else
920 {
921 gfc_component *c;
922
923 for (c = comp->ts.u.derived->components; c; c = c->next)
924 finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code);
925 gfc_free_expr (e);
926 }
927 }
928
929
930 /* Generate code equivalent to
931 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
932 + offset, c_ptr), ptr). */
933
934 static gfc_code *
935 finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
936 gfc_expr *offset, gfc_namespace *sub_ns)
937 {
938 gfc_code *block;
939 gfc_expr *expr, *expr2;
940
941 /* C_F_POINTER(). */
942 block = gfc_get_code (EXEC_CALL);
943 gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
944 block->resolved_sym = block->symtree->n.sym;
945 block->resolved_sym->attr.flavor = FL_PROCEDURE;
946 block->resolved_sym->attr.intrinsic = 1;
947 block->resolved_sym->attr.subroutine = 1;
948 block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
949 block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
950 block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
951 gfc_commit_symbol (block->resolved_sym);
952
953 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
954 block->ext.actual = gfc_get_actual_arglist ();
955 block->ext.actual->next = gfc_get_actual_arglist ();
956 block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
957 NULL, 0);
958 block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
959
960 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
961
962 /* TRANSFER's first argument: C_LOC (array). */
963 expr = gfc_get_expr ();
964 expr->expr_type = EXPR_FUNCTION;
965 gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
966 expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
967 expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
968 expr->symtree->n.sym->attr.intrinsic = 1;
969 expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
970 expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
971 expr->value.function.actual = gfc_get_actual_arglist ();
972 expr->value.function.actual->expr
973 = gfc_lval_expr_from_sym (array);
974 expr->symtree->n.sym->result = expr->symtree->n.sym;
975 gfc_commit_symbol (expr->symtree->n.sym);
976 expr->ts.type = BT_INTEGER;
977 expr->ts.kind = gfc_index_integer_kind;
978
979 /* TRANSFER. */
980 expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
981 gfc_current_locus, 3, expr,
982 gfc_get_int_expr (gfc_index_integer_kind,
983 NULL, 0), NULL);
984 expr2->ts.type = BT_INTEGER;
985 expr2->ts.kind = gfc_index_integer_kind;
986
987 /* <array addr> + <offset>. */
988 block->ext.actual->expr = gfc_get_expr ();
989 block->ext.actual->expr->expr_type = EXPR_OP;
990 block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
991 block->ext.actual->expr->value.op.op1 = expr2;
992 block->ext.actual->expr->value.op.op2 = offset;
993 block->ext.actual->expr->ts = expr->ts;
994
995 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
996 block->ext.actual->next = gfc_get_actual_arglist ();
997 block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
998 block->ext.actual->next->next = gfc_get_actual_arglist ();
999
1000 return block;
1001 }
1002
1003
1004 /* Calculates the offset to the (idx+1)th element of an array, taking the
1005 stride into account. It generates the code:
1006 offset = 0
1007 do idx2 = 1, rank
1008 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
1009 end do
1010 offset = offset * byte_stride. */
1011
1012 static gfc_code*
1013 finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
1014 gfc_symbol *strides, gfc_symbol *sizes,
1015 gfc_symbol *byte_stride, gfc_expr *rank,
1016 gfc_code *block, gfc_namespace *sub_ns)
1017 {
1018 gfc_iterator *iter;
1019 gfc_expr *expr, *expr2;
1020
1021 /* offset = 0. */
1022 block->next = gfc_get_code (EXEC_ASSIGN);
1023 block = block->next;
1024 block->expr1 = gfc_lval_expr_from_sym (offset);
1025 block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1026
1027 /* Create loop. */
1028 iter = gfc_get_iterator ();
1029 iter->var = gfc_lval_expr_from_sym (idx2);
1030 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1031 iter->end = gfc_copy_expr (rank);
1032 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1033 block->next = gfc_get_code (EXEC_DO);
1034 block = block->next;
1035 block->ext.iterator = iter;
1036 block->block = gfc_get_code (EXEC_DO);
1037
1038 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
1039 * strides(idx2). */
1040
1041 /* mod (idx, sizes(idx2)). */
1042 expr = gfc_lval_expr_from_sym (sizes);
1043 expr->ref = gfc_get_ref ();
1044 expr->ref->type = REF_ARRAY;
1045 expr->ref->u.ar.as = sizes->as;
1046 expr->ref->u.ar.type = AR_ELEMENT;
1047 expr->ref->u.ar.dimen = 1;
1048 expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1049 expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
1050
1051 expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
1052 gfc_current_locus, 2,
1053 gfc_lval_expr_from_sym (idx), expr);
1054 expr->ts = idx->ts;
1055
1056 /* (...) / sizes(idx2-1). */
1057 expr2 = gfc_get_expr ();
1058 expr2->expr_type = EXPR_OP;
1059 expr2->value.op.op = INTRINSIC_DIVIDE;
1060 expr2->value.op.op1 = expr;
1061 expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
1062 expr2->value.op.op2->ref = gfc_get_ref ();
1063 expr2->value.op.op2->ref->type = REF_ARRAY;
1064 expr2->value.op.op2->ref->u.ar.as = sizes->as;
1065 expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1066 expr2->value.op.op2->ref->u.ar.dimen = 1;
1067 expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1068 expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
1069 expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
1070 expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
1071 expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
1072 = gfc_lval_expr_from_sym (idx2);
1073 expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
1074 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1075 expr2->value.op.op2->ref->u.ar.start[0]->ts
1076 = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
1077 expr2->ts = idx->ts;
1078
1079 /* ... * strides(idx2). */
1080 expr = gfc_get_expr ();
1081 expr->expr_type = EXPR_OP;
1082 expr->value.op.op = INTRINSIC_TIMES;
1083 expr->value.op.op1 = expr2;
1084 expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
1085 expr->value.op.op2->ref = gfc_get_ref ();
1086 expr->value.op.op2->ref->type = REF_ARRAY;
1087 expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1088 expr->value.op.op2->ref->u.ar.dimen = 1;
1089 expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1090 expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
1091 expr->value.op.op2->ref->u.ar.as = strides->as;
1092 expr->ts = idx->ts;
1093
1094 /* offset = offset + ... */
1095 block->block->next = gfc_get_code (EXEC_ASSIGN);
1096 block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
1097 block->block->next->expr2 = gfc_get_expr ();
1098 block->block->next->expr2->expr_type = EXPR_OP;
1099 block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
1100 block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
1101 block->block->next->expr2->value.op.op2 = expr;
1102 block->block->next->expr2->ts = idx->ts;
1103
1104 /* After the loop: offset = offset * byte_stride. */
1105 block->next = gfc_get_code (EXEC_ASSIGN);
1106 block = block->next;
1107 block->expr1 = gfc_lval_expr_from_sym (offset);
1108 block->expr2 = gfc_get_expr ();
1109 block->expr2->expr_type = EXPR_OP;
1110 block->expr2->value.op.op = INTRINSIC_TIMES;
1111 block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
1112 block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
1113 block->expr2->ts = block->expr2->value.op.op1->ts;
1114 return block;
1115 }
1116
1117
1118 /* Insert code of the following form:
1119
1120 block
1121 integer(c_intptr_t) :: i
1122
1123 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1124 && (is_contiguous || !final_rank3->attr.contiguous
1125 || final_rank3->as->type != AS_ASSUMED_SHAPE))
1126 || 0 == STORAGE_SIZE (array)) then
1127 call final_rank3 (array)
1128 else
1129 block
1130 integer(c_intptr_t) :: offset, j
1131 type(t) :: tmp(shape (array))
1132
1133 do i = 0, size (array)-1
1134 offset = obtain_offset(i, strides, sizes, byte_stride)
1135 addr = transfer (c_loc (array), addr) + offset
1136 call c_f_pointer (transfer (addr, cptr), ptr)
1137
1138 addr = transfer (c_loc (tmp), addr)
1139 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
1140 call c_f_pointer (transfer (addr, cptr), ptr2)
1141 ptr2 = ptr
1142 end do
1143 call final_rank3 (tmp)
1144 end block
1145 end if
1146 block */
1147
1148 static void
1149 finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
1150 gfc_symbol *array, gfc_symbol *byte_stride,
1151 gfc_symbol *idx, gfc_symbol *ptr,
1152 gfc_symbol *nelem,
1153 gfc_symbol *strides, gfc_symbol *sizes,
1154 gfc_symbol *idx2, gfc_symbol *offset,
1155 gfc_symbol *is_contiguous, gfc_expr *rank,
1156 gfc_namespace *sub_ns)
1157 {
1158 gfc_symbol *tmp_array, *ptr2;
1159 gfc_expr *size_expr, *offset2, *expr;
1160 gfc_namespace *ns;
1161 gfc_iterator *iter;
1162 gfc_code *block2;
1163 int i;
1164
1165 block->next = gfc_get_code (EXEC_IF);
1166 block = block->next;
1167
1168 block->block = gfc_get_code (EXEC_IF);
1169 block = block->block;
1170
1171 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
1172 size_expr = gfc_get_expr ();
1173 size_expr->where = gfc_current_locus;
1174 size_expr->expr_type = EXPR_OP;
1175 size_expr->value.op.op = INTRINSIC_DIVIDE;
1176
1177 /* STORAGE_SIZE (array,kind=c_intptr_t). */
1178 size_expr->value.op.op1
1179 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
1180 "storage_size", gfc_current_locus, 2,
1181 gfc_lval_expr_from_sym (array),
1182 gfc_get_int_expr (gfc_index_integer_kind,
1183 NULL, 0));
1184
1185 /* NUMERIC_STORAGE_SIZE. */
1186 size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
1187 gfc_character_storage_size);
1188 size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
1189 size_expr->ts = size_expr->value.op.op1->ts;
1190
1191 /* IF condition: (stride == size_expr
1192 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
1193 || is_contiguous)
1194 || 0 == size_expr. */
1195 block->expr1 = gfc_get_expr ();
1196 block->expr1->ts.type = BT_LOGICAL;
1197 block->expr1->ts.kind = gfc_default_logical_kind;
1198 block->expr1->expr_type = EXPR_OP;
1199 block->expr1->where = gfc_current_locus;
1200
1201 block->expr1->value.op.op = INTRINSIC_OR;
1202
1203 /* byte_stride == size_expr */
1204 expr = gfc_get_expr ();
1205 expr->ts.type = BT_LOGICAL;
1206 expr->ts.kind = gfc_default_logical_kind;
1207 expr->expr_type = EXPR_OP;
1208 expr->where = gfc_current_locus;
1209 expr->value.op.op = INTRINSIC_EQ;
1210 expr->value.op.op1
1211 = gfc_lval_expr_from_sym (byte_stride);
1212 expr->value.op.op2 = size_expr;
1213
1214 /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
1215 add is_contiguous check. */
1216
1217 if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
1218 || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
1219 {
1220 gfc_expr *expr2;
1221 expr2 = gfc_get_expr ();
1222 expr2->ts.type = BT_LOGICAL;
1223 expr2->ts.kind = gfc_default_logical_kind;
1224 expr2->expr_type = EXPR_OP;
1225 expr2->where = gfc_current_locus;
1226 expr2->value.op.op = INTRINSIC_AND;
1227 expr2->value.op.op1 = expr;
1228 expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
1229 expr = expr2;
1230 }
1231
1232 block->expr1->value.op.op1 = expr;
1233
1234 /* 0 == size_expr */
1235 block->expr1->value.op.op2 = gfc_get_expr ();
1236 block->expr1->value.op.op2->ts.type = BT_LOGICAL;
1237 block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
1238 block->expr1->value.op.op2->expr_type = EXPR_OP;
1239 block->expr1->value.op.op2->where = gfc_current_locus;
1240 block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
1241 block->expr1->value.op.op2->value.op.op1 =
1242 gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1243 block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
1244
1245 /* IF body: call final subroutine. */
1246 block->next = gfc_get_code (EXEC_CALL);
1247 block->next->symtree = fini->proc_tree;
1248 block->next->resolved_sym = fini->proc_tree->n.sym;
1249 block->next->ext.actual = gfc_get_actual_arglist ();
1250 block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
1251
1252 /* ELSE. */
1253
1254 block->block = gfc_get_code (EXEC_IF);
1255 block = block->block;
1256
1257 /* BLOCK ... END BLOCK. */
1258 block->next = gfc_get_code (EXEC_BLOCK);
1259 block = block->next;
1260
1261 ns = gfc_build_block_ns (sub_ns);
1262 block->ext.block.ns = ns;
1263 block->ext.block.assoc = NULL;
1264
1265 gfc_get_symbol ("ptr2", ns, &ptr2);
1266 ptr2->ts.type = BT_DERIVED;
1267 ptr2->ts.u.derived = array->ts.u.derived;
1268 ptr2->attr.flavor = FL_VARIABLE;
1269 ptr2->attr.pointer = 1;
1270 ptr2->attr.artificial = 1;
1271 gfc_set_sym_referenced (ptr2);
1272 gfc_commit_symbol (ptr2);
1273
1274 gfc_get_symbol ("tmp_array", ns, &tmp_array);
1275 tmp_array->ts.type = BT_DERIVED;
1276 tmp_array->ts.u.derived = array->ts.u.derived;
1277 tmp_array->attr.flavor = FL_VARIABLE;
1278 tmp_array->attr.dimension = 1;
1279 tmp_array->attr.artificial = 1;
1280 tmp_array->as = gfc_get_array_spec();
1281 tmp_array->attr.intent = INTENT_INOUT;
1282 tmp_array->as->type = AS_EXPLICIT;
1283 tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
1284
1285 for (i = 0; i < tmp_array->as->rank; i++)
1286 {
1287 gfc_expr *shape_expr;
1288 tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
1289 NULL, 1);
1290 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
1291 shape_expr
1292 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
1293 gfc_current_locus, 3,
1294 gfc_lval_expr_from_sym (array),
1295 gfc_get_int_expr (gfc_default_integer_kind,
1296 NULL, i+1),
1297 gfc_get_int_expr (gfc_default_integer_kind,
1298 NULL,
1299 gfc_index_integer_kind));
1300 shape_expr->ts.kind = gfc_index_integer_kind;
1301 tmp_array->as->upper[i] = shape_expr;
1302 }
1303 gfc_set_sym_referenced (tmp_array);
1304 gfc_commit_symbol (tmp_array);
1305
1306 /* Create loop. */
1307 iter = gfc_get_iterator ();
1308 iter->var = gfc_lval_expr_from_sym (idx);
1309 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1310 iter->end = gfc_lval_expr_from_sym (nelem);
1311 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1312
1313 block = gfc_get_code (EXEC_DO);
1314 ns->code = block;
1315 block->ext.iterator = iter;
1316 block->block = gfc_get_code (EXEC_DO);
1317
1318 /* Offset calculation for the new array: idx * size of type (in bytes). */
1319 offset2 = gfc_get_expr ();
1320 offset2->expr_type = EXPR_OP;
1321 offset2->value.op.op = INTRINSIC_TIMES;
1322 offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
1323 offset2->value.op.op2 = gfc_copy_expr (size_expr);
1324 offset2->ts = byte_stride->ts;
1325
1326 /* Offset calculation of "array". */
1327 block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
1328 byte_stride, rank, block->block, sub_ns);
1329
1330 /* Create code for
1331 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1332 + idx * stride, c_ptr), ptr). */
1333 block2->next = finalization_scalarizer (array, ptr,
1334 gfc_lval_expr_from_sym (offset),
1335 sub_ns);
1336 block2 = block2->next;
1337 block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
1338 block2 = block2->next;
1339
1340 /* ptr2 = ptr. */
1341 block2->next = gfc_get_code (EXEC_ASSIGN);
1342 block2 = block2->next;
1343 block2->expr1 = gfc_lval_expr_from_sym (ptr2);
1344 block2->expr2 = gfc_lval_expr_from_sym (ptr);
1345
1346 /* Call now the user's final subroutine. */
1347 block->next = gfc_get_code (EXEC_CALL);
1348 block = block->next;
1349 block->symtree = fini->proc_tree;
1350 block->resolved_sym = fini->proc_tree->n.sym;
1351 block->ext.actual = gfc_get_actual_arglist ();
1352 block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
1353
1354 if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
1355 return;
1356
1357 /* Copy back. */
1358
1359 /* Loop. */
1360 iter = gfc_get_iterator ();
1361 iter->var = gfc_lval_expr_from_sym (idx);
1362 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1363 iter->end = gfc_lval_expr_from_sym (nelem);
1364 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1365
1366 block->next = gfc_get_code (EXEC_DO);
1367 block = block->next;
1368 block->ext.iterator = iter;
1369 block->block = gfc_get_code (EXEC_DO);
1370
1371 /* Offset calculation of "array". */
1372 block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
1373 byte_stride, rank, block->block, sub_ns);
1374
1375 /* Create code for
1376 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1377 + offset, c_ptr), ptr). */
1378 block2->next = finalization_scalarizer (array, ptr,
1379 gfc_lval_expr_from_sym (offset),
1380 sub_ns);
1381 block2 = block2->next;
1382 block2->next = finalization_scalarizer (tmp_array, ptr2,
1383 gfc_copy_expr (offset2), sub_ns);
1384 block2 = block2->next;
1385
1386 /* ptr = ptr2. */
1387 block2->next = gfc_get_code (EXEC_ASSIGN);
1388 block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
1389 block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
1390 }
1391
1392
1393 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
1394 derived type "derived". The function first calls the approriate FINAL
1395 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
1396 components (but not the inherited ones). Last, it calls the wrapper
1397 subroutine of the parent. The generated wrapper procedure takes as argument
1398 an assumed-rank array.
1399 If neither allocatable components nor FINAL subroutines exists, the vtab
1400 will contain a NULL pointer.
1401 The generated function has the form
1402 _final(assumed-rank array, stride, skip_corarray)
1403 where the array has to be contiguous (except of the lowest dimension). The
1404 stride (in bytes) is used to allow different sizes for ancestor types by
1405 skipping over the additionally added components in the scalarizer. If
1406 "fini_coarray" is false, coarray components are not finalized to allow for
1407 the correct semantic with intrinsic assignment. */
1408
1409 static void
1410 generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
1411 const char *tname, gfc_component *vtab_final)
1412 {
1413 gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
1414 gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
1415 gfc_component *comp;
1416 gfc_namespace *sub_ns;
1417 gfc_code *last_code, *block;
1418 char name[GFC_MAX_SYMBOL_LEN+1];
1419 bool finalizable_comp = false;
1420 bool expr_null_wrapper = false;
1421 gfc_expr *ancestor_wrapper = NULL, *rank;
1422 gfc_iterator *iter;
1423
1424 if (derived->attr.unlimited_polymorphic)
1425 {
1426 vtab_final->initializer = gfc_get_null_expr (NULL);
1427 return;
1428 }
1429
1430 /* Search for the ancestor's finalizers. */
1431 if (derived->attr.extension && derived->components
1432 && (!derived->components->ts.u.derived->attr.abstract
1433 || has_finalizer_component (derived)))
1434 {
1435 gfc_symbol *vtab;
1436 gfc_component *comp;
1437
1438 vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
1439 for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
1440 if (comp->name[0] == '_' && comp->name[1] == 'f')
1441 {
1442 ancestor_wrapper = comp->initializer;
1443 break;
1444 }
1445 }
1446
1447 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
1448 components: Return a NULL() expression; we defer this a bit to have have
1449 an interface declaration. */
1450 if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
1451 && !derived->attr.alloc_comp
1452 && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
1453 && !has_finalizer_component (derived))
1454 expr_null_wrapper = true;
1455 else
1456 /* Check whether there are new allocatable components. */
1457 for (comp = derived->components; comp; comp = comp->next)
1458 {
1459 if (comp == derived->components && derived->attr.extension
1460 && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
1461 continue;
1462
1463 if (comp->ts.type != BT_CLASS && !comp->attr.pointer
1464 && (comp->attr.allocatable
1465 || (comp->ts.type == BT_DERIVED
1466 && (comp->ts.u.derived->attr.alloc_comp
1467 || has_finalizer_component (comp->ts.u.derived)
1468 || (comp->ts.u.derived->f2k_derived
1469 && comp->ts.u.derived->f2k_derived->finalizers)))))
1470 finalizable_comp = true;
1471 else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
1472 && CLASS_DATA (comp)->attr.allocatable)
1473 finalizable_comp = true;
1474 }
1475
1476 /* If there is no new finalizer and no new allocatable, return with
1477 an expr to the ancestor's one. */
1478 if (!expr_null_wrapper && !finalizable_comp
1479 && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
1480 {
1481 gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
1482 && ancestor_wrapper->expr_type == EXPR_VARIABLE);
1483 vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
1484 vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
1485 return;
1486 }
1487
1488 /* We now create a wrapper, which does the following:
1489 1. Call the suitable finalization subroutine for this type
1490 2. Loop over all noninherited allocatable components and noninherited
1491 components with allocatable components and DEALLOCATE those; this will
1492 take care of finalizers, coarray deregistering and allocatable
1493 nested components.
1494 3. Call the ancestor's finalizer. */
1495
1496 /* Declare the wrapper function; it takes an assumed-rank array
1497 and a VALUE logical as arguments. */
1498
1499 /* Set up the namespace. */
1500 sub_ns = gfc_get_namespace (ns, 0);
1501 sub_ns->sibling = ns->contained;
1502 if (!expr_null_wrapper)
1503 ns->contained = sub_ns;
1504 sub_ns->resolved = 1;
1505
1506 /* Set up the procedure symbol. */
1507 sprintf (name, "__final_%s", tname);
1508 gfc_get_symbol (name, sub_ns, &final);
1509 sub_ns->proc_name = final;
1510 final->attr.flavor = FL_PROCEDURE;
1511 final->attr.function = 1;
1512 final->attr.pure = 0;
1513 final->result = final;
1514 final->ts.type = BT_INTEGER;
1515 final->ts.kind = 4;
1516 final->attr.artificial = 1;
1517 final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
1518 if (ns->proc_name->attr.flavor == FL_MODULE)
1519 final->module = ns->proc_name->name;
1520 gfc_set_sym_referenced (final);
1521 gfc_commit_symbol (final);
1522
1523 /* Set up formal argument. */
1524 gfc_get_symbol ("array", sub_ns, &array);
1525 array->ts.type = BT_DERIVED;
1526 array->ts.u.derived = derived;
1527 array->attr.flavor = FL_VARIABLE;
1528 array->attr.dummy = 1;
1529 array->attr.contiguous = 1;
1530 array->attr.dimension = 1;
1531 array->attr.artificial = 1;
1532 array->as = gfc_get_array_spec();
1533 array->as->type = AS_ASSUMED_RANK;
1534 array->as->rank = -1;
1535 array->attr.intent = INTENT_INOUT;
1536 gfc_set_sym_referenced (array);
1537 final->formal = gfc_get_formal_arglist ();
1538 final->formal->sym = array;
1539 gfc_commit_symbol (array);
1540
1541 /* Set up formal argument. */
1542 gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
1543 byte_stride->ts.type = BT_INTEGER;
1544 byte_stride->ts.kind = gfc_index_integer_kind;
1545 byte_stride->attr.flavor = FL_VARIABLE;
1546 byte_stride->attr.dummy = 1;
1547 byte_stride->attr.value = 1;
1548 byte_stride->attr.artificial = 1;
1549 gfc_set_sym_referenced (byte_stride);
1550 final->formal->next = gfc_get_formal_arglist ();
1551 final->formal->next->sym = byte_stride;
1552 gfc_commit_symbol (byte_stride);
1553
1554 /* Set up formal argument. */
1555 gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
1556 fini_coarray->ts.type = BT_LOGICAL;
1557 fini_coarray->ts.kind = 1;
1558 fini_coarray->attr.flavor = FL_VARIABLE;
1559 fini_coarray->attr.dummy = 1;
1560 fini_coarray->attr.value = 1;
1561 fini_coarray->attr.artificial = 1;
1562 gfc_set_sym_referenced (fini_coarray);
1563 final->formal->next->next = gfc_get_formal_arglist ();
1564 final->formal->next->next->sym = fini_coarray;
1565 gfc_commit_symbol (fini_coarray);
1566
1567 /* Return with a NULL() expression but with an interface which has
1568 the formal arguments. */
1569 if (expr_null_wrapper)
1570 {
1571 vtab_final->initializer = gfc_get_null_expr (NULL);
1572 vtab_final->ts.interface = final;
1573 return;
1574 }
1575
1576 /* Local variables. */
1577
1578 gfc_get_symbol ("idx", sub_ns, &idx);
1579 idx->ts.type = BT_INTEGER;
1580 idx->ts.kind = gfc_index_integer_kind;
1581 idx->attr.flavor = FL_VARIABLE;
1582 idx->attr.artificial = 1;
1583 gfc_set_sym_referenced (idx);
1584 gfc_commit_symbol (idx);
1585
1586 gfc_get_symbol ("idx2", sub_ns, &idx2);
1587 idx2->ts.type = BT_INTEGER;
1588 idx2->ts.kind = gfc_index_integer_kind;
1589 idx2->attr.flavor = FL_VARIABLE;
1590 idx2->attr.artificial = 1;
1591 gfc_set_sym_referenced (idx2);
1592 gfc_commit_symbol (idx2);
1593
1594 gfc_get_symbol ("offset", sub_ns, &offset);
1595 offset->ts.type = BT_INTEGER;
1596 offset->ts.kind = gfc_index_integer_kind;
1597 offset->attr.flavor = FL_VARIABLE;
1598 offset->attr.artificial = 1;
1599 gfc_set_sym_referenced (offset);
1600 gfc_commit_symbol (offset);
1601
1602 /* Create RANK expression. */
1603 rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
1604 gfc_current_locus, 1,
1605 gfc_lval_expr_from_sym (array));
1606 if (rank->ts.kind != idx->ts.kind)
1607 gfc_convert_type_warn (rank, &idx->ts, 2, 0);
1608
1609 /* Create is_contiguous variable. */
1610 gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
1611 is_contiguous->ts.type = BT_LOGICAL;
1612 is_contiguous->ts.kind = gfc_default_logical_kind;
1613 is_contiguous->attr.flavor = FL_VARIABLE;
1614 is_contiguous->attr.artificial = 1;
1615 gfc_set_sym_referenced (is_contiguous);
1616 gfc_commit_symbol (is_contiguous);
1617
1618 /* Create "sizes(0..rank)" variable, which contains the multiplied
1619 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
1620 sizes(2) = sizes(1) * extent(dim=2) etc. */
1621 gfc_get_symbol ("sizes", sub_ns, &sizes);
1622 sizes->ts.type = BT_INTEGER;
1623 sizes->ts.kind = gfc_index_integer_kind;
1624 sizes->attr.flavor = FL_VARIABLE;
1625 sizes->attr.dimension = 1;
1626 sizes->attr.artificial = 1;
1627 sizes->as = gfc_get_array_spec();
1628 sizes->attr.intent = INTENT_INOUT;
1629 sizes->as->type = AS_EXPLICIT;
1630 sizes->as->rank = 1;
1631 sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1632 sizes->as->upper[0] = gfc_copy_expr (rank);
1633 gfc_set_sym_referenced (sizes);
1634 gfc_commit_symbol (sizes);
1635
1636 /* Create "strides(1..rank)" variable, which contains the strides per
1637 dimension. */
1638 gfc_get_symbol ("strides", sub_ns, &strides);
1639 strides->ts.type = BT_INTEGER;
1640 strides->ts.kind = gfc_index_integer_kind;
1641 strides->attr.flavor = FL_VARIABLE;
1642 strides->attr.dimension = 1;
1643 strides->attr.artificial = 1;
1644 strides->as = gfc_get_array_spec();
1645 strides->attr.intent = INTENT_INOUT;
1646 strides->as->type = AS_EXPLICIT;
1647 strides->as->rank = 1;
1648 strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1649 strides->as->upper[0] = gfc_copy_expr (rank);
1650 gfc_set_sym_referenced (strides);
1651 gfc_commit_symbol (strides);
1652
1653
1654 /* Set return value to 0. */
1655 last_code = gfc_get_code (EXEC_ASSIGN);
1656 last_code->expr1 = gfc_lval_expr_from_sym (final);
1657 last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
1658 sub_ns->code = last_code;
1659
1660 /* Set: is_contiguous = .true. */
1661 last_code->next = gfc_get_code (EXEC_ASSIGN);
1662 last_code = last_code->next;
1663 last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
1664 last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
1665 &gfc_current_locus, true);
1666
1667 /* Set: sizes(0) = 1. */
1668 last_code->next = gfc_get_code (EXEC_ASSIGN);
1669 last_code = last_code->next;
1670 last_code->expr1 = gfc_lval_expr_from_sym (sizes);
1671 last_code->expr1->ref = gfc_get_ref ();
1672 last_code->expr1->ref->type = REF_ARRAY;
1673 last_code->expr1->ref->u.ar.type = AR_ELEMENT;
1674 last_code->expr1->ref->u.ar.dimen = 1;
1675 last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1676 last_code->expr1->ref->u.ar.start[0]
1677 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1678 last_code->expr1->ref->u.ar.as = sizes->as;
1679 last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1680
1681 /* Create:
1682 DO idx = 1, rank
1683 strides(idx) = _F._stride (array, dim=idx)
1684 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
1685 if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
1686 END DO. */
1687
1688 /* Create loop. */
1689 iter = gfc_get_iterator ();
1690 iter->var = gfc_lval_expr_from_sym (idx);
1691 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1692 iter->end = gfc_copy_expr (rank);
1693 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1694 last_code->next = gfc_get_code (EXEC_DO);
1695 last_code = last_code->next;
1696 last_code->ext.iterator = iter;
1697 last_code->block = gfc_get_code (EXEC_DO);
1698
1699 /* strides(idx) = _F._stride(array,dim=idx). */
1700 last_code->block->next = gfc_get_code (EXEC_ASSIGN);
1701 block = last_code->block->next;
1702
1703 block->expr1 = gfc_lval_expr_from_sym (strides);
1704 block->expr1->ref = gfc_get_ref ();
1705 block->expr1->ref->type = REF_ARRAY;
1706 block->expr1->ref->u.ar.type = AR_ELEMENT;
1707 block->expr1->ref->u.ar.dimen = 1;
1708 block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1709 block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
1710 block->expr1->ref->u.ar.as = strides->as;
1711
1712 block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
1713 gfc_current_locus, 2,
1714 gfc_lval_expr_from_sym (array),
1715 gfc_lval_expr_from_sym (idx));
1716
1717 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
1718 block->next = gfc_get_code (EXEC_ASSIGN);
1719 block = block->next;
1720
1721 /* sizes(idx) = ... */
1722 block->expr1 = gfc_lval_expr_from_sym (sizes);
1723 block->expr1->ref = gfc_get_ref ();
1724 block->expr1->ref->type = REF_ARRAY;
1725 block->expr1->ref->u.ar.type = AR_ELEMENT;
1726 block->expr1->ref->u.ar.dimen = 1;
1727 block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1728 block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
1729 block->expr1->ref->u.ar.as = sizes->as;
1730
1731 block->expr2 = gfc_get_expr ();
1732 block->expr2->expr_type = EXPR_OP;
1733 block->expr2->value.op.op = INTRINSIC_TIMES;
1734
1735 /* sizes(idx-1). */
1736 block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
1737 block->expr2->value.op.op1->ref = gfc_get_ref ();
1738 block->expr2->value.op.op1->ref->type = REF_ARRAY;
1739 block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
1740 block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
1741 block->expr2->value.op.op1->ref->u.ar.dimen = 1;
1742 block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1743 block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
1744 block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
1745 block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
1746 block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
1747 = gfc_lval_expr_from_sym (idx);
1748 block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
1749 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1750 block->expr2->value.op.op1->ref->u.ar.start[0]->ts
1751 = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
1752
1753 /* size(array, dim=idx, kind=index_kind). */
1754 block->expr2->value.op.op2
1755 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
1756 gfc_current_locus, 3,
1757 gfc_lval_expr_from_sym (array),
1758 gfc_lval_expr_from_sym (idx),
1759 gfc_get_int_expr (gfc_index_integer_kind,
1760 NULL,
1761 gfc_index_integer_kind));
1762 block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
1763 block->expr2->ts = idx->ts;
1764
1765 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
1766 block->next = gfc_get_code (EXEC_IF);
1767 block = block->next;
1768
1769 block->block = gfc_get_code (EXEC_IF);
1770 block = block->block;
1771
1772 /* if condition: strides(idx) /= sizes(idx-1). */
1773 block->expr1 = gfc_get_expr ();
1774 block->expr1->ts.type = BT_LOGICAL;
1775 block->expr1->ts.kind = gfc_default_logical_kind;
1776 block->expr1->expr_type = EXPR_OP;
1777 block->expr1->where = gfc_current_locus;
1778 block->expr1->value.op.op = INTRINSIC_NE;
1779
1780 block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
1781 block->expr1->value.op.op1->ref = gfc_get_ref ();
1782 block->expr1->value.op.op1->ref->type = REF_ARRAY;
1783 block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
1784 block->expr1->value.op.op1->ref->u.ar.dimen = 1;
1785 block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1786 block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
1787 block->expr1->value.op.op1->ref->u.ar.as = strides->as;
1788
1789 block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
1790 block->expr1->value.op.op2->ref = gfc_get_ref ();
1791 block->expr1->value.op.op2->ref->type = REF_ARRAY;
1792 block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
1793 block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
1794 block->expr1->value.op.op2->ref->u.ar.dimen = 1;
1795 block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1796 block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
1797 block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
1798 block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
1799 block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
1800 = gfc_lval_expr_from_sym (idx);
1801 block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
1802 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1803 block->expr1->value.op.op2->ref->u.ar.start[0]->ts
1804 = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
1805
1806 /* if body: is_contiguous = .false. */
1807 block->next = gfc_get_code (EXEC_ASSIGN);
1808 block = block->next;
1809 block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
1810 block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
1811 &gfc_current_locus, false);
1812
1813 /* Obtain the size (number of elements) of "array" MINUS ONE,
1814 which is used in the scalarization. */
1815 gfc_get_symbol ("nelem", sub_ns, &nelem);
1816 nelem->ts.type = BT_INTEGER;
1817 nelem->ts.kind = gfc_index_integer_kind;
1818 nelem->attr.flavor = FL_VARIABLE;
1819 nelem->attr.artificial = 1;
1820 gfc_set_sym_referenced (nelem);
1821 gfc_commit_symbol (nelem);
1822
1823 /* nelem = sizes (rank) - 1. */
1824 last_code->next = gfc_get_code (EXEC_ASSIGN);
1825 last_code = last_code->next;
1826
1827 last_code->expr1 = gfc_lval_expr_from_sym (nelem);
1828
1829 last_code->expr2 = gfc_get_expr ();
1830 last_code->expr2->expr_type = EXPR_OP;
1831 last_code->expr2->value.op.op = INTRINSIC_MINUS;
1832 last_code->expr2->value.op.op2
1833 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1834 last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
1835
1836 last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
1837 last_code->expr2->value.op.op1->ref = gfc_get_ref ();
1838 last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
1839 last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
1840 last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
1841 last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
1842 last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
1843 last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
1844
1845 /* Call final subroutines. We now generate code like:
1846 use iso_c_binding
1847 integer, pointer :: ptr
1848 type(c_ptr) :: cptr
1849 integer(c_intptr_t) :: i, addr
1850
1851 select case (rank (array))
1852 case (3)
1853 ! If needed, the array is packed
1854 call final_rank3 (array)
1855 case default:
1856 do i = 0, size (array)-1
1857 addr = transfer (c_loc (array), addr) + i * stride
1858 call c_f_pointer (transfer (addr, cptr), ptr)
1859 call elemental_final (ptr)
1860 end do
1861 end select */
1862
1863 if (derived->f2k_derived && derived->f2k_derived->finalizers)
1864 {
1865 gfc_finalizer *fini, *fini_elem = NULL;
1866
1867 gfc_get_symbol ("ptr", sub_ns, &ptr);
1868 ptr->ts.type = BT_DERIVED;
1869 ptr->ts.u.derived = derived;
1870 ptr->attr.flavor = FL_VARIABLE;
1871 ptr->attr.pointer = 1;
1872 ptr->attr.artificial = 1;
1873 gfc_set_sym_referenced (ptr);
1874 gfc_commit_symbol (ptr);
1875
1876 /* SELECT CASE (RANK (array)). */
1877 last_code->next = gfc_get_code (EXEC_SELECT);
1878 last_code = last_code->next;
1879 last_code->expr1 = gfc_copy_expr (rank);
1880 block = NULL;
1881
1882 for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
1883 {
1884 if (!fini->proc_tree)
1885 fini->proc_tree = gfc_find_sym_in_symtree (fini->proc_sym);
1886 if (fini->proc_tree->n.sym->attr.elemental)
1887 {
1888 fini_elem = fini;
1889 continue;
1890 }
1891
1892 /* CASE (fini_rank). */
1893 if (block)
1894 {
1895 block->block = gfc_get_code (EXEC_SELECT);
1896 block = block->block;
1897 }
1898 else
1899 {
1900 block = gfc_get_code (EXEC_SELECT);
1901 last_code->block = block;
1902 }
1903 block->ext.block.case_list = gfc_get_case ();
1904 block->ext.block.case_list->where = gfc_current_locus;
1905 if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
1906 block->ext.block.case_list->low
1907 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1908 fini->proc_tree->n.sym->formal->sym->as->rank);
1909 else
1910 block->ext.block.case_list->low
1911 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1912 block->ext.block.case_list->high
1913 = gfc_copy_expr (block->ext.block.case_list->low);
1914
1915 /* CALL fini_rank (array) - possibly with packing. */
1916 if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
1917 finalizer_insert_packed_call (block, fini, array, byte_stride,
1918 idx, ptr, nelem, strides,
1919 sizes, idx2, offset, is_contiguous,
1920 rank, sub_ns);
1921 else
1922 {
1923 block->next = gfc_get_code (EXEC_CALL);
1924 block->next->symtree = fini->proc_tree;
1925 block->next->resolved_sym = fini->proc_tree->n.sym;
1926 block->next->ext.actual = gfc_get_actual_arglist ();
1927 block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
1928 }
1929 }
1930
1931 /* Elemental call - scalarized. */
1932 if (fini_elem)
1933 {
1934 /* CASE DEFAULT. */
1935 if (block)
1936 {
1937 block->block = gfc_get_code (EXEC_SELECT);
1938 block = block->block;
1939 }
1940 else
1941 {
1942 block = gfc_get_code (EXEC_SELECT);
1943 last_code->block = block;
1944 }
1945 block->ext.block.case_list = gfc_get_case ();
1946
1947 /* Create loop. */
1948 iter = gfc_get_iterator ();
1949 iter->var = gfc_lval_expr_from_sym (idx);
1950 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
1951 iter->end = gfc_lval_expr_from_sym (nelem);
1952 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1953 block->next = gfc_get_code (EXEC_DO);
1954 block = block->next;
1955 block->ext.iterator = iter;
1956 block->block = gfc_get_code (EXEC_DO);
1957
1958 /* Offset calculation. */
1959 block = finalization_get_offset (idx, idx2, offset, strides, sizes,
1960 byte_stride, rank, block->block,
1961 sub_ns);
1962
1963 /* Create code for
1964 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
1965 + offset, c_ptr), ptr). */
1966 block->next
1967 = finalization_scalarizer (array, ptr,
1968 gfc_lval_expr_from_sym (offset),
1969 sub_ns);
1970 block = block->next;
1971
1972 /* CALL final_elemental (array). */
1973 block->next = gfc_get_code (EXEC_CALL);
1974 block = block->next;
1975 block->symtree = fini_elem->proc_tree;
1976 block->resolved_sym = fini_elem->proc_sym;
1977 block->ext.actual = gfc_get_actual_arglist ();
1978 block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
1979 }
1980 }
1981
1982 /* Finalize and deallocate allocatable components. The same manual
1983 scalarization is used as above. */
1984
1985 if (finalizable_comp)
1986 {
1987 gfc_symbol *stat;
1988 gfc_code *block = NULL;
1989
1990 if (!ptr)
1991 {
1992 gfc_get_symbol ("ptr", sub_ns, &ptr);
1993 ptr->ts.type = BT_DERIVED;
1994 ptr->ts.u.derived = derived;
1995 ptr->attr.flavor = FL_VARIABLE;
1996 ptr->attr.pointer = 1;
1997 ptr->attr.artificial = 1;
1998 gfc_set_sym_referenced (ptr);
1999 gfc_commit_symbol (ptr);
2000 }
2001
2002 gfc_get_symbol ("ignore", sub_ns, &stat);
2003 stat->attr.flavor = FL_VARIABLE;
2004 stat->attr.artificial = 1;
2005 stat->ts.type = BT_INTEGER;
2006 stat->ts.kind = gfc_default_integer_kind;
2007 gfc_set_sym_referenced (stat);
2008 gfc_commit_symbol (stat);
2009
2010 /* Create loop. */
2011 iter = gfc_get_iterator ();
2012 iter->var = gfc_lval_expr_from_sym (idx);
2013 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
2014 iter->end = gfc_lval_expr_from_sym (nelem);
2015 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
2016 last_code->next = gfc_get_code (EXEC_DO);
2017 last_code = last_code->next;
2018 last_code->ext.iterator = iter;
2019 last_code->block = gfc_get_code (EXEC_DO);
2020
2021 /* Offset calculation. */
2022 block = finalization_get_offset (idx, idx2, offset, strides, sizes,
2023 byte_stride, rank, last_code->block,
2024 sub_ns);
2025
2026 /* Create code for
2027 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
2028 + idx * stride, c_ptr), ptr). */
2029 block->next = finalization_scalarizer (array, ptr,
2030 gfc_lval_expr_from_sym(offset),
2031 sub_ns);
2032 block = block->next;
2033
2034 for (comp = derived->components; comp; comp = comp->next)
2035 {
2036 if (comp == derived->components && derived->attr.extension
2037 && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
2038 continue;
2039
2040 finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
2041 stat, fini_coarray, &block);
2042 if (!last_code->block->next)
2043 last_code->block->next = block;
2044 }
2045
2046 }
2047
2048 /* Call the finalizer of the ancestor. */
2049 if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
2050 {
2051 last_code->next = gfc_get_code (EXEC_CALL);
2052 last_code = last_code->next;
2053 last_code->symtree = ancestor_wrapper->symtree;
2054 last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
2055
2056 last_code->ext.actual = gfc_get_actual_arglist ();
2057 last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
2058 last_code->ext.actual->next = gfc_get_actual_arglist ();
2059 last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
2060 last_code->ext.actual->next->next = gfc_get_actual_arglist ();
2061 last_code->ext.actual->next->next->expr
2062 = gfc_lval_expr_from_sym (fini_coarray);
2063 }
2064
2065 gfc_free_expr (rank);
2066 vtab_final->initializer = gfc_lval_expr_from_sym (final);
2067 vtab_final->ts.interface = final;
2068 }
2069
2070
2071 /* Add procedure pointers for all type-bound procedures to a vtab. */
2072
2073 static void
2074 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
2075 {
2076 gfc_symbol* super_type;
2077
2078 super_type = gfc_get_derived_super_type (derived);
2079
2080 if (super_type && (super_type != derived))
2081 {
2082 /* Make sure that the PPCs appear in the same order as in the parent. */
2083 copy_vtab_proc_comps (super_type, vtype);
2084 /* Only needed to get the PPC initializers right. */
2085 add_procs_to_declared_vtab (super_type, vtype);
2086 }
2087
2088 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
2089 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
2090
2091 if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
2092 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
2093 }
2094
2095
2096 /* Find or generate the symbol for a derived type's vtab. */
2097
2098 gfc_symbol *
2099 gfc_find_derived_vtab (gfc_symbol *derived)
2100 {
2101 gfc_namespace *ns;
2102 gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
2103 gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
2104
2105 /* Find the top-level namespace. */
2106 for (ns = gfc_current_ns; ns; ns = ns->parent)
2107 if (!ns->parent)
2108 break;
2109
2110 /* If the type is a class container, use the underlying derived type. */
2111 if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
2112 derived = gfc_get_derived_super_type (derived);
2113
2114 if (ns)
2115 {
2116 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
2117
2118 get_unique_hashed_string (tname, derived);
2119 sprintf (name, "__vtab_%s", tname);
2120
2121 /* Look for the vtab symbol in various namespaces. */
2122 gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
2123 if (vtab == NULL)
2124 gfc_find_symbol (name, ns, 0, &vtab);
2125 if (vtab == NULL)
2126 gfc_find_symbol (name, derived->ns, 0, &vtab);
2127
2128 if (vtab == NULL)
2129 {
2130 gfc_get_symbol (name, ns, &vtab);
2131 vtab->ts.type = BT_DERIVED;
2132 if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
2133 &gfc_current_locus))
2134 goto cleanup;
2135 vtab->attr.target = 1;
2136 vtab->attr.save = SAVE_IMPLICIT;
2137 vtab->attr.vtab = 1;
2138 vtab->attr.access = ACCESS_PUBLIC;
2139 gfc_set_sym_referenced (vtab);
2140 sprintf (name, "__vtype_%s", tname);
2141
2142 gfc_find_symbol (name, ns, 0, &vtype);
2143 if (vtype == NULL)
2144 {
2145 gfc_component *c;
2146 gfc_symbol *parent = NULL, *parent_vtab = NULL;
2147
2148 gfc_get_symbol (name, ns, &vtype);
2149 if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
2150 &gfc_current_locus))
2151 goto cleanup;
2152 vtype->attr.access = ACCESS_PUBLIC;
2153 vtype->attr.vtype = 1;
2154 gfc_set_sym_referenced (vtype);
2155
2156 /* Add component '_hash'. */
2157 if (!gfc_add_component (vtype, "_hash", &c))
2158 goto cleanup;
2159 c->ts.type = BT_INTEGER;
2160 c->ts.kind = 4;
2161 c->attr.access = ACCESS_PRIVATE;
2162 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2163 NULL, derived->hash_value);
2164
2165 /* Add component '_size'. */
2166 if (!gfc_add_component (vtype, "_size", &c))
2167 goto cleanup;
2168 c->ts.type = BT_INTEGER;
2169 c->ts.kind = 4;
2170 c->attr.access = ACCESS_PRIVATE;
2171 /* Remember the derived type in ts.u.derived,
2172 so that the correct initializer can be set later on
2173 (in gfc_conv_structure). */
2174 c->ts.u.derived = derived;
2175 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2176 NULL, 0);
2177
2178 /* Add component _extends. */
2179 if (!gfc_add_component (vtype, "_extends", &c))
2180 goto cleanup;
2181 c->attr.pointer = 1;
2182 c->attr.access = ACCESS_PRIVATE;
2183 if (!derived->attr.unlimited_polymorphic)
2184 parent = gfc_get_derived_super_type (derived);
2185 else
2186 parent = NULL;
2187
2188 if (parent)
2189 {
2190 parent_vtab = gfc_find_derived_vtab (parent);
2191 c->ts.type = BT_DERIVED;
2192 c->ts.u.derived = parent_vtab->ts.u.derived;
2193 c->initializer = gfc_get_expr ();
2194 c->initializer->expr_type = EXPR_VARIABLE;
2195 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
2196 0, &c->initializer->symtree);
2197 }
2198 else
2199 {
2200 c->ts.type = BT_DERIVED;
2201 c->ts.u.derived = vtype;
2202 c->initializer = gfc_get_null_expr (NULL);
2203 }
2204
2205 if (!derived->attr.unlimited_polymorphic
2206 && derived->components == NULL
2207 && !derived->attr.zero_comp)
2208 {
2209 /* At this point an error must have occurred.
2210 Prevent further errors on the vtype components. */
2211 found_sym = vtab;
2212 goto have_vtype;
2213 }
2214
2215 /* Add component _def_init. */
2216 if (!gfc_add_component (vtype, "_def_init", &c))
2217 goto cleanup;
2218 c->attr.pointer = 1;
2219 c->attr.artificial = 1;
2220 c->attr.access = ACCESS_PRIVATE;
2221 c->ts.type = BT_DERIVED;
2222 c->ts.u.derived = derived;
2223 if (derived->attr.unlimited_polymorphic
2224 || derived->attr.abstract)
2225 c->initializer = gfc_get_null_expr (NULL);
2226 else
2227 {
2228 /* Construct default initialization variable. */
2229 sprintf (name, "__def_init_%s", tname);
2230 gfc_get_symbol (name, ns, &def_init);
2231 def_init->attr.target = 1;
2232 def_init->attr.artificial = 1;
2233 def_init->attr.save = SAVE_IMPLICIT;
2234 def_init->attr.access = ACCESS_PUBLIC;
2235 def_init->attr.flavor = FL_VARIABLE;
2236 gfc_set_sym_referenced (def_init);
2237 def_init->ts.type = BT_DERIVED;
2238 def_init->ts.u.derived = derived;
2239 def_init->value = gfc_default_initializer (&def_init->ts);
2240
2241 c->initializer = gfc_lval_expr_from_sym (def_init);
2242 }
2243
2244 /* Add component _copy. */
2245 if (!gfc_add_component (vtype, "_copy", &c))
2246 goto cleanup;
2247 c->attr.proc_pointer = 1;
2248 c->attr.access = ACCESS_PRIVATE;
2249 c->tb = XCNEW (gfc_typebound_proc);
2250 c->tb->ppc = 1;
2251 if (derived->attr.unlimited_polymorphic
2252 || derived->attr.abstract)
2253 c->initializer = gfc_get_null_expr (NULL);
2254 else
2255 {
2256 /* Set up namespace. */
2257 gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2258 sub_ns->sibling = ns->contained;
2259 ns->contained = sub_ns;
2260 sub_ns->resolved = 1;
2261 /* Set up procedure symbol. */
2262 sprintf (name, "__copy_%s", tname);
2263 gfc_get_symbol (name, sub_ns, &copy);
2264 sub_ns->proc_name = copy;
2265 copy->attr.flavor = FL_PROCEDURE;
2266 copy->attr.subroutine = 1;
2267 copy->attr.pure = 1;
2268 copy->attr.artificial = 1;
2269 copy->attr.if_source = IFSRC_DECL;
2270 /* This is elemental so that arrays are automatically
2271 treated correctly by the scalarizer. */
2272 copy->attr.elemental = 1;
2273 if (ns->proc_name->attr.flavor == FL_MODULE)
2274 copy->module = ns->proc_name->name;
2275 gfc_set_sym_referenced (copy);
2276 /* Set up formal arguments. */
2277 gfc_get_symbol ("src", sub_ns, &src);
2278 src->ts.type = BT_DERIVED;
2279 src->ts.u.derived = derived;
2280 src->attr.flavor = FL_VARIABLE;
2281 src->attr.dummy = 1;
2282 src->attr.artificial = 1;
2283 src->attr.intent = INTENT_IN;
2284 gfc_set_sym_referenced (src);
2285 copy->formal = gfc_get_formal_arglist ();
2286 copy->formal->sym = src;
2287 gfc_get_symbol ("dst", sub_ns, &dst);
2288 dst->ts.type = BT_DERIVED;
2289 dst->ts.u.derived = derived;
2290 dst->attr.flavor = FL_VARIABLE;
2291 dst->attr.dummy = 1;
2292 dst->attr.artificial = 1;
2293 dst->attr.intent = INTENT_INOUT;
2294 gfc_set_sym_referenced (dst);
2295 copy->formal->next = gfc_get_formal_arglist ();
2296 copy->formal->next->sym = dst;
2297 /* Set up code. */
2298 sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
2299 sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
2300 sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
2301 /* Set initializer. */
2302 c->initializer = gfc_lval_expr_from_sym (copy);
2303 c->ts.interface = copy;
2304 }
2305
2306 /* Add component _final, which contains a procedure pointer to
2307 a wrapper which handles both the freeing of allocatable
2308 components and the calls to finalization subroutines.
2309 Note: The actual wrapper function can only be generated
2310 at resolution time. */
2311 if (!gfc_add_component (vtype, "_final", &c))
2312 goto cleanup;
2313 c->attr.proc_pointer = 1;
2314 c->attr.access = ACCESS_PRIVATE;
2315 c->tb = XCNEW (gfc_typebound_proc);
2316 c->tb->ppc = 1;
2317 generate_finalization_wrapper (derived, ns, tname, c);
2318
2319 /* Add procedure pointers for type-bound procedures. */
2320 if (!derived->attr.unlimited_polymorphic)
2321 add_procs_to_declared_vtab (derived, vtype);
2322 }
2323
2324 have_vtype:
2325 vtab->ts.u.derived = vtype;
2326 vtab->value = gfc_default_initializer (&vtab->ts);
2327 }
2328 }
2329
2330 found_sym = vtab;
2331
2332 cleanup:
2333 /* It is unexpected to have some symbols added at resolution or code
2334 generation time. We commit the changes in order to keep a clean state. */
2335 if (found_sym)
2336 {
2337 gfc_commit_symbol (vtab);
2338 if (vtype)
2339 gfc_commit_symbol (vtype);
2340 if (def_init)
2341 gfc_commit_symbol (def_init);
2342 if (copy)
2343 gfc_commit_symbol (copy);
2344 if (src)
2345 gfc_commit_symbol (src);
2346 if (dst)
2347 gfc_commit_symbol (dst);
2348 }
2349 else
2350 gfc_undo_symbols ();
2351
2352 return found_sym;
2353 }
2354
2355
2356 /* Check if a derived type is finalizable. That is the case if it
2357 (1) has a FINAL subroutine or
2358 (2) has a nonpointer nonallocatable component of finalizable type.
2359 If it is finalizable, return an expression containing the
2360 finalization wrapper. */
2361
2362 bool
2363 gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
2364 {
2365 gfc_symbol *vtab;
2366 gfc_component *c;
2367
2368 /* (1) Check for FINAL subroutines. */
2369 if (derived->f2k_derived && derived->f2k_derived->finalizers)
2370 goto yes;
2371
2372 /* (2) Check for components of finalizable type. */
2373 for (c = derived->components; c; c = c->next)
2374 if (c->ts.type == BT_DERIVED
2375 && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
2376 && gfc_is_finalizable (c->ts.u.derived, NULL))
2377 goto yes;
2378
2379 return false;
2380
2381 yes:
2382 /* Make sure vtab is generated. */
2383 vtab = gfc_find_derived_vtab (derived);
2384 if (final_expr)
2385 {
2386 /* Return finalizer expression. */
2387 gfc_component *final;
2388 final = vtab->ts.u.derived->components->next->next->next->next->next;
2389 gcc_assert (strcmp (final->name, "_final") == 0);
2390 gcc_assert (final->initializer
2391 && final->initializer->expr_type != EXPR_NULL);
2392 *final_expr = final->initializer;
2393 }
2394 return true;
2395 }
2396
2397
2398 /* Find (or generate) the symbol for an intrinsic type's vtab. This is
2399 needed to support unlimited polymorphism. */
2400
2401 static gfc_symbol *
2402 find_intrinsic_vtab (gfc_typespec *ts)
2403 {
2404 gfc_namespace *ns;
2405 gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
2406 gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
2407 int charlen = 0;
2408
2409 if (ts->type == BT_CHARACTER)
2410 {
2411 if (ts->deferred)
2412 {
2413 gfc_error ("TODO: Deferred character length variable at %C cannot "
2414 "yet be associated with unlimited polymorphic entities");
2415 return NULL;
2416 }
2417 else if (ts->u.cl && ts->u.cl->length
2418 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
2419 charlen = mpz_get_si (ts->u.cl->length->value.integer);
2420 }
2421
2422 /* Find the top-level namespace. */
2423 for (ns = gfc_current_ns; ns; ns = ns->parent)
2424 if (!ns->parent)
2425 break;
2426
2427 if (ns)
2428 {
2429 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
2430
2431 if (ts->type == BT_CHARACTER)
2432 sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
2433 charlen, ts->kind);
2434 else
2435 sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
2436
2437 sprintf (name, "__vtab_%s", tname);
2438
2439 /* Look for the vtab symbol in various namespaces. */
2440 gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
2441 if (vtab == NULL)
2442 gfc_find_symbol (name, ns, 0, &vtab);
2443
2444 if (vtab == NULL)
2445 {
2446 gfc_get_symbol (name, ns, &vtab);
2447 vtab->ts.type = BT_DERIVED;
2448 if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
2449 &gfc_current_locus))
2450 goto cleanup;
2451 vtab->attr.target = 1;
2452 vtab->attr.save = SAVE_IMPLICIT;
2453 vtab->attr.vtab = 1;
2454 vtab->attr.access = ACCESS_PUBLIC;
2455 gfc_set_sym_referenced (vtab);
2456 sprintf (name, "__vtype_%s", tname);
2457
2458 gfc_find_symbol (name, ns, 0, &vtype);
2459 if (vtype == NULL)
2460 {
2461 gfc_component *c;
2462 int hash;
2463 gfc_namespace *sub_ns;
2464 gfc_namespace *contained;
2465 gfc_expr *e;
2466
2467 gfc_get_symbol (name, ns, &vtype);
2468 if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
2469 &gfc_current_locus))
2470 goto cleanup;
2471 vtype->attr.access = ACCESS_PUBLIC;
2472 vtype->attr.vtype = 1;
2473 gfc_set_sym_referenced (vtype);
2474
2475 /* Add component '_hash'. */
2476 if (!gfc_add_component (vtype, "_hash", &c))
2477 goto cleanup;
2478 c->ts.type = BT_INTEGER;
2479 c->ts.kind = 4;
2480 c->attr.access = ACCESS_PRIVATE;
2481 hash = gfc_intrinsic_hash_value (ts);
2482 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2483 NULL, hash);
2484
2485 /* Add component '_size'. */
2486 if (!gfc_add_component (vtype, "_size", &c))
2487 goto cleanup;
2488 c->ts.type = BT_INTEGER;
2489 c->ts.kind = 4;
2490 c->attr.access = ACCESS_PRIVATE;
2491
2492 /* Build a minimal expression to make use of
2493 target-memory.c/gfc_element_size for 'size'. */
2494 e = gfc_get_expr ();
2495 e->ts = *ts;
2496 e->expr_type = EXPR_VARIABLE;
2497 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
2498 NULL,
2499 (int)gfc_element_size (e));
2500 gfc_free_expr (e);
2501
2502 /* Add component _extends. */
2503 if (!gfc_add_component (vtype, "_extends", &c))
2504 goto cleanup;
2505 c->attr.pointer = 1;
2506 c->attr.access = ACCESS_PRIVATE;
2507 c->ts.type = BT_VOID;
2508 c->initializer = gfc_get_null_expr (NULL);
2509
2510 /* Add component _def_init. */
2511 if (!gfc_add_component (vtype, "_def_init", &c))
2512 goto cleanup;
2513 c->attr.pointer = 1;
2514 c->attr.access = ACCESS_PRIVATE;
2515 c->ts.type = BT_VOID;
2516 c->initializer = gfc_get_null_expr (NULL);
2517
2518 /* Add component _copy. */
2519 if (!gfc_add_component (vtype, "_copy", &c))
2520 goto cleanup;
2521 c->attr.proc_pointer = 1;
2522 c->attr.access = ACCESS_PRIVATE;
2523 c->tb = XCNEW (gfc_typebound_proc);
2524 c->tb->ppc = 1;
2525
2526 /* Check to see if copy function already exists. Note
2527 that this is only used for characters of different
2528 lengths. */
2529 contained = ns->contained;
2530 for (; contained; contained = contained->sibling)
2531 if (contained->proc_name
2532 && strcmp (name, contained->proc_name->name) == 0)
2533 {
2534 copy = contained->proc_name;
2535 goto got_char_copy;
2536 }
2537
2538 /* Set up namespace. */
2539 sub_ns = gfc_get_namespace (ns, 0);
2540 sub_ns->sibling = ns->contained;
2541 ns->contained = sub_ns;
2542 sub_ns->resolved = 1;
2543 /* Set up procedure symbol. */
2544 if (ts->type != BT_CHARACTER)
2545 sprintf (name, "__copy_%s", tname);
2546 else
2547 /* __copy is always the same for characters. */
2548 sprintf (name, "__copy_character_%d", ts->kind);
2549 gfc_get_symbol (name, sub_ns, &copy);
2550 sub_ns->proc_name = copy;
2551 copy->attr.flavor = FL_PROCEDURE;
2552 copy->attr.subroutine = 1;
2553 copy->attr.pure = 1;
2554 copy->attr.if_source = IFSRC_DECL;
2555 /* This is elemental so that arrays are automatically
2556 treated correctly by the scalarizer. */
2557 copy->attr.elemental = 1;
2558 if (ns->proc_name->attr.flavor == FL_MODULE)
2559 copy->module = ns->proc_name->name;
2560 gfc_set_sym_referenced (copy);
2561 /* Set up formal arguments. */
2562 gfc_get_symbol ("src", sub_ns, &src);
2563 src->ts.type = ts->type;
2564 src->ts.kind = ts->kind;
2565 src->attr.flavor = FL_VARIABLE;
2566 src->attr.dummy = 1;
2567 src->attr.intent = INTENT_IN;
2568 gfc_set_sym_referenced (src);
2569 copy->formal = gfc_get_formal_arglist ();
2570 copy->formal->sym = src;
2571 gfc_get_symbol ("dst", sub_ns, &dst);
2572 dst->ts.type = ts->type;
2573 dst->ts.kind = ts->kind;
2574 dst->attr.flavor = FL_VARIABLE;
2575 dst->attr.dummy = 1;
2576 dst->attr.intent = INTENT_INOUT;
2577 gfc_set_sym_referenced (dst);
2578 copy->formal->next = gfc_get_formal_arglist ();
2579 copy->formal->next->sym = dst;
2580 /* Set up code. */
2581 sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
2582 sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
2583 sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
2584 got_char_copy:
2585 /* Set initializer. */
2586 c->initializer = gfc_lval_expr_from_sym (copy);
2587 c->ts.interface = copy;
2588
2589 /* Add component _final. */
2590 if (!gfc_add_component (vtype, "_final", &c))
2591 goto cleanup;
2592 c->attr.proc_pointer = 1;
2593 c->attr.access = ACCESS_PRIVATE;
2594 c->tb = XCNEW (gfc_typebound_proc);
2595 c->tb->ppc = 1;
2596 c->initializer = gfc_get_null_expr (NULL);
2597 }
2598 vtab->ts.u.derived = vtype;
2599 vtab->value = gfc_default_initializer (&vtab->ts);
2600 }
2601 }
2602
2603 found_sym = vtab;
2604
2605 cleanup:
2606 /* It is unexpected to have some symbols added at resolution or code
2607 generation time. We commit the changes in order to keep a clean state. */
2608 if (found_sym)
2609 {
2610 gfc_commit_symbol (vtab);
2611 if (vtype)
2612 gfc_commit_symbol (vtype);
2613 if (copy)
2614 gfc_commit_symbol (copy);
2615 if (src)
2616 gfc_commit_symbol (src);
2617 if (dst)
2618 gfc_commit_symbol (dst);
2619 }
2620 else
2621 gfc_undo_symbols ();
2622
2623 return found_sym;
2624 }
2625
2626
2627 /* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
2628
2629 gfc_symbol *
2630 gfc_find_vtab (gfc_typespec *ts)
2631 {
2632 switch (ts->type)
2633 {
2634 case BT_UNKNOWN:
2635 return NULL;
2636 case BT_DERIVED:
2637 return gfc_find_derived_vtab (ts->u.derived);
2638 case BT_CLASS:
2639 return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
2640 default:
2641 return find_intrinsic_vtab (ts);
2642 }
2643 }
2644
2645
2646 /* General worker function to find either a type-bound procedure or a
2647 type-bound user operator. */
2648
2649 static gfc_symtree*
2650 find_typebound_proc_uop (gfc_symbol* derived, bool* t,
2651 const char* name, bool noaccess, bool uop,
2652 locus* where)
2653 {
2654 gfc_symtree* res;
2655 gfc_symtree* root;
2656
2657 /* Set default to failure. */
2658 if (t)
2659 *t = false;
2660
2661 if (derived->f2k_derived)
2662 /* Set correct symbol-root. */
2663 root = (uop ? derived->f2k_derived->tb_uop_root
2664 : derived->f2k_derived->tb_sym_root);
2665 else
2666 return NULL;
2667
2668 /* Try to find it in the current type's namespace. */
2669 res = gfc_find_symtree (root, name);
2670 if (res && res->n.tb && !res->n.tb->error)
2671 {
2672 /* We found one. */
2673 if (t)
2674 *t = true;
2675
2676 if (!noaccess && derived->attr.use_assoc
2677 && res->n.tb->access == ACCESS_PRIVATE)
2678 {
2679 if (where)
2680 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2681 name, derived->name, where);
2682 if (t)
2683 *t = false;
2684 }
2685
2686 return res;
2687 }
2688
2689 /* Otherwise, recurse on parent type if derived is an extension. */
2690 if (derived->attr.extension)
2691 {
2692 gfc_symbol* super_type;
2693 super_type = gfc_get_derived_super_type (derived);
2694 gcc_assert (super_type);
2695
2696 return find_typebound_proc_uop (super_type, t, name,
2697 noaccess, uop, where);
2698 }
2699
2700 /* Nothing found. */
2701 return NULL;
2702 }
2703
2704
2705 /* Find a type-bound procedure or user operator by name for a derived-type
2706 (looking recursively through the super-types). */
2707
2708 gfc_symtree*
2709 gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
2710 const char* name, bool noaccess, locus* where)
2711 {
2712 return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
2713 }
2714
2715 gfc_symtree*
2716 gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
2717 const char* name, bool noaccess, locus* where)
2718 {
2719 return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
2720 }
2721
2722
2723 /* Find a type-bound intrinsic operator looking recursively through the
2724 super-type hierarchy. */
2725
2726 gfc_typebound_proc*
2727 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
2728 gfc_intrinsic_op op, bool noaccess,
2729 locus* where)
2730 {
2731 gfc_typebound_proc* res;
2732
2733 /* Set default to failure. */
2734 if (t)
2735 *t = false;
2736
2737 /* Try to find it in the current type's namespace. */
2738 if (derived->f2k_derived)
2739 res = derived->f2k_derived->tb_op[op];
2740 else
2741 res = NULL;
2742
2743 /* Check access. */
2744 if (res && !res->error)
2745 {
2746 /* We found one. */
2747 if (t)
2748 *t = true;
2749
2750 if (!noaccess && derived->attr.use_assoc
2751 && res->access == ACCESS_PRIVATE)
2752 {
2753 if (where)
2754 gfc_error ("'%s' of '%s' is PRIVATE at %L",
2755 gfc_op2string (op), derived->name, where);
2756 if (t)
2757 *t = false;
2758 }
2759
2760 return res;
2761 }
2762
2763 /* Otherwise, recurse on parent type if derived is an extension. */
2764 if (derived->attr.extension)
2765 {
2766 gfc_symbol* super_type;
2767 super_type = gfc_get_derived_super_type (derived);
2768 gcc_assert (super_type);
2769
2770 return gfc_find_typebound_intrinsic_op (super_type, t, op,
2771 noaccess, where);
2772 }
2773
2774 /* Nothing found. */
2775 return NULL;
2776 }
2777
2778
2779 /* Get a typebound-procedure symtree or create and insert it if not yet
2780 present. This is like a very simplified version of gfc_get_sym_tree for
2781 tbp-symtrees rather than regular ones. */
2782
2783 gfc_symtree*
2784 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
2785 {
2786 gfc_symtree *result;
2787
2788 result = gfc_find_symtree (*root, name);
2789 if (!result)
2790 {
2791 result = gfc_new_symtree (root, name);
2792 gcc_assert (result);
2793 result->n.tb = NULL;
2794 }
2795
2796 return result;
2797 }
Mirror of https://gcc.gnu.org/git/gcc.git