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