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