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