Branch data Line data Source code
1 : : /* Expression translation
2 : : Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook <paul@nowt.org>
4 : : and Steven Bosscher <s.bosscher@student.tudelft.nl>
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 : : /* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23 : :
24 : : #include "config.h"
25 : : #include "system.h"
26 : : #include "coretypes.h"
27 : : #include "options.h"
28 : : #include "tree.h"
29 : : #include "gfortran.h"
30 : : #include "trans.h"
31 : : #include "stringpool.h"
32 : : #include "diagnostic-core.h" /* For fatal_error. */
33 : : #include "fold-const.h"
34 : : #include "langhooks.h"
35 : : #include "arith.h"
36 : : #include "constructor.h"
37 : : #include "trans-const.h"
38 : : #include "trans-types.h"
39 : : #include "trans-array.h"
40 : : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 : : #include "trans-stmt.h"
42 : : #include "dependency.h"
43 : : #include "gimplify.h"
44 : : #include "tm.h" /* For CHAR_TYPE_SIZE. */
45 : :
46 : :
47 : : /* Calculate the number of characters in a string. */
48 : :
49 : : static tree
50 : 31309 : gfc_get_character_len (tree type)
51 : : {
52 : 31309 : tree len;
53 : :
54 : 31309 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
55 : : && TYPE_STRING_FLAG (type));
56 : :
57 : 31309 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
58 : 31309 : len = (len) ? (len) : (integer_zero_node);
59 : 31309 : return fold_convert (gfc_charlen_type_node, len);
60 : : }
61 : :
62 : :
63 : :
64 : : /* Calculate the number of bytes in a string. */
65 : :
66 : : tree
67 : 31309 : gfc_get_character_len_in_bytes (tree type)
68 : : {
69 : 31309 : tree tmp, len;
70 : :
71 : 31309 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
72 : : && TYPE_STRING_FLAG (type));
73 : :
74 : 31309 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
75 : 31309 : tmp = (tmp && !integer_zerop (tmp))
76 : 62618 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
77 : 31309 : len = gfc_get_character_len (type);
78 : 31309 : if (tmp && len && !integer_zerop (len))
79 : 30653 : len = fold_build2_loc (input_location, MULT_EXPR,
80 : : gfc_charlen_type_node, len, tmp);
81 : 31309 : return len;
82 : : }
83 : :
84 : :
85 : : /* Convert a scalar to an array descriptor. To be used for assumed-rank
86 : : arrays. */
87 : :
88 : : static tree
89 : 5314 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
90 : : {
91 : 5314 : enum gfc_array_kind akind;
92 : :
93 : 5314 : if (attr.pointer)
94 : : akind = GFC_ARRAY_POINTER_CONT;
95 : 5073 : else if (attr.allocatable)
96 : : akind = GFC_ARRAY_ALLOCATABLE;
97 : : else
98 : 4457 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
99 : :
100 : 5314 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
101 : 3978 : scalar = TREE_TYPE (scalar);
102 : 5314 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
103 : 5314 : akind, !(attr.pointer || attr.target));
104 : : }
105 : :
106 : : tree
107 : 4646 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
108 : : {
109 : 4646 : tree desc, type, etype;
110 : :
111 : 4646 : type = get_scalar_to_descriptor_type (scalar, attr);
112 : 4646 : etype = TREE_TYPE (scalar);
113 : 4646 : desc = gfc_create_var (type, "desc");
114 : 4646 : DECL_ARTIFICIAL (desc) = 1;
115 : :
116 : 4646 : if (CONSTANT_CLASS_P (scalar))
117 : : {
118 : 91 : tree tmp;
119 : 91 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
120 : 91 : gfc_add_modify (&se->pre, tmp, scalar);
121 : 91 : scalar = tmp;
122 : : }
123 : 4646 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
124 : 1336 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
125 : 3310 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
126 : 98 : etype = TREE_TYPE (etype);
127 : 4646 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
128 : : gfc_get_dtype_rank_type (0, etype));
129 : 4646 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
130 : 4646 : gfc_conv_descriptor_span_set (&se->pre, desc,
131 : : gfc_conv_descriptor_elem_len (desc));
132 : :
133 : : /* Copy pointer address back - but only if it could have changed and
134 : : if the actual argument is a pointer and not, e.g., NULL(). */
135 : 4646 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
136 : 618 : gfc_add_modify (&se->post, scalar,
137 : 309 : fold_convert (TREE_TYPE (scalar),
138 : : gfc_conv_descriptor_data_get (desc)));
139 : 4646 : return desc;
140 : : }
141 : :
142 : :
143 : : /* Get the coarray token from the ultimate array or component ref.
144 : : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
145 : :
146 : : tree
147 : 404 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
148 : : {
149 : 404 : gfc_symbol *sym = expr->symtree->n.sym;
150 : 404 : bool is_coarray = sym->attr.codimension;
151 : 404 : gfc_expr *caf_expr = gfc_copy_expr (expr);
152 : 404 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
153 : :
154 : 1373 : while (ref)
155 : : {
156 : 969 : if (ref->type == REF_COMPONENT
157 : 394 : && (ref->u.c.component->attr.allocatable
158 : 394 : || ref->u.c.component->attr.pointer)
159 : 394 : && (is_coarray || ref->u.c.component->attr.codimension))
160 : 969 : last_caf_ref = ref;
161 : 969 : ref = ref->next;
162 : : }
163 : :
164 : 404 : if (last_caf_ref == NULL)
165 : : return NULL_TREE;
166 : :
167 : 305 : tree comp = last_caf_ref->u.c.component->caf_token, caf;
168 : 305 : gfc_se se;
169 : 305 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
170 : 305 : if (comp == NULL_TREE && comp_ref)
171 : : return NULL_TREE;
172 : 275 : gfc_init_se (&se, outerse);
173 : 275 : gfc_free_ref_list (last_caf_ref->next);
174 : 275 : last_caf_ref->next = NULL;
175 : 275 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
176 : 275 : se.want_pointer = comp_ref;
177 : 275 : gfc_conv_expr (&se, caf_expr);
178 : 275 : gfc_add_block_to_block (&outerse->pre, &se.pre);
179 : :
180 : 275 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
181 : 152 : se.expr = TREE_OPERAND (se.expr, 0);
182 : 275 : gfc_free_expr (caf_expr);
183 : :
184 : 275 : if (comp_ref)
185 : 152 : caf = fold_build3_loc (input_location, COMPONENT_REF,
186 : 152 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
187 : : else
188 : 123 : caf = gfc_conv_descriptor_token (se.expr);
189 : 275 : return gfc_build_addr_expr (NULL_TREE, caf);
190 : : }
191 : :
192 : :
193 : : /* This is the seed for an eventual trans-class.c
194 : :
195 : : The following parameters should not be used directly since they might
196 : : in future implementations. Use the corresponding APIs. */
197 : : #define CLASS_DATA_FIELD 0
198 : : #define CLASS_VPTR_FIELD 1
199 : : #define CLASS_LEN_FIELD 2
200 : : #define VTABLE_HASH_FIELD 0
201 : : #define VTABLE_SIZE_FIELD 1
202 : : #define VTABLE_EXTENDS_FIELD 2
203 : : #define VTABLE_DEF_INIT_FIELD 3
204 : : #define VTABLE_COPY_FIELD 4
205 : : #define VTABLE_FINAL_FIELD 5
206 : : #define VTABLE_DEALLOCATE_FIELD 6
207 : :
208 : :
209 : : tree
210 : 39 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
211 : : {
212 : 39 : tree tmp;
213 : 39 : tree field;
214 : 39 : vec<constructor_elt, va_gc> *init = NULL;
215 : :
216 : 39 : field = TYPE_FIELDS (TREE_TYPE (decl));
217 : 39 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
218 : 39 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
219 : :
220 : 39 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
221 : 39 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
222 : :
223 : 39 : return build_constructor (TREE_TYPE (decl), init);
224 : : }
225 : :
226 : :
227 : : tree
228 : 24113 : gfc_class_data_get (tree decl)
229 : : {
230 : 24113 : tree data;
231 : 24113 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
232 : 4413 : decl = build_fold_indirect_ref_loc (input_location, decl);
233 : 24113 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
234 : : CLASS_DATA_FIELD);
235 : 24113 : return fold_build3_loc (input_location, COMPONENT_REF,
236 : 24113 : TREE_TYPE (data), decl, data,
237 : 24113 : NULL_TREE);
238 : : }
239 : :
240 : :
241 : : tree
242 : 32672 : gfc_class_vptr_get (tree decl)
243 : : {
244 : 32672 : tree vptr;
245 : : /* For class arrays decl may be a temporary descriptor handle, the vptr is
246 : : then available through the saved descriptor. */
247 : 19637 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
248 : 34003 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
249 : 1029 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
250 : 32672 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
251 : 2124 : decl = build_fold_indirect_ref_loc (input_location, decl);
252 : 32672 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
253 : : CLASS_VPTR_FIELD);
254 : 32672 : return fold_build3_loc (input_location, COMPONENT_REF,
255 : 32672 : TREE_TYPE (vptr), decl, vptr,
256 : 32672 : NULL_TREE);
257 : : }
258 : :
259 : :
260 : : tree
261 : 4803 : gfc_class_len_get (tree decl)
262 : : {
263 : 4803 : tree len;
264 : : /* For class arrays decl may be a temporary descriptor handle, the len is
265 : : then available through the saved descriptor. */
266 : 3377 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
267 : 4937 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
268 : 6 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
269 : 4803 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
270 : 440 : decl = build_fold_indirect_ref_loc (input_location, decl);
271 : 4803 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
272 : : CLASS_LEN_FIELD);
273 : 4803 : return fold_build3_loc (input_location, COMPONENT_REF,
274 : 4803 : TREE_TYPE (len), decl, len,
275 : 4803 : NULL_TREE);
276 : : }
277 : :
278 : :
279 : : /* Try to get the _len component of a class. When the class is not unlimited
280 : : poly, i.e. no _len field exists, then return a zero node. */
281 : :
282 : : static tree
283 : 3276 : gfc_class_len_or_zero_get (tree decl)
284 : : {
285 : 3276 : tree len;
286 : : /* For class arrays decl may be a temporary descriptor handle, the vptr is
287 : : then available through the saved descriptor. */
288 : 2102 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
289 : 3306 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
290 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
291 : 3276 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
292 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
293 : 3276 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
294 : : CLASS_LEN_FIELD);
295 : 4056 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
296 : 780 : TREE_TYPE (len), decl, len,
297 : : NULL_TREE)
298 : 2496 : : build_zero_cst (gfc_charlen_type_node);
299 : : }
300 : :
301 : :
302 : : tree
303 : 3149 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
304 : : {
305 : 3149 : tree tmp;
306 : 3149 : tree tmp2;
307 : 3149 : tree type;
308 : :
309 : 3149 : tmp = gfc_class_len_or_zero_get (class_expr);
310 : :
311 : : /* Include the len value in the element size if present. */
312 : 3149 : if (!integer_zerop (tmp))
313 : : {
314 : 653 : type = TREE_TYPE (size);
315 : 653 : if (block)
316 : : {
317 : 585 : size = gfc_evaluate_now (size, block);
318 : 585 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
319 : : }
320 : 653 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
321 : : type, size, tmp);
322 : 653 : tmp = fold_build2_loc (input_location, GT_EXPR,
323 : : logical_type_node, tmp,
324 : : build_zero_cst (type));
325 : 653 : size = fold_build3_loc (input_location, COND_EXPR,
326 : : type, tmp, tmp2, size);
327 : : }
328 : : else
329 : : return size;
330 : :
331 : 653 : if (block)
332 : 585 : size = gfc_evaluate_now (size, block);
333 : :
334 : : return size;
335 : : }
336 : :
337 : :
338 : : /* Get the specified FIELD from the VPTR. */
339 : :
340 : : static tree
341 : 15648 : vptr_field_get (tree vptr, int fieldno)
342 : : {
343 : 15648 : tree field;
344 : 15648 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
345 : 15648 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
346 : : fieldno);
347 : 15648 : field = fold_build3_loc (input_location, COMPONENT_REF,
348 : 15648 : TREE_TYPE (field), vptr, field,
349 : : NULL_TREE);
350 : 15648 : gcc_assert (field);
351 : 15648 : return field;
352 : : }
353 : :
354 : :
355 : : /* Get the field from the class' vptr. */
356 : :
357 : : static tree
358 : 7352 : class_vtab_field_get (tree decl, int fieldno)
359 : : {
360 : 7352 : tree vptr;
361 : 7352 : vptr = gfc_class_vptr_get (decl);
362 : 7352 : return vptr_field_get (vptr, fieldno);
363 : : }
364 : :
365 : :
366 : : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
367 : : unison. */
368 : : #define VTAB_GET_FIELD_GEN(name, field) tree \
369 : : gfc_class_vtab_## name ##_get (tree cl) \
370 : : { \
371 : : return class_vtab_field_get (cl, field); \
372 : : } \
373 : : \
374 : : tree \
375 : : gfc_vptr_## name ##_get (tree vptr) \
376 : : { \
377 : : return vptr_field_get (vptr, field); \
378 : : }
379 : :
380 : 171 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
381 : 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
382 : 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
383 : 3502 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
384 : 1155 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
385 : 390 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
386 : : #undef VTAB_GET_FIELD_GEN
387 : :
388 : : /* The size field is returned as an array index type. Therefore treat
389 : : it and only it specially. */
390 : :
391 : : tree
392 : 5847 : gfc_class_vtab_size_get (tree cl)
393 : : {
394 : 5847 : tree size;
395 : 5847 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
396 : : /* Always return size as an array index type. */
397 : 5847 : size = fold_convert (gfc_array_index_type, size);
398 : 5847 : gcc_assert (size);
399 : 5847 : return size;
400 : : }
401 : :
402 : : tree
403 : 4583 : gfc_vptr_size_get (tree vptr)
404 : : {
405 : 4583 : tree size;
406 : 4583 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
407 : : /* Always return size as an array index type. */
408 : 4583 : size = fold_convert (gfc_array_index_type, size);
409 : 4583 : gcc_assert (size);
410 : 4583 : return size;
411 : : }
412 : :
413 : :
414 : : #undef CLASS_DATA_FIELD
415 : : #undef CLASS_VPTR_FIELD
416 : : #undef CLASS_LEN_FIELD
417 : : #undef VTABLE_HASH_FIELD
418 : : #undef VTABLE_SIZE_FIELD
419 : : #undef VTABLE_EXTENDS_FIELD
420 : : #undef VTABLE_DEF_INIT_FIELD
421 : : #undef VTABLE_COPY_FIELD
422 : : #undef VTABLE_FINAL_FIELD
423 : :
424 : :
425 : : /* IF ts is null (default), search for the last _class ref in the chain
426 : : of references of the expression and cut the chain there. Although
427 : : this routine is similiar to class.cc:gfc_add_component_ref (), there
428 : : is a significant difference: gfc_add_component_ref () concentrates
429 : : on an array ref that is the last ref in the chain and is oblivious
430 : : to the kind of refs following.
431 : : ELSE IF ts is non-null the cut is at the class entity or component
432 : : that is followed by an array reference, which is not an element.
433 : : These calls come from trans-array.cc:build_class_array_ref, which
434 : : handles scalarized class array references.*/
435 : :
436 : : gfc_expr *
437 : 7070 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
438 : : gfc_typespec **ts)
439 : : {
440 : 7070 : gfc_expr *base_expr;
441 : 7070 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
442 : :
443 : : /* Find the last class reference. */
444 : 7070 : class_ref = NULL;
445 : 7070 : array_ref = NULL;
446 : :
447 : 7070 : if (ts)
448 : : {
449 : 311 : if (e->symtree
450 : 286 : && e->symtree->n.sym->ts.type == BT_CLASS)
451 : 286 : *ts = &e->symtree->n.sym->ts;
452 : : else
453 : 25 : *ts = NULL;
454 : : }
455 : :
456 : 17665 : for (ref = e->ref; ref; ref = ref->next)
457 : : {
458 : 10891 : if (ts)
459 : : {
460 : 738 : if (ref->type == REF_COMPONENT
461 : 340 : && ref->u.c.component->ts.type == BT_CLASS
462 : 0 : && ref->next && ref->next->type == REF_COMPONENT
463 : 0 : && !strcmp (ref->next->u.c.component->name, "_data")
464 : 0 : && ref->next->next
465 : 0 : && ref->next->next->type == REF_ARRAY
466 : 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
467 : : {
468 : 0 : *ts = &ref->u.c.component->ts;
469 : 0 : class_ref = ref;
470 : 0 : break;
471 : : }
472 : :
473 : 738 : if (ref->next == NULL)
474 : : break;
475 : : }
476 : : else
477 : : {
478 : 10153 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
479 : 10153 : array_ref = ref;
480 : :
481 : 10153 : if (ref->type == REF_COMPONENT
482 : 6324 : && ref->u.c.component->ts.type == BT_CLASS)
483 : : {
484 : : /* Component to the right of a part reference with nonzero
485 : : rank must not have the ALLOCATABLE attribute. If attempts
486 : : are made to reference such a component reference, an error
487 : : results followed by an ICE. */
488 : 1365 : if (array_ref
489 : 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
490 : : return NULL;
491 : : class_ref = ref;
492 : : }
493 : : }
494 : : }
495 : :
496 : 7060 : if (ts && *ts == NULL)
497 : : return NULL;
498 : :
499 : : /* Remove and store all subsequent references after the
500 : : CLASS reference. */
501 : 7035 : if (class_ref)
502 : : {
503 : 1199 : tail = class_ref->next;
504 : 1199 : class_ref->next = NULL;
505 : : }
506 : 5836 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
507 : : {
508 : 5818 : tail = e->ref;
509 : 5818 : e->ref = NULL;
510 : : }
511 : :
512 : 7035 : if (is_mold)
513 : 59 : base_expr = gfc_expr_to_initialize (e);
514 : : else
515 : 6976 : base_expr = gfc_copy_expr (e);
516 : :
517 : : /* Restore the original tail expression. */
518 : 7035 : if (class_ref)
519 : : {
520 : 1199 : gfc_free_ref_list (class_ref->next);
521 : 1199 : class_ref->next = tail;
522 : : }
523 : 5836 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
524 : : {
525 : 5818 : gfc_free_ref_list (e->ref);
526 : 5818 : e->ref = tail;
527 : : }
528 : : return base_expr;
529 : : }
530 : :
531 : :
532 : : /* Reset the vptr to the declared type, e.g. after deallocation.
533 : : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
534 : : one with E. The generated assignment code is added at the end of BLOCK. */
535 : :
536 : : void
537 : 1663 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
538 : : {
539 : 1663 : tree vptr = NULL_TREE;
540 : :
541 : 1663 : if (class_container != NULL_TREE)
542 : 109 : vptr = gfc_get_vptr_from_expr (class_container);
543 : :
544 : 109 : if (vptr == NULL_TREE)
545 : : {
546 : 1560 : gfc_se se;
547 : :
548 : : /* Evaluate the expression and obtain the vptr from it. */
549 : 1560 : gfc_init_se (&se, NULL);
550 : 1560 : if (e->rank)
551 : 792 : gfc_conv_expr_descriptor (&se, e);
552 : : else
553 : 768 : gfc_conv_expr (&se, e);
554 : 1560 : gfc_add_block_to_block (block, &se.pre);
555 : :
556 : 1560 : vptr = gfc_get_vptr_from_expr (se.expr);
557 : : }
558 : :
559 : : /* If a vptr is not found, we can do nothing more. */
560 : 1560 : if (vptr == NULL_TREE)
561 : : return;
562 : :
563 : 1653 : if (UNLIMITED_POLY (e))
564 : 411 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
565 : : else
566 : : {
567 : 1242 : gfc_symbol *vtab;
568 : 1242 : tree vtable;
569 : :
570 : : /* Return the vptr to the address of the declared type. */
571 : 1242 : vtab = gfc_find_derived_vtab (e->ts.u.derived);
572 : 1242 : vtable = vtab->backend_decl;
573 : 1242 : if (vtable == NULL_TREE)
574 : 21 : vtable = gfc_get_symbol_decl (vtab);
575 : 1242 : vtable = gfc_build_addr_expr (NULL, vtable);
576 : 1242 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
577 : 1242 : gfc_add_modify (block, vptr, vtable);
578 : : }
579 : : }
580 : :
581 : :
582 : : /* Reset the len for unlimited polymorphic objects. */
583 : :
584 : : void
585 : 387 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
586 : : {
587 : 387 : gfc_expr *e;
588 : 387 : gfc_se se_len;
589 : 387 : e = gfc_find_and_cut_at_last_class_ref (expr);
590 : 387 : if (e == NULL)
591 : 0 : return;
592 : 387 : gfc_add_len_component (e);
593 : 387 : gfc_init_se (&se_len, NULL);
594 : 387 : gfc_conv_expr (&se_len, e);
595 : 387 : gfc_add_modify (block, se_len.expr,
596 : 387 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
597 : 387 : gfc_free_expr (e);
598 : : }
599 : :
600 : :
601 : : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
602 : : reference is found. Note that it is up to the caller to avoid using this
603 : : for expressions other than variables. */
604 : :
605 : : tree
606 : 753 : gfc_get_class_from_gfc_expr (gfc_expr *e)
607 : : {
608 : 753 : gfc_expr *class_expr;
609 : 753 : gfc_se cse;
610 : 753 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
611 : 753 : if (class_expr == NULL)
612 : : return NULL_TREE;
613 : 753 : gfc_init_se (&cse, NULL);
614 : 753 : gfc_conv_expr (&cse, class_expr);
615 : 753 : gfc_free_expr (class_expr);
616 : 753 : return cse.expr;
617 : : }
618 : :
619 : :
620 : : /* Obtain the last class reference in an expression.
621 : : Return NULL_TREE if no class reference is found. */
622 : :
623 : : tree
624 : 69658 : gfc_get_class_from_expr (tree expr)
625 : : {
626 : 69658 : tree tmp;
627 : 69658 : tree type;
628 : :
629 : 195826 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
630 : : {
631 : 195826 : if (CONSTANT_CLASS_P (tmp))
632 : : return NULL_TREE;
633 : :
634 : 195789 : type = TREE_TYPE (tmp);
635 : 229524 : while (type)
636 : : {
637 : 223400 : if (GFC_CLASS_TYPE_P (type))
638 : 8078 : return tmp;
639 : 215322 : if (type != TYPE_CANONICAL (type))
640 : 33735 : type = TYPE_CANONICAL (type);
641 : : else
642 : : type = NULL_TREE;
643 : : }
644 : 187711 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
645 : : break;
646 : : }
647 : :
648 : 61543 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
649 : 37687 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
650 : :
651 : 61543 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
652 : : return tmp;
653 : :
654 : : return NULL_TREE;
655 : : }
656 : :
657 : :
658 : : /* Obtain the vptr of the last class reference in an expression.
659 : : Return NULL_TREE if no class reference is found. */
660 : :
661 : : tree
662 : 1873 : gfc_get_vptr_from_expr (tree expr)
663 : : {
664 : 1873 : tree tmp;
665 : :
666 : 1873 : tmp = gfc_get_class_from_expr (expr);
667 : :
668 : 1873 : if (tmp != NULL_TREE)
669 : 1851 : return gfc_class_vptr_get (tmp);
670 : :
671 : : return NULL_TREE;
672 : : }
673 : :
674 : :
675 : : static void
676 : 1118 : class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
677 : : bool lhs_type)
678 : : {
679 : 1118 : tree tmp, tmp2, type;
680 : :
681 : 1118 : gfc_conv_descriptor_data_set (block, lhs_desc,
682 : : gfc_conv_descriptor_data_get (rhs_desc));
683 : 1118 : gfc_conv_descriptor_offset_set (block, lhs_desc,
684 : : gfc_conv_descriptor_offset_get (rhs_desc));
685 : :
686 : 1118 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
687 : : gfc_conv_descriptor_dtype (rhs_desc));
688 : :
689 : : /* Assign the dimension as range-ref. */
690 : 1118 : tmp = gfc_get_descriptor_dimension (lhs_desc);
691 : 1118 : tmp2 = gfc_get_descriptor_dimension (rhs_desc);
692 : :
693 : 1118 : type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
694 : 1118 : tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
695 : : gfc_index_zero_node, NULL_TREE, NULL_TREE);
696 : 1118 : tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
697 : : gfc_index_zero_node, NULL_TREE, NULL_TREE);
698 : 1118 : gfc_add_modify (block, tmp, tmp2);
699 : 1118 : }
700 : :
701 : :
702 : : /* Takes a derived type expression and returns the address of a temporary
703 : : class object of the 'declared' type. If vptr is not NULL, this is
704 : : used for the temporary class object.
705 : : optional_alloc_ptr is false when the dummy is neither allocatable
706 : : nor a pointer; that's only relevant for the optional handling.
707 : : The optional argument 'derived_array' is used to preserve the parmse
708 : : expression for deallocation of allocatable components. Assumed rank
709 : : formal arguments made this necessary. */
710 : : void
711 : 4235 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
712 : : gfc_typespec class_ts, tree vptr, bool optional,
713 : : bool optional_alloc_ptr,
714 : : tree *derived_array)
715 : : {
716 : 4235 : gfc_symbol *vtab;
717 : 4235 : tree cond_optional = NULL_TREE;
718 : 4235 : gfc_ss *ss;
719 : 4235 : tree ctree;
720 : 4235 : tree var;
721 : 4235 : tree tmp;
722 : 4235 : int dim;
723 : :
724 : : /* The derived type needs to be converted to a temporary
725 : : CLASS object. */
726 : 4235 : tmp = gfc_typenode_for_spec (&class_ts);
727 : 4235 : var = gfc_create_var (tmp, "class");
728 : :
729 : : /* Set the vptr. */
730 : 4235 : ctree = gfc_class_vptr_get (var);
731 : :
732 : 4235 : if (vptr != NULL_TREE)
733 : : {
734 : : /* Use the dynamic vptr. */
735 : : tmp = vptr;
736 : : }
737 : : else
738 : : {
739 : : /* In this case the vtab corresponds to the derived type and the
740 : : vptr must point to it. */
741 : 4127 : vtab = gfc_find_derived_vtab (e->ts.u.derived);
742 : 4127 : gcc_assert (vtab);
743 : 4127 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
744 : : }
745 : 4235 : gfc_add_modify (&parmse->pre, ctree,
746 : 4235 : fold_convert (TREE_TYPE (ctree), tmp));
747 : :
748 : : /* Now set the data field. */
749 : 4235 : ctree = gfc_class_data_get (var);
750 : :
751 : 4235 : if (optional)
752 : 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
753 : :
754 : 4235 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
755 : : {
756 : : /* If there is a ready made pointer to a derived type, use it
757 : : rather than evaluating the expression again. */
758 : 454 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
759 : 454 : gfc_add_modify (&parmse->pre, ctree, tmp);
760 : : }
761 : 3781 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
762 : : {
763 : : /* For an array reference in an elemental procedure call we need
764 : : to retain the ss to provide the scalarized array reference. */
765 : 221 : gfc_conv_expr_reference (parmse, e);
766 : 221 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
767 : 221 : if (optional)
768 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
769 : : cond_optional, tmp,
770 : 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
771 : 221 : gfc_add_modify (&parmse->pre, ctree, tmp);
772 : : }
773 : : else
774 : : {
775 : 3560 : ss = gfc_walk_expr (e);
776 : 3560 : if (ss == gfc_ss_terminator)
777 : : {
778 : 2539 : parmse->ss = NULL;
779 : 2539 : gfc_conv_expr_reference (parmse, e);
780 : :
781 : : /* Scalar to an assumed-rank array. */
782 : 2539 : if (class_ts.u.derived->components->as)
783 : : {
784 : 318 : tree type;
785 : 318 : type = get_scalar_to_descriptor_type (parmse->expr,
786 : : gfc_expr_attr (e));
787 : 318 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
788 : : gfc_get_dtype (type));
789 : 318 : if (optional)
790 : 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
791 : 96 : TREE_TYPE (parmse->expr),
792 : : cond_optional, parmse->expr,
793 : 96 : fold_convert (TREE_TYPE (parmse->expr),
794 : : null_pointer_node));
795 : 318 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
796 : : }
797 : : else
798 : : {
799 : 2221 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
800 : 2221 : if (optional)
801 : 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
802 : : cond_optional, tmp,
803 : 132 : fold_convert (TREE_TYPE (tmp),
804 : : null_pointer_node));
805 : 2221 : gfc_add_modify (&parmse->pre, ctree, tmp);
806 : : }
807 : : }
808 : : else
809 : : {
810 : 1021 : stmtblock_t block;
811 : 1021 : gfc_init_block (&block);
812 : 1021 : gfc_ref *ref;
813 : :
814 : 1021 : parmse->ss = ss;
815 : 1021 : parmse->use_offset = 1;
816 : 1021 : gfc_conv_expr_descriptor (parmse, e);
817 : :
818 : : /* Detect any array references with vector subscripts. */
819 : 2042 : for (ref = e->ref; ref; ref = ref->next)
820 : 1027 : if (ref->type == REF_ARRAY
821 : 985 : && ref->u.ar.type != AR_ELEMENT
822 : 985 : && ref->u.ar.type != AR_FULL)
823 : : {
824 : 126 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
825 : 78 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
826 : : break;
827 : 54 : if (dim < ref->u.ar.dimen)
828 : : break;
829 : : }
830 : :
831 : : /* Array references with vector subscripts and non-variable expressions
832 : : need be converted to a one-based descriptor. */
833 : 1021 : if (ref || e->expr_type != EXPR_VARIABLE)
834 : : {
835 : 84 : for (dim = 0; dim < e->rank; ++dim)
836 : 42 : gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
837 : : gfc_index_one_node);
838 : : }
839 : :
840 : 1021 : if (e->rank != class_ts.u.derived->components->as->rank)
841 : : {
842 : 396 : gcc_assert (class_ts.u.derived->components->as->type
843 : : == AS_ASSUMED_RANK);
844 : 396 : if (derived_array
845 : 396 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
846 : : {
847 : 396 : *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
848 : : "array");
849 : 396 : gfc_add_modify (&block, *derived_array , parmse->expr);
850 : : }
851 : 396 : class_array_data_assign (&block, ctree, parmse->expr, false);
852 : : }
853 : : else
854 : : {
855 : 625 : if (gfc_expr_attr (e).codimension)
856 : 72 : parmse->expr = fold_build1_loc (input_location,
857 : : VIEW_CONVERT_EXPR,
858 : 72 : TREE_TYPE (ctree),
859 : : parmse->expr);
860 : 625 : gfc_add_modify (&block, ctree, parmse->expr);
861 : : }
862 : :
863 : 1021 : if (optional)
864 : : {
865 : 348 : tmp = gfc_finish_block (&block);
866 : :
867 : 348 : gfc_init_block (&block);
868 : 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
869 : 348 : if (derived_array && *derived_array != NULL_TREE)
870 : 132 : gfc_conv_descriptor_data_set (&block, *derived_array,
871 : : null_pointer_node);
872 : :
873 : 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
874 : : gfc_finish_block (&block));
875 : 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
876 : : }
877 : : else
878 : 673 : gfc_add_block_to_block (&parmse->pre, &block);
879 : : }
880 : : }
881 : :
882 : 4235 : if (class_ts.u.derived->components->ts.type == BT_DERIVED
883 : 4235 : && class_ts.u.derived->components->ts.u.derived
884 : 4235 : ->attr.unlimited_polymorphic)
885 : : {
886 : : /* Take care about initializing the _len component correctly. */
887 : 288 : ctree = gfc_class_len_get (var);
888 : 288 : if (UNLIMITED_POLY (e))
889 : : {
890 : 6 : gfc_expr *len;
891 : 6 : gfc_se se;
892 : :
893 : 6 : len = gfc_find_and_cut_at_last_class_ref (e);
894 : 6 : gfc_add_len_component (len);
895 : 6 : gfc_init_se (&se, NULL);
896 : 6 : gfc_conv_expr (&se, len);
897 : 6 : if (optional)
898 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
899 : : cond_optional, se.expr,
900 : 0 : fold_convert (TREE_TYPE (se.expr),
901 : : integer_zero_node));
902 : : else
903 : 6 : tmp = se.expr;
904 : 6 : gfc_free_expr (len);
905 : 6 : }
906 : : else
907 : 282 : tmp = integer_zero_node;
908 : 288 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
909 : : tmp));
910 : : }
911 : : /* Pass the address of the class object. */
912 : 4235 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
913 : :
914 : 4235 : if (optional && optional_alloc_ptr)
915 : 168 : parmse->expr = build3_loc (input_location, COND_EXPR,
916 : 84 : TREE_TYPE (parmse->expr),
917 : : cond_optional, parmse->expr,
918 : 84 : fold_convert (TREE_TYPE (parmse->expr),
919 : : null_pointer_node));
920 : 4235 : }
921 : :
922 : :
923 : : /* Create a new class container, which is required as scalar coarrays
924 : : have an array descriptor while normal scalars haven't. Optionally,
925 : : NULL pointer checks are added if the argument is OPTIONAL. */
926 : :
927 : : static void
928 : 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
929 : : gfc_typespec class_ts, bool optional)
930 : : {
931 : 48 : tree var, ctree, tmp;
932 : 48 : stmtblock_t block;
933 : 48 : gfc_ref *ref;
934 : 48 : gfc_ref *class_ref;
935 : :
936 : 48 : gfc_init_block (&block);
937 : :
938 : 48 : class_ref = NULL;
939 : 144 : for (ref = e->ref; ref; ref = ref->next)
940 : : {
941 : 96 : if (ref->type == REF_COMPONENT
942 : 48 : && ref->u.c.component->ts.type == BT_CLASS)
943 : 96 : class_ref = ref;
944 : : }
945 : :
946 : 48 : if (class_ref == NULL
947 : 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
948 : 48 : tmp = e->symtree->n.sym->backend_decl;
949 : : else
950 : : {
951 : : /* Remove everything after the last class reference, convert the
952 : : expression and then recover its tailend once more. */
953 : 0 : gfc_se tmpse;
954 : 0 : ref = class_ref->next;
955 : 0 : class_ref->next = NULL;
956 : 0 : gfc_init_se (&tmpse, NULL);
957 : 0 : gfc_conv_expr (&tmpse, e);
958 : 0 : class_ref->next = ref;
959 : 0 : tmp = tmpse.expr;
960 : : }
961 : :
962 : 48 : var = gfc_typenode_for_spec (&class_ts);
963 : 48 : var = gfc_create_var (var, "class");
964 : :
965 : 48 : ctree = gfc_class_vptr_get (var);
966 : 96 : gfc_add_modify (&block, ctree,
967 : 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
968 : :
969 : 48 : ctree = gfc_class_data_get (var);
970 : 48 : tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
971 : 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
972 : :
973 : : /* Pass the address of the class object. */
974 : 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
975 : :
976 : 48 : if (optional)
977 : : {
978 : 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
979 : 48 : tree tmp2;
980 : :
981 : 48 : tmp = gfc_finish_block (&block);
982 : :
983 : 48 : gfc_init_block (&block);
984 : 48 : tmp2 = gfc_class_data_get (var);
985 : 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
986 : : null_pointer_node));
987 : 48 : tmp2 = gfc_finish_block (&block);
988 : :
989 : 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
990 : : cond, tmp, tmp2);
991 : 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
992 : : }
993 : : else
994 : 0 : gfc_add_block_to_block (&parmse->pre, &block);
995 : 48 : }
996 : :
997 : :
998 : : /* Takes an intrinsic type expression and returns the address of a temporary
999 : : class object of the 'declared' type. */
1000 : : void
1001 : 697 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1002 : : gfc_typespec class_ts)
1003 : : {
1004 : 697 : gfc_symbol *vtab;
1005 : 697 : gfc_ss *ss;
1006 : 697 : tree ctree;
1007 : 697 : tree var;
1008 : 697 : tree tmp;
1009 : 697 : int dim;
1010 : 697 : bool unlimited_poly;
1011 : :
1012 : 1394 : unlimited_poly = class_ts.type == BT_CLASS
1013 : 697 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1014 : 697 : && class_ts.u.derived->components->ts.u.derived
1015 : 697 : ->attr.unlimited_polymorphic;
1016 : :
1017 : : /* The intrinsic type needs to be converted to a temporary
1018 : : CLASS object. */
1019 : 697 : tmp = gfc_typenode_for_spec (&class_ts);
1020 : 697 : var = gfc_create_var (tmp, "class");
1021 : :
1022 : : /* Set the vptr. */
1023 : 697 : ctree = gfc_class_vptr_get (var);
1024 : :
1025 : 697 : vtab = gfc_find_vtab (&e->ts);
1026 : 697 : gcc_assert (vtab);
1027 : 697 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1028 : 697 : gfc_add_modify (&parmse->pre, ctree,
1029 : 697 : fold_convert (TREE_TYPE (ctree), tmp));
1030 : :
1031 : : /* Now set the data field. */
1032 : 697 : ctree = gfc_class_data_get (var);
1033 : 697 : if (parmse->ss && parmse->ss->info->useflags)
1034 : : {
1035 : : /* For an array reference in an elemental procedure call we need
1036 : : to retain the ss to provide the scalarized array reference. */
1037 : 0 : gfc_conv_expr_reference (parmse, e);
1038 : 0 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1039 : 0 : gfc_add_modify (&parmse->pre, ctree, tmp);
1040 : : }
1041 : : else
1042 : : {
1043 : 697 : ss = gfc_walk_expr (e);
1044 : 697 : if (ss == gfc_ss_terminator)
1045 : : {
1046 : 202 : parmse->ss = NULL;
1047 : 202 : gfc_conv_expr_reference (parmse, e);
1048 : 202 : if (class_ts.u.derived->components->as
1049 : 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1050 : : {
1051 : 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1052 : : gfc_expr_attr (e));
1053 : 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1054 : 24 : TREE_TYPE (ctree), tmp);
1055 : : }
1056 : : else
1057 : 178 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1058 : 202 : gfc_add_modify (&parmse->pre, ctree, tmp);
1059 : : }
1060 : : else
1061 : : {
1062 : 495 : parmse->ss = ss;
1063 : 495 : parmse->use_offset = 1;
1064 : 495 : gfc_conv_expr_descriptor (parmse, e);
1065 : :
1066 : : /* Array references with vector subscripts and non-variable expressions
1067 : : need be converted to a one-based descriptor. */
1068 : 495 : if (e->expr_type != EXPR_VARIABLE)
1069 : : {
1070 : 368 : for (dim = 0; dim < e->rank; ++dim)
1071 : 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1072 : : dim, gfc_index_one_node);
1073 : : }
1074 : :
1075 : 495 : if (class_ts.u.derived->components->as->rank != e->rank)
1076 : : {
1077 : 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1078 : 49 : TREE_TYPE (ctree), parmse->expr);
1079 : 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1080 : : }
1081 : : else
1082 : 446 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1083 : : }
1084 : : }
1085 : :
1086 : 697 : gcc_assert (class_ts.type == BT_CLASS);
1087 : 697 : if (unlimited_poly)
1088 : : {
1089 : 697 : ctree = gfc_class_len_get (var);
1090 : : /* When the actual arg is a char array, then set the _len component of the
1091 : : unlimited polymorphic entity to the length of the string. */
1092 : 697 : if (e->ts.type == BT_CHARACTER)
1093 : : {
1094 : : /* Start with parmse->string_length because this seems to be set to a
1095 : : correct value more often. */
1096 : 110 : if (parmse->string_length)
1097 : : tmp = parmse->string_length;
1098 : : /* When the string_length is not yet set, then try the backend_decl of
1099 : : the cl. */
1100 : 0 : else if (e->ts.u.cl->backend_decl)
1101 : : tmp = e->ts.u.cl->backend_decl;
1102 : : /* If both of the above approaches fail, then try to generate an
1103 : : expression from the input, which is only feasible currently, when the
1104 : : expression can be evaluated to a constant one. */
1105 : : else
1106 : : {
1107 : : /* Try to simplify the expression. */
1108 : 0 : gfc_simplify_expr (e, 0);
1109 : 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1110 : : {
1111 : : /* Amazingly all data is present to compute the length of a
1112 : : constant string, but the expression is not yet there. */
1113 : 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1114 : : gfc_charlen_int_kind,
1115 : : &e->where);
1116 : 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1117 : 0 : e->value.character.length);
1118 : 0 : gfc_conv_const_charlen (e->ts.u.cl);
1119 : 0 : e->ts.u.cl->resolved = 1;
1120 : 0 : tmp = e->ts.u.cl->backend_decl;
1121 : : }
1122 : : else
1123 : : {
1124 : 0 : gfc_error ("Cannot compute the length of the char array "
1125 : : "at %L.", &e->where);
1126 : : }
1127 : : }
1128 : : }
1129 : : else
1130 : 587 : tmp = integer_zero_node;
1131 : :
1132 : 697 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1133 : : }
1134 : : else if (unlimited_poly)
1135 : : {
1136 : : ctree = gfc_class_len_get (var);
1137 : : gfc_add_modify (&parmse->pre, ctree,
1138 : : fold_convert (TREE_TYPE (ctree),
1139 : : integer_zero_node));
1140 : : }
1141 : : /* Pass the address of the class object. */
1142 : 697 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1143 : 697 : }
1144 : :
1145 : :
1146 : : /* Takes a scalarized class array expression and returns the
1147 : : address of a temporary scalar class object of the 'declared'
1148 : : type.
1149 : : OOP-TODO: This could be improved by adding code that branched on
1150 : : the dynamic type being the same as the declared type. In this case
1151 : : the original class expression can be passed directly.
1152 : : optional_alloc_ptr is false when the dummy is neither allocatable
1153 : : nor a pointer; that's relevant for the optional handling.
1154 : : Set copyback to true if class container's _data and _vtab pointers
1155 : : might get modified. */
1156 : :
1157 : : void
1158 : 3116 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1159 : : bool elemental, bool copyback, bool optional,
1160 : : bool optional_alloc_ptr)
1161 : : {
1162 : 3116 : tree ctree;
1163 : 3116 : tree var;
1164 : 3116 : tree tmp;
1165 : 3116 : tree vptr;
1166 : 3116 : tree cond = NULL_TREE;
1167 : 3116 : tree slen = NULL_TREE;
1168 : 3116 : gfc_ref *ref;
1169 : 3116 : gfc_ref *class_ref;
1170 : 3116 : stmtblock_t block;
1171 : 3116 : bool full_array = false;
1172 : :
1173 : 3116 : gfc_init_block (&block);
1174 : :
1175 : 3116 : class_ref = NULL;
1176 : 6256 : for (ref = e->ref; ref; ref = ref->next)
1177 : : {
1178 : 5901 : if (ref->type == REF_COMPONENT
1179 : 3173 : && ref->u.c.component->ts.type == BT_CLASS)
1180 : 5901 : class_ref = ref;
1181 : :
1182 : 5901 : if (ref->next == NULL)
1183 : : break;
1184 : : }
1185 : :
1186 : 3116 : if ((ref == NULL || class_ref == ref)
1187 : 466 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1188 : 3570 : && (!class_ts.u.derived->components->as
1189 : 372 : || class_ts.u.derived->components->as->rank != -1))
1190 : 128 : return;
1191 : :
1192 : : /* Test for FULL_ARRAY. */
1193 : 2988 : if (e->rank == 0
1194 : 2988 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1195 : 478 : || (class_ts.u.derived->components->as
1196 : 350 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1197 : 397 : full_array = true;
1198 : : else
1199 : 2591 : gfc_is_class_array_ref (e, &full_array);
1200 : :
1201 : : /* The derived type needs to be converted to a temporary
1202 : : CLASS object. */
1203 : 2988 : tmp = gfc_typenode_for_spec (&class_ts);
1204 : 2988 : var = gfc_create_var (tmp, "class");
1205 : :
1206 : : /* Set the data. */
1207 : 2988 : ctree = gfc_class_data_get (var);
1208 : 2988 : if (class_ts.u.derived->components->as
1209 : 2734 : && e->rank != class_ts.u.derived->components->as->rank)
1210 : : {
1211 : 904 : if (e->rank == 0)
1212 : : {
1213 : 350 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1214 : : gfc_expr_attr (e));
1215 : 350 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1216 : : gfc_get_dtype (type));
1217 : :
1218 : 350 : tmp = gfc_class_data_get (parmse->expr);
1219 : 350 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1220 : 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1221 : :
1222 : 350 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1223 : : }
1224 : : else
1225 : 554 : class_array_data_assign (&block, ctree, parmse->expr, false);
1226 : : }
1227 : : else
1228 : : {
1229 : 2084 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1230 : 1189 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1231 : 1189 : TREE_TYPE (ctree), parmse->expr);
1232 : 2084 : gfc_add_modify (&block, ctree, parmse->expr);
1233 : : }
1234 : :
1235 : : /* Return the data component, except in the case of scalarized array
1236 : : references, where nullification of the cannot occur and so there
1237 : : is no need. */
1238 : 2988 : if (!elemental && full_array && copyback)
1239 : : {
1240 : 1004 : if (class_ts.u.derived->components->as
1241 : 1004 : && e->rank != class_ts.u.derived->components->as->rank)
1242 : : {
1243 : 270 : if (e->rank == 0)
1244 : : {
1245 : 102 : tmp = gfc_class_data_get (parmse->expr);
1246 : 204 : gfc_add_modify (&parmse->post, tmp,
1247 : 102 : fold_convert (TREE_TYPE (tmp),
1248 : : gfc_conv_descriptor_data_get (ctree)));
1249 : : }
1250 : : else
1251 : 168 : class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1252 : : }
1253 : : else
1254 : 734 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1255 : : }
1256 : :
1257 : : /* Set the vptr. */
1258 : 2988 : ctree = gfc_class_vptr_get (var);
1259 : :
1260 : : /* The vptr is the second field of the actual argument.
1261 : : First we have to find the corresponding class reference. */
1262 : :
1263 : 2988 : tmp = NULL_TREE;
1264 : 2988 : if (gfc_is_class_array_function (e)
1265 : 2988 : && parmse->class_vptr != NULL_TREE)
1266 : : tmp = parmse->class_vptr;
1267 : 2976 : else if (class_ref == NULL
1268 : 2545 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1269 : : {
1270 : 2545 : tmp = e->symtree->n.sym->backend_decl;
1271 : :
1272 : 2545 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1273 : 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1274 : :
1275 : 2545 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1276 : 303 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1277 : :
1278 : 2545 : slen = build_zero_cst (size_type_node);
1279 : : }
1280 : 431 : else if (parmse->class_container != NULL_TREE)
1281 : : /* Don't redundantly evaluate the expression if the required information
1282 : : is already available. */
1283 : : tmp = parmse->class_container;
1284 : : else
1285 : : {
1286 : : /* Remove everything after the last class reference, convert the
1287 : : expression and then recover its tailend once more. */
1288 : 18 : gfc_se tmpse;
1289 : 18 : ref = class_ref->next;
1290 : 18 : class_ref->next = NULL;
1291 : 18 : gfc_init_se (&tmpse, NULL);
1292 : 18 : gfc_conv_expr (&tmpse, e);
1293 : 18 : class_ref->next = ref;
1294 : 18 : tmp = tmpse.expr;
1295 : 18 : slen = tmpse.string_length;
1296 : : }
1297 : :
1298 : 2988 : gcc_assert (tmp != NULL_TREE);
1299 : :
1300 : : /* Dereference if needs be. */
1301 : 2988 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1302 : 267 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1303 : :
1304 : 2988 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1305 : 2976 : vptr = gfc_class_vptr_get (tmp);
1306 : : else
1307 : : vptr = tmp;
1308 : :
1309 : 2988 : gfc_add_modify (&block, ctree,
1310 : 2988 : fold_convert (TREE_TYPE (ctree), vptr));
1311 : :
1312 : : /* Return the vptr component, except in the case of scalarized array
1313 : : references, where the dynamic type cannot change. */
1314 : 2988 : if (!elemental && full_array && copyback)
1315 : 1004 : gfc_add_modify (&parmse->post, vptr,
1316 : 1004 : fold_convert (TREE_TYPE (vptr), ctree));
1317 : :
1318 : : /* For unlimited polymorphic objects also set the _len component. */
1319 : 2988 : if (class_ts.type == BT_CLASS
1320 : 2988 : && class_ts.u.derived->components
1321 : 2988 : && class_ts.u.derived->components->ts.u
1322 : 2988 : .derived->attr.unlimited_polymorphic)
1323 : : {
1324 : 838 : ctree = gfc_class_len_get (var);
1325 : 838 : if (UNLIMITED_POLY (e))
1326 : 636 : tmp = gfc_class_len_get (tmp);
1327 : 202 : else if (e->ts.type == BT_CHARACTER)
1328 : : {
1329 : 0 : gcc_assert (slen != NULL_TREE);
1330 : : tmp = slen;
1331 : : }
1332 : : else
1333 : 202 : tmp = build_zero_cst (size_type_node);
1334 : 838 : gfc_add_modify (&parmse->pre, ctree,
1335 : 838 : fold_convert (TREE_TYPE (ctree), tmp));
1336 : :
1337 : : /* Return the len component, except in the case of scalarized array
1338 : : references, where the dynamic type cannot change. */
1339 : 838 : if (!elemental && full_array && copyback
1340 : 380 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1341 : 338 : gfc_add_modify (&parmse->post, tmp,
1342 : 338 : fold_convert (TREE_TYPE (tmp), ctree));
1343 : : }
1344 : :
1345 : 2988 : if (optional)
1346 : : {
1347 : 486 : tree tmp2;
1348 : :
1349 : 486 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1350 : : /* parmse->pre may contain some preparatory instructions for the
1351 : : temporary array descriptor. Those may only be executed when the
1352 : : optional argument is set, therefore add parmse->pre's instructions
1353 : : to block, which is later guarded by an if (optional_arg_given). */
1354 : 486 : gfc_add_block_to_block (&parmse->pre, &block);
1355 : 486 : block.head = parmse->pre.head;
1356 : 486 : parmse->pre.head = NULL_TREE;
1357 : 486 : tmp = gfc_finish_block (&block);
1358 : :
1359 : 486 : if (optional_alloc_ptr)
1360 : 78 : tmp2 = build_empty_stmt (input_location);
1361 : : else
1362 : : {
1363 : 408 : gfc_init_block (&block);
1364 : :
1365 : 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1366 : 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1367 : : null_pointer_node));
1368 : 408 : tmp2 = gfc_finish_block (&block);
1369 : : }
1370 : :
1371 : 486 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1372 : : cond, tmp, tmp2);
1373 : 486 : gfc_add_expr_to_block (&parmse->pre, tmp);
1374 : : }
1375 : : else
1376 : 2502 : gfc_add_block_to_block (&parmse->pre, &block);
1377 : :
1378 : : /* Pass the address of the class object. */
1379 : 2988 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1380 : :
1381 : 2988 : if (optional && optional_alloc_ptr)
1382 : 156 : parmse->expr = build3_loc (input_location, COND_EXPR,
1383 : 78 : TREE_TYPE (parmse->expr),
1384 : : cond, parmse->expr,
1385 : 78 : fold_convert (TREE_TYPE (parmse->expr),
1386 : : null_pointer_node));
1387 : : }
1388 : :
1389 : :
1390 : : /* Given a class array declaration and an index, returns the address
1391 : : of the referenced element. */
1392 : :
1393 : : static tree
1394 : 534 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1395 : : bool unlimited)
1396 : : {
1397 : 534 : tree data, size, tmp, ctmp, offset, ptr;
1398 : :
1399 : 534 : data = data_comp != NULL_TREE ? data_comp :
1400 : 0 : gfc_class_data_get (class_decl);
1401 : 534 : size = gfc_class_vtab_size_get (class_decl);
1402 : :
1403 : 534 : if (unlimited)
1404 : : {
1405 : 138 : tmp = fold_convert (gfc_array_index_type,
1406 : : gfc_class_len_get (class_decl));
1407 : 138 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1408 : : gfc_array_index_type, size, tmp);
1409 : 138 : tmp = fold_build2_loc (input_location, GT_EXPR,
1410 : : logical_type_node, tmp,
1411 : 138 : build_zero_cst (TREE_TYPE (tmp)));
1412 : 138 : size = fold_build3_loc (input_location, COND_EXPR,
1413 : : gfc_array_index_type, tmp, ctmp, size);
1414 : : }
1415 : :
1416 : 534 : offset = fold_build2_loc (input_location, MULT_EXPR,
1417 : : gfc_array_index_type,
1418 : : index, size);
1419 : :
1420 : 534 : data = gfc_conv_descriptor_data_get (data);
1421 : 534 : ptr = fold_convert (pvoid_type_node, data);
1422 : 534 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1423 : 534 : return fold_convert (TREE_TYPE (data), ptr);
1424 : : }
1425 : :
1426 : :
1427 : : /* Copies one class expression to another, assuming that if either
1428 : : 'to' or 'from' are arrays they are packed. Should 'from' be
1429 : : NULL_TREE, the initialization expression for 'to' is used, assuming
1430 : : that the _vptr is set. */
1431 : :
1432 : : tree
1433 : 619 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1434 : : {
1435 : 619 : tree fcn;
1436 : 619 : tree fcn_type;
1437 : 619 : tree from_data;
1438 : 619 : tree from_len;
1439 : 619 : tree to_data;
1440 : 619 : tree to_len;
1441 : 619 : tree to_ref;
1442 : 619 : tree from_ref;
1443 : 619 : vec<tree, va_gc> *args;
1444 : 619 : tree tmp;
1445 : 619 : tree stdcopy;
1446 : 619 : tree extcopy;
1447 : 619 : tree index;
1448 : 619 : bool is_from_desc = false, is_to_class = false;
1449 : :
1450 : 619 : args = NULL;
1451 : : /* To prevent warnings on uninitialized variables. */
1452 : 619 : from_len = to_len = NULL_TREE;
1453 : :
1454 : 619 : if (from != NULL_TREE)
1455 : 619 : fcn = gfc_class_vtab_copy_get (from);
1456 : : else
1457 : 0 : fcn = gfc_class_vtab_copy_get (to);
1458 : :
1459 : 619 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1460 : :
1461 : 619 : if (from != NULL_TREE)
1462 : : {
1463 : 619 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1464 : 619 : if (is_from_desc)
1465 : : {
1466 : 0 : from_data = from;
1467 : 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1468 : : }
1469 : : else
1470 : : {
1471 : : /* Check that from is a class. When the class is part of a coarray,
1472 : : then from is a common pointer and is to be used as is. */
1473 : 1238 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1474 : 619 : ? build_fold_indirect_ref (from) : from;
1475 : 1238 : from_data =
1476 : 619 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1477 : 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1478 : 619 : ? gfc_class_data_get (from) : from;
1479 : 619 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1480 : : }
1481 : : }
1482 : : else
1483 : 0 : from_data = gfc_class_vtab_def_init_get (to);
1484 : :
1485 : 619 : if (unlimited)
1486 : : {
1487 : 127 : if (from != NULL_TREE && unlimited)
1488 : 127 : from_len = gfc_class_len_or_zero_get (from);
1489 : : else
1490 : 0 : from_len = build_zero_cst (size_type_node);
1491 : : }
1492 : :
1493 : 619 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1494 : : {
1495 : 619 : is_to_class = true;
1496 : 619 : to_data = gfc_class_data_get (to);
1497 : 619 : if (unlimited)
1498 : 127 : to_len = gfc_class_len_get (to);
1499 : : }
1500 : : else
1501 : : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1502 : 0 : to_data = to;
1503 : :
1504 : 619 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1505 : : {
1506 : 267 : stmtblock_t loopbody;
1507 : 267 : stmtblock_t body;
1508 : 267 : stmtblock_t ifbody;
1509 : 267 : gfc_loopinfo loop;
1510 : 267 : tree orig_nelems = nelems; /* Needed for bounds check. */
1511 : :
1512 : 267 : gfc_init_block (&body);
1513 : 267 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1514 : : gfc_array_index_type, nelems,
1515 : : gfc_index_one_node);
1516 : 267 : nelems = gfc_evaluate_now (tmp, &body);
1517 : 267 : index = gfc_create_var (gfc_array_index_type, "S");
1518 : :
1519 : 267 : if (is_from_desc)
1520 : : {
1521 : 267 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1522 : : unlimited);
1523 : 267 : vec_safe_push (args, from_ref);
1524 : : }
1525 : : else
1526 : 0 : vec_safe_push (args, from_data);
1527 : :
1528 : 267 : if (is_to_class)
1529 : 267 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1530 : : else
1531 : : {
1532 : 0 : tmp = gfc_conv_array_data (to);
1533 : 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1534 : 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1535 : : gfc_build_array_ref (tmp, index, to));
1536 : : }
1537 : 267 : vec_safe_push (args, to_ref);
1538 : :
1539 : : /* Add bounds check. */
1540 : 267 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1541 : : {
1542 : 1 : char *msg;
1543 : 1 : const char *name = "<<unknown>>";
1544 : 1 : tree from_len;
1545 : :
1546 : 1 : if (DECL_P (to))
1547 : 0 : name = (const char *)(DECL_NAME (to)->identifier.id.str);
1548 : :
1549 : 1 : from_len = gfc_conv_descriptor_size (from_data, 1);
1550 : 1 : from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
1551 : 1 : tmp = fold_build2_loc (input_location, NE_EXPR,
1552 : : logical_type_node, from_len, orig_nelems);
1553 : 1 : msg = xasprintf ("Array bound mismatch for dimension %d "
1554 : : "of array '%s' (%%ld/%%ld)",
1555 : : 1, name);
1556 : :
1557 : 1 : gfc_trans_runtime_check (true, false, tmp, &body,
1558 : : &gfc_current_locus, msg,
1559 : : fold_convert (long_integer_type_node, orig_nelems),
1560 : : fold_convert (long_integer_type_node, from_len));
1561 : :
1562 : 1 : free (msg);
1563 : : }
1564 : :
1565 : 267 : tmp = build_call_vec (fcn_type, fcn, args);
1566 : :
1567 : : /* Build the body of the loop. */
1568 : 267 : gfc_init_block (&loopbody);
1569 : 267 : gfc_add_expr_to_block (&loopbody, tmp);
1570 : :
1571 : : /* Build the loop and return. */
1572 : 267 : gfc_init_loopinfo (&loop);
1573 : 267 : loop.dimen = 1;
1574 : 267 : loop.from[0] = gfc_index_zero_node;
1575 : 267 : loop.loopvar[0] = index;
1576 : 267 : loop.to[0] = nelems;
1577 : 267 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1578 : 267 : gfc_init_block (&ifbody);
1579 : 267 : gfc_add_block_to_block (&ifbody, &loop.pre);
1580 : 267 : stdcopy = gfc_finish_block (&ifbody);
1581 : : /* In initialization mode from_len is a constant zero. */
1582 : 267 : if (unlimited && !integer_zerop (from_len))
1583 : : {
1584 : 69 : vec_safe_push (args, from_len);
1585 : 69 : vec_safe_push (args, to_len);
1586 : 69 : tmp = build_call_vec (fcn_type, fcn, args);
1587 : : /* Build the body of the loop. */
1588 : 69 : gfc_init_block (&loopbody);
1589 : 69 : gfc_add_expr_to_block (&loopbody, tmp);
1590 : :
1591 : : /* Build the loop and return. */
1592 : 69 : gfc_init_loopinfo (&loop);
1593 : 69 : loop.dimen = 1;
1594 : 69 : loop.from[0] = gfc_index_zero_node;
1595 : 69 : loop.loopvar[0] = index;
1596 : 69 : loop.to[0] = nelems;
1597 : 69 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1598 : 69 : gfc_init_block (&ifbody);
1599 : 69 : gfc_add_block_to_block (&ifbody, &loop.pre);
1600 : 69 : extcopy = gfc_finish_block (&ifbody);
1601 : :
1602 : 69 : tmp = fold_build2_loc (input_location, GT_EXPR,
1603 : : logical_type_node, from_len,
1604 : 69 : build_zero_cst (TREE_TYPE (from_len)));
1605 : 69 : tmp = fold_build3_loc (input_location, COND_EXPR,
1606 : : void_type_node, tmp, extcopy, stdcopy);
1607 : 69 : gfc_add_expr_to_block (&body, tmp);
1608 : 69 : tmp = gfc_finish_block (&body);
1609 : : }
1610 : : else
1611 : : {
1612 : 198 : gfc_add_expr_to_block (&body, stdcopy);
1613 : 198 : tmp = gfc_finish_block (&body);
1614 : : }
1615 : 267 : gfc_cleanup_loop (&loop);
1616 : : }
1617 : : else
1618 : : {
1619 : 352 : gcc_assert (!is_from_desc);
1620 : 352 : vec_safe_push (args, from_data);
1621 : 352 : vec_safe_push (args, to_data);
1622 : 352 : stdcopy = build_call_vec (fcn_type, fcn, args);
1623 : :
1624 : : /* In initialization mode from_len is a constant zero. */
1625 : 352 : if (unlimited && !integer_zerop (from_len))
1626 : : {
1627 : 58 : vec_safe_push (args, from_len);
1628 : 58 : vec_safe_push (args, to_len);
1629 : 58 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1630 : 58 : tmp = fold_build2_loc (input_location, GT_EXPR,
1631 : : logical_type_node, from_len,
1632 : 58 : build_zero_cst (TREE_TYPE (from_len)));
1633 : 58 : tmp = fold_build3_loc (input_location, COND_EXPR,
1634 : : void_type_node, tmp, extcopy, stdcopy);
1635 : : }
1636 : : else
1637 : : tmp = stdcopy;
1638 : : }
1639 : :
1640 : : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1641 : 619 : if (from == NULL_TREE)
1642 : : {
1643 : 0 : tree cond;
1644 : 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1645 : : logical_type_node,
1646 : : from_data, null_pointer_node);
1647 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1648 : : void_type_node, cond,
1649 : : tmp, build_empty_stmt (input_location));
1650 : : }
1651 : :
1652 : 619 : return tmp;
1653 : : }
1654 : :
1655 : :
1656 : : static tree
1657 : 93 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1658 : : {
1659 : 93 : gfc_actual_arglist *actual;
1660 : 93 : gfc_expr *ppc;
1661 : 93 : gfc_code *ppc_code;
1662 : 93 : tree res;
1663 : :
1664 : 93 : actual = gfc_get_actual_arglist ();
1665 : 93 : actual->expr = gfc_copy_expr (rhs);
1666 : 93 : actual->next = gfc_get_actual_arglist ();
1667 : 93 : actual->next->expr = gfc_copy_expr (lhs);
1668 : 93 : ppc = gfc_copy_expr (obj);
1669 : 93 : gfc_add_vptr_component (ppc);
1670 : 93 : gfc_add_component_ref (ppc, "_copy");
1671 : 93 : ppc_code = gfc_get_code (EXEC_CALL);
1672 : 93 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1673 : : /* Although '_copy' is set to be elemental in class.cc, it is
1674 : : not staying that way. Find out why, sometime.... */
1675 : 93 : ppc_code->resolved_sym->attr.elemental = 1;
1676 : 93 : ppc_code->ext.actual = actual;
1677 : 93 : ppc_code->expr1 = ppc;
1678 : : /* Since '_copy' is elemental, the scalarizer will take care
1679 : : of arrays in gfc_trans_call. */
1680 : 93 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1681 : 93 : gfc_free_statements (ppc_code);
1682 : :
1683 : 93 : if (UNLIMITED_POLY(obj))
1684 : : {
1685 : : /* Check if rhs is non-NULL. */
1686 : 18 : gfc_se src;
1687 : 18 : gfc_init_se (&src, NULL);
1688 : 18 : gfc_conv_expr (&src, rhs);
1689 : 18 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1690 : 18 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1691 : 18 : src.expr, fold_convert (TREE_TYPE (src.expr),
1692 : : null_pointer_node));
1693 : 18 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1694 : : build_empty_stmt (input_location));
1695 : : }
1696 : :
1697 : 93 : return res;
1698 : : }
1699 : :
1700 : : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1701 : : A MEMCPY is needed to copy the full data from the default initializer
1702 : : of the dynamic type. */
1703 : :
1704 : : tree
1705 : 380 : gfc_trans_class_init_assign (gfc_code *code)
1706 : : {
1707 : 380 : stmtblock_t block;
1708 : 380 : tree tmp;
1709 : 380 : gfc_se dst,src,memsz;
1710 : 380 : gfc_expr *lhs, *rhs, *sz;
1711 : :
1712 : 380 : gfc_start_block (&block);
1713 : :
1714 : 380 : lhs = gfc_copy_expr (code->expr1);
1715 : :
1716 : 380 : rhs = gfc_copy_expr (code->expr1);
1717 : 380 : gfc_add_vptr_component (rhs);
1718 : :
1719 : : /* Make sure that the component backend_decls have been built, which
1720 : : will not have happened if the derived types concerned have not
1721 : : been referenced. */
1722 : 380 : gfc_get_derived_type (rhs->ts.u.derived);
1723 : 380 : gfc_add_def_init_component (rhs);
1724 : : /* The _def_init is always scalar. */
1725 : 380 : rhs->rank = 0;
1726 : :
1727 : 380 : if (code->expr1->ts.type == BT_CLASS
1728 : 359 : && CLASS_DATA (code->expr1)->attr.dimension)
1729 : : {
1730 : 93 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1731 : 93 : *tmparr = *CLASS_DATA (code->expr1)->as;
1732 : : /* Adding the array ref to the class expression results in correct
1733 : : indexing to the dynamic type. */
1734 : 93 : gfc_add_full_array_ref (lhs, tmparr);
1735 : 93 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1736 : 93 : }
1737 : : else
1738 : : {
1739 : : /* Scalar initialization needs the _data component. */
1740 : 287 : gfc_add_data_component (lhs);
1741 : 287 : sz = gfc_copy_expr (code->expr1);
1742 : 287 : gfc_add_vptr_component (sz);
1743 : 287 : gfc_add_size_component (sz);
1744 : :
1745 : 287 : gfc_init_se (&dst, NULL);
1746 : 287 : gfc_init_se (&src, NULL);
1747 : 287 : gfc_init_se (&memsz, NULL);
1748 : 287 : gfc_conv_expr (&dst, lhs);
1749 : 287 : gfc_conv_expr (&src, rhs);
1750 : 287 : gfc_conv_expr (&memsz, sz);
1751 : 287 : gfc_add_block_to_block (&block, &src.pre);
1752 : 287 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1753 : :
1754 : 287 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1755 : :
1756 : 287 : if (UNLIMITED_POLY(code->expr1))
1757 : : {
1758 : : /* Check if _def_init is non-NULL. */
1759 : 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1760 : : logical_type_node, src.expr,
1761 : 7 : fold_convert (TREE_TYPE (src.expr),
1762 : : null_pointer_node));
1763 : 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1764 : : tmp, build_empty_stmt (input_location));
1765 : : }
1766 : : }
1767 : :
1768 : 380 : if (code->expr1->symtree->n.sym->attr.dummy
1769 : 329 : && (code->expr1->symtree->n.sym->attr.optional
1770 : 323 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1771 : : {
1772 : 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1773 : 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1774 : : present, tmp,
1775 : : build_empty_stmt (input_location));
1776 : : }
1777 : :
1778 : 380 : gfc_add_expr_to_block (&block, tmp);
1779 : :
1780 : 380 : return gfc_finish_block (&block);
1781 : : }
1782 : :
1783 : :
1784 : : /* Class valued elemental function calls or class array elements arriving
1785 : : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1786 : : is used to ensure that the rhs dynamic type is assigned to the lhs. */
1787 : :
1788 : : static bool
1789 : 606 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1790 : : {
1791 : 606 : tree fcn;
1792 : 606 : tree rse_expr;
1793 : 606 : tree class_data;
1794 : 606 : tree tmp;
1795 : 606 : tree zero;
1796 : 606 : tree cond;
1797 : 606 : tree final_cond;
1798 : 606 : stmtblock_t inner_block;
1799 : 606 : bool is_descriptor;
1800 : 606 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1801 : 606 : bool not_lhs_array_type;
1802 : :
1803 : : /* Temporaries arising from dependencies in assignment get cast as a
1804 : : character type of the dynamic size of the rhs. Use the vptr copy
1805 : : for this case. */
1806 : 606 : tmp = TREE_TYPE (lse->expr);
1807 : 606 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1808 : 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1809 : :
1810 : : /* Use ordinary assignment if the rhs is not a call expression or
1811 : : the lhs is not a class entity or an array(ie. character) type. */
1812 : 576 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
1813 : 824 : && not_lhs_array_type)
1814 : : return false;
1815 : :
1816 : : /* Ordinary assignment can be used if both sides are class expressions
1817 : : since the dynamic type is preserved by copying the vptr. This
1818 : : should only occur, where temporaries are involved. */
1819 : 388 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1820 : 388 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1821 : : return false;
1822 : :
1823 : : /* Fix the class expression and the class data of the rhs. */
1824 : 351 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1825 : 351 : || not_call_expr)
1826 : : {
1827 : 351 : tmp = gfc_get_class_from_expr (rse->expr);
1828 : 351 : if (tmp == NULL_TREE)
1829 : : return false;
1830 : 116 : rse_expr = gfc_evaluate_now (tmp, block);
1831 : : }
1832 : : else
1833 : 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
1834 : :
1835 : 116 : class_data = gfc_class_data_get (rse_expr);
1836 : :
1837 : : /* Check that the rhs data is not null. */
1838 : 116 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1839 : 116 : if (is_descriptor)
1840 : 116 : class_data = gfc_conv_descriptor_data_get (class_data);
1841 : 116 : class_data = gfc_evaluate_now (class_data, block);
1842 : :
1843 : 116 : zero = build_int_cst (TREE_TYPE (class_data), 0);
1844 : 116 : cond = fold_build2_loc (input_location, NE_EXPR,
1845 : : logical_type_node,
1846 : : class_data, zero);
1847 : :
1848 : : /* Copy the rhs to the lhs. */
1849 : 116 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
1850 : 116 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
1851 : 116 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
1852 : 116 : tmp = is_descriptor ? tmp : class_data;
1853 : 116 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1854 : : gfc_build_addr_expr (NULL, lse->expr));
1855 : 116 : gfc_add_expr_to_block (block, tmp);
1856 : :
1857 : : /* Only elemental function results need to be finalised and freed. */
1858 : 116 : if (not_call_expr)
1859 : : return true;
1860 : :
1861 : : /* Finalize the class data if needed. */
1862 : 0 : gfc_init_block (&inner_block);
1863 : 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
1864 : 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
1865 : 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
1866 : : logical_type_node, fcn, zero);
1867 : 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
1868 : 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
1869 : 0 : tmp = build3_v (COND_EXPR, final_cond,
1870 : : tmp, build_empty_stmt (input_location));
1871 : 0 : gfc_add_expr_to_block (&inner_block, tmp);
1872 : :
1873 : : /* Free the class data. */
1874 : 0 : tmp = gfc_call_free (class_data);
1875 : 0 : tmp = build3_v (COND_EXPR, cond, tmp,
1876 : : build_empty_stmt (input_location));
1877 : 0 : gfc_add_expr_to_block (&inner_block, tmp);
1878 : :
1879 : : /* Finish the inner block and subject it to the condition on the
1880 : : class data being non-zero. */
1881 : 0 : tmp = gfc_finish_block (&inner_block);
1882 : 0 : tmp = build3_v (COND_EXPR, cond, tmp,
1883 : : build_empty_stmt (input_location));
1884 : 0 : gfc_add_expr_to_block (block, tmp);
1885 : :
1886 : 0 : return true;
1887 : : }
1888 : :
1889 : : /* End of prototype trans-class.c */
1890 : :
1891 : :
1892 : : static void
1893 : 6188 : realloc_lhs_warning (bt type, bool array, locus *where)
1894 : : {
1895 : 6188 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1896 : 35 : gfc_warning (OPT_Wrealloc_lhs,
1897 : : "Code for reallocating the allocatable array at %L will "
1898 : : "be added", where);
1899 : 6153 : else if (warn_realloc_lhs_all)
1900 : 4 : gfc_warning (OPT_Wrealloc_lhs_all,
1901 : : "Code for reallocating the allocatable variable at %L "
1902 : : "will be added", where);
1903 : 6188 : }
1904 : :
1905 : :
1906 : : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1907 : : gfc_expr *);
1908 : :
1909 : : /* Copy the scalarization loop variables. */
1910 : :
1911 : : static void
1912 : 898131 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1913 : : {
1914 : 898131 : dest->ss = src->ss;
1915 : 898131 : dest->loop = src->loop;
1916 : 898131 : }
1917 : :
1918 : :
1919 : : /* Initialize a simple expression holder.
1920 : :
1921 : : Care must be taken when multiple se are created with the same parent.
1922 : : The child se must be kept in sync. The easiest way is to delay creation
1923 : : of a child se until after the previous se has been translated. */
1924 : :
1925 : : void
1926 : 3400092 : gfc_init_se (gfc_se * se, gfc_se * parent)
1927 : : {
1928 : 3400092 : memset (se, 0, sizeof (gfc_se));
1929 : 3400092 : gfc_init_block (&se->pre);
1930 : 3400092 : gfc_init_block (&se->finalblock);
1931 : 3400092 : gfc_init_block (&se->post);
1932 : :
1933 : 3400092 : se->parent = parent;
1934 : :
1935 : 3400092 : if (parent)
1936 : 898131 : gfc_copy_se_loopvars (se, parent);
1937 : 3400092 : }
1938 : :
1939 : :
1940 : : /* Advances to the next SS in the chain. Use this rather than setting
1941 : : se->ss = se->ss->next because all the parents needs to be kept in sync.
1942 : : See gfc_init_se. */
1943 : :
1944 : : void
1945 : 178124 : gfc_advance_se_ss_chain (gfc_se * se)
1946 : : {
1947 : 178124 : gfc_se *p;
1948 : 178124 : gfc_ss *ss;
1949 : :
1950 : 178124 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1951 : :
1952 : : p = se;
1953 : : /* Walk down the parent chain. */
1954 : 458299 : while (p != NULL)
1955 : : {
1956 : : /* Simple consistency check. */
1957 : 280175 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1958 : : || p->parent->ss->nested_ss == p->ss);
1959 : :
1960 : : /* If we were in a nested loop, the next scalarized expression can be
1961 : : on the parent ss' next pointer. Thus we should not take the next
1962 : : pointer blindly, but rather go up one nest level as long as next
1963 : : is the end of chain. */
1964 : 280175 : ss = p->ss;
1965 : 281395 : while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1966 : : ss = ss->parent;
1967 : :
1968 : 280175 : p->ss = ss->next;
1969 : :
1970 : 280175 : p = p->parent;
1971 : : }
1972 : 178124 : }
1973 : :
1974 : :
1975 : : /* Ensures the result of the expression as either a temporary variable
1976 : : or a constant so that it can be used repeatedly. */
1977 : :
1978 : : void
1979 : 7888 : gfc_make_safe_expr (gfc_se * se)
1980 : : {
1981 : 7888 : tree var;
1982 : :
1983 : 7888 : if (CONSTANT_CLASS_P (se->expr))
1984 : : return;
1985 : :
1986 : : /* We need a temporary for this result. */
1987 : 202 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1988 : 202 : gfc_add_modify (&se->pre, var, se->expr);
1989 : 202 : se->expr = var;
1990 : : }
1991 : :
1992 : :
1993 : : /* Return an expression which determines if a dummy parameter is present.
1994 : : Also used for arguments to procedures with multiple entry points. */
1995 : :
1996 : : tree
1997 : 7454 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
1998 : : {
1999 : 7454 : tree decl, orig_decl, cond;
2000 : :
2001 : 7454 : gcc_assert (sym->attr.dummy);
2002 : 7454 : orig_decl = decl = gfc_get_symbol_decl (sym);
2003 : :
2004 : : /* Intrinsic scalars with VALUE attribute which are passed by value
2005 : : use a hidden argument to denote the present status. */
2006 : 7454 : if (sym->attr.value && !sym->attr.dimension
2007 : 490 : && sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type))
2008 : : {
2009 : 490 : char name[GFC_MAX_SYMBOL_LEN + 2];
2010 : 490 : tree tree_name;
2011 : :
2012 : 490 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2013 : 490 : name[0] = '.';
2014 : 490 : strcpy (&name[1], sym->name);
2015 : 490 : tree_name = get_identifier (name);
2016 : :
2017 : : /* Walk function argument list to find hidden arg. */
2018 : 490 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2019 : 3308 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2020 : 3308 : if (DECL_NAME (cond) == tree_name
2021 : 3308 : && DECL_ARTIFICIAL (cond))
2022 : : break;
2023 : :
2024 : 490 : gcc_assert (cond);
2025 : 490 : return cond;
2026 : : }
2027 : :
2028 : : /* Assumed-shape arrays use a local variable for the array data;
2029 : : the actual PARAM_DECL is in a saved decl. As the local variable
2030 : : is NULL, it can be checked instead, unless use_saved_desc is
2031 : : requested. */
2032 : :
2033 : 6964 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2034 : : {
2035 : 615 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2036 : : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2037 : 615 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2038 : : }
2039 : :
2040 : 6964 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2041 : 6964 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2042 : :
2043 : : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2044 : : as actual argument to denote absent dummies. For array descriptors,
2045 : : we thus also need to check the array descriptor. For BT_CLASS, it
2046 : : can also occur for scalars and F2003 due to type->class wrapping and
2047 : : class->class wrapping. Note further that BT_CLASS always uses an
2048 : : array descriptor for arrays, also for explicit-shape/assumed-size.
2049 : : For assumed-rank arrays, no local variable is generated, hence,
2050 : : the following also applies with !use_saved_desc. */
2051 : :
2052 : 6964 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2053 : 5240 : && !sym->attr.allocatable
2054 : 4433 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2055 : 1942 : || (sym->ts.type == BT_CLASS
2056 : 990 : && !CLASS_DATA (sym)->attr.allocatable
2057 : 990 : && !CLASS_DATA (sym)->attr.class_pointer))
2058 : 2743 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2059 : 6 : || sym->ts.type == BT_CLASS))
2060 : : {
2061 : 2737 : tree tmp;
2062 : :
2063 : 2737 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2064 : 942 : || sym->as->type == AS_ASSUMED_RANK
2065 : 871 : || sym->attr.codimension))
2066 : 2084 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2067 : : {
2068 : 869 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2069 : 869 : if (sym->ts.type == BT_CLASS)
2070 : 216 : tmp = gfc_class_data_get (tmp);
2071 : 869 : tmp = gfc_conv_array_data (tmp);
2072 : : }
2073 : 1868 : else if (sym->ts.type == BT_CLASS)
2074 : 36 : tmp = gfc_class_data_get (decl);
2075 : : else
2076 : : tmp = NULL_TREE;
2077 : :
2078 : 905 : if (tmp != NULL_TREE)
2079 : : {
2080 : 905 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2081 : 905 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2082 : 905 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2083 : : logical_type_node, cond, tmp);
2084 : : }
2085 : : }
2086 : :
2087 : : return cond;
2088 : : }
2089 : :
2090 : :
2091 : : /* Converts a missing, dummy argument into a null or zero. */
2092 : :
2093 : : void
2094 : 310 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2095 : : {
2096 : 310 : tree present;
2097 : 310 : tree tmp;
2098 : :
2099 : 310 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2100 : :
2101 : 310 : if (kind > 0)
2102 : : {
2103 : : /* Create a temporary and convert it to the correct type. */
2104 : 54 : tmp = gfc_get_int_type (kind);
2105 : 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2106 : : se->expr));
2107 : :
2108 : : /* Test for a NULL value. */
2109 : 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2110 : 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2111 : 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2112 : 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2113 : : }
2114 : : else
2115 : : {
2116 : 256 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2117 : : present, se->expr,
2118 : 256 : build_zero_cst (TREE_TYPE (se->expr)));
2119 : 256 : tmp = gfc_evaluate_now (tmp, &se->pre);
2120 : 256 : se->expr = tmp;
2121 : : }
2122 : :
2123 : 310 : if (ts.type == BT_CHARACTER)
2124 : : {
2125 : 6 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2126 : 6 : tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
2127 : : present, se->string_length, tmp);
2128 : 6 : tmp = gfc_evaluate_now (tmp, &se->pre);
2129 : 6 : se->string_length = tmp;
2130 : : }
2131 : 310 : return;
2132 : : }
2133 : :
2134 : :
2135 : : /* Get the character length of an expression, looking through gfc_refs
2136 : : if necessary. */
2137 : :
2138 : : tree
2139 : 17259 : gfc_get_expr_charlen (gfc_expr *e)
2140 : : {
2141 : 17259 : gfc_ref *r;
2142 : 17259 : tree length;
2143 : 17259 : tree previous = NULL_TREE;
2144 : 17259 : gfc_se se;
2145 : :
2146 : 17259 : gcc_assert (e->expr_type == EXPR_VARIABLE
2147 : : && e->ts.type == BT_CHARACTER);
2148 : :
2149 : 17259 : length = NULL; /* To silence compiler warning. */
2150 : :
2151 : 17259 : if (is_subref_array (e) && e->ts.u.cl->length)
2152 : : {
2153 : 742 : gfc_se tmpse;
2154 : 742 : gfc_init_se (&tmpse, NULL);
2155 : 742 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2156 : 742 : e->ts.u.cl->backend_decl = tmpse.expr;
2157 : 742 : return tmpse.expr;
2158 : : }
2159 : :
2160 : : /* First candidate: if the variable is of type CHARACTER, the
2161 : : expression's length could be the length of the character
2162 : : variable. */
2163 : 16517 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2164 : 16261 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2165 : :
2166 : : /* Look through the reference chain for component references. */
2167 : 33127 : for (r = e->ref; r; r = r->next)
2168 : : {
2169 : 16610 : previous = length;
2170 : 16610 : switch (r->type)
2171 : : {
2172 : 256 : case REF_COMPONENT:
2173 : 256 : if (r->u.c.component->ts.type == BT_CHARACTER)
2174 : 256 : length = r->u.c.component->ts.u.cl->backend_decl;
2175 : : break;
2176 : :
2177 : : case REF_ARRAY:
2178 : : /* Do nothing. */
2179 : : break;
2180 : :
2181 : 12 : case REF_SUBSTRING:
2182 : 12 : gfc_init_se (&se, NULL);
2183 : 12 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2184 : 12 : length = se.expr;
2185 : 12 : if (r->u.ss.end)
2186 : 6 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2187 : : else
2188 : 6 : se.expr = previous;
2189 : 12 : length = fold_build2_loc (input_location, MINUS_EXPR,
2190 : : gfc_charlen_type_node,
2191 : : se.expr, length);
2192 : 12 : length = fold_build2_loc (input_location, PLUS_EXPR,
2193 : : gfc_charlen_type_node, length,
2194 : : gfc_index_one_node);
2195 : 12 : break;
2196 : :
2197 : 0 : default:
2198 : 0 : gcc_unreachable ();
2199 : 16610 : break;
2200 : : }
2201 : : }
2202 : :
2203 : 16517 : gcc_assert (length != NULL);
2204 : : return length;
2205 : : }
2206 : :
2207 : :
2208 : : /* Return for an expression the backend decl of the coarray. */
2209 : :
2210 : : tree
2211 : 1432 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2212 : : {
2213 : 1432 : tree caf_decl;
2214 : 1432 : bool found = false;
2215 : 1432 : gfc_ref *ref;
2216 : :
2217 : 1432 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2218 : :
2219 : : /* Not-implemented diagnostic. */
2220 : 1432 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2221 : 17 : && UNLIMITED_POLY (expr->symtree->n.sym)
2222 : 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2223 : 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2224 : : "%L is not supported", &expr->where);
2225 : :
2226 : 4893 : for (ref = expr->ref; ref; ref = ref->next)
2227 : 3461 : if (ref->type == REF_COMPONENT)
2228 : : {
2229 : 1312 : if (ref->u.c.component->ts.type == BT_CLASS
2230 : 0 : && UNLIMITED_POLY (ref->u.c.component)
2231 : 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2232 : 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2233 : : "component at %L is not supported", &expr->where);
2234 : : }
2235 : :
2236 : : /* Make sure the backend_decl is present before accessing it. */
2237 : 2864 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2238 : 1432 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2239 : : : expr->symtree->n.sym->backend_decl;
2240 : :
2241 : 1432 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2242 : : {
2243 : 17 : if (expr->ref && expr->ref->type == REF_ARRAY)
2244 : : {
2245 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2246 : 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2247 : : return caf_decl;
2248 : : }
2249 : 37 : for (ref = expr->ref; ref; ref = ref->next)
2250 : : {
2251 : 34 : if (ref->type == REF_COMPONENT
2252 : 17 : && strcmp (ref->u.c.component->name, "_data") != 0)
2253 : : {
2254 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2255 : 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2256 : : return caf_decl;
2257 : : break;
2258 : : }
2259 : 34 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2260 : : break;
2261 : : }
2262 : : }
2263 : 1432 : if (expr->symtree->n.sym->attr.codimension)
2264 : : return caf_decl;
2265 : :
2266 : : /* The following code assumes that the coarray is a component reachable via
2267 : : only scalar components/variables; the Fortran standard guarantees this. */
2268 : :
2269 : 35 : for (ref = expr->ref; ref; ref = ref->next)
2270 : 35 : if (ref->type == REF_COMPONENT)
2271 : : {
2272 : 35 : gfc_component *comp = ref->u.c.component;
2273 : :
2274 : 35 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2275 : 12 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2276 : 35 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2277 : 35 : TREE_TYPE (comp->backend_decl), caf_decl,
2278 : : comp->backend_decl, NULL_TREE);
2279 : 35 : if (comp->ts.type == BT_CLASS)
2280 : : {
2281 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2282 : 0 : if (CLASS_DATA (comp)->attr.codimension)
2283 : : {
2284 : : found = true;
2285 : : break;
2286 : : }
2287 : : }
2288 : 35 : if (comp->attr.codimension)
2289 : : {
2290 : : found = true;
2291 : : break;
2292 : : }
2293 : : }
2294 : 35 : gcc_assert (found && caf_decl);
2295 : : return caf_decl;
2296 : : }
2297 : :
2298 : :
2299 : : /* Obtain the Coarray token - and optionally also the offset. */
2300 : :
2301 : : void
2302 : 1353 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2303 : : tree se_expr, gfc_expr *expr)
2304 : : {
2305 : 1353 : tree tmp;
2306 : :
2307 : : /* Coarray token. */
2308 : 1353 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2309 : : {
2310 : 264 : gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
2311 : : == GFC_ARRAY_ALLOCATABLE
2312 : : || expr->symtree->n.sym->attr.select_type_temporary);
2313 : 264 : *token = gfc_conv_descriptor_token (caf_decl);
2314 : : }
2315 : 1089 : else if (DECL_LANG_SPECIFIC (caf_decl)
2316 : 1089 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2317 : 3 : *token = GFC_DECL_TOKEN (caf_decl);
2318 : : else
2319 : : {
2320 : 1086 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2321 : : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2322 : 1086 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2323 : : }
2324 : :
2325 : 1353 : if (offset == NULL)
2326 : : return;
2327 : :
2328 : : /* Offset between the coarray base address and the address wanted. */
2329 : 468 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2330 : 468 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2331 : 48 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2332 : 79 : *offset = build_int_cst (gfc_array_index_type, 0);
2333 : 389 : else if (DECL_LANG_SPECIFIC (caf_decl)
2334 : 389 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2335 : 3 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2336 : 386 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2337 : 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2338 : : else
2339 : 386 : *offset = build_int_cst (gfc_array_index_type, 0);
2340 : :
2341 : 468 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2342 : 468 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2343 : : {
2344 : 377 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2345 : 377 : tmp = gfc_conv_descriptor_data_get (tmp);
2346 : : }
2347 : 91 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2348 : 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2349 : : else
2350 : : {
2351 : 91 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2352 : : tmp = se_expr;
2353 : : }
2354 : :
2355 : 468 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2356 : : *offset, fold_convert (gfc_array_index_type, tmp));
2357 : :
2358 : 468 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2359 : 115 : && expr->symtree->n.sym->attr.codimension
2360 : 115 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2361 : : {
2362 : 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2363 : 0 : gfc_ref *ref = base_expr->ref;
2364 : 0 : gfc_se base_se;
2365 : :
2366 : : // Iterate through the refs until the last one.
2367 : 0 : while (ref->next)
2368 : : ref = ref->next;
2369 : :
2370 : 0 : if (ref->type == REF_ARRAY
2371 : 0 : && ref->u.ar.type != AR_FULL)
2372 : : {
2373 : 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2374 : 0 : int i;
2375 : 0 : for (i = 0; i < ranksum; ++i)
2376 : : {
2377 : 0 : ref->u.ar.start[i] = NULL;
2378 : 0 : ref->u.ar.end[i] = NULL;
2379 : : }
2380 : 0 : ref->u.ar.type = AR_FULL;
2381 : : }
2382 : 0 : gfc_init_se (&base_se, NULL);
2383 : 0 : if (gfc_caf_attr (base_expr).dimension)
2384 : : {
2385 : 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2386 : 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2387 : : }
2388 : : else
2389 : : {
2390 : 0 : gfc_conv_expr (&base_se, base_expr);
2391 : 0 : tmp = base_se.expr;
2392 : : }
2393 : :
2394 : 0 : gfc_free_expr (base_expr);
2395 : 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2396 : 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2397 : 0 : }
2398 : 468 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2399 : 97 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2400 : : else
2401 : : {
2402 : 371 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2403 : : tmp = caf_decl;
2404 : : }
2405 : :
2406 : 468 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2407 : : fold_convert (gfc_array_index_type, *offset),
2408 : : fold_convert (gfc_array_index_type, tmp));
2409 : : }
2410 : :
2411 : :
2412 : : /* Convert the coindex of a coarray into an image index; the result is
2413 : : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2414 : : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2415 : :
2416 : : tree
2417 : 1151 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2418 : : {
2419 : 1151 : gfc_ref *ref;
2420 : 1151 : tree lbound, ubound, extent, tmp, img_idx;
2421 : 1151 : gfc_se se;
2422 : 1151 : int i;
2423 : :
2424 : 1175 : for (ref = e->ref; ref; ref = ref->next)
2425 : 1175 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2426 : : break;
2427 : 1151 : gcc_assert (ref != NULL);
2428 : :
2429 : 1151 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2430 : : {
2431 : 6 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2432 : 6 : integer_zero_node);
2433 : : }
2434 : :
2435 : 1145 : img_idx = build_zero_cst (gfc_array_index_type);
2436 : 1145 : extent = build_one_cst (gfc_array_index_type);
2437 : 1145 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2438 : 366 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2439 : : {
2440 : 183 : gfc_init_se (&se, NULL);
2441 : 183 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2442 : 183 : gfc_add_block_to_block (block, &se.pre);
2443 : 183 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2444 : 183 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2445 : 183 : TREE_TYPE (lbound), se.expr, lbound);
2446 : 183 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2447 : : extent, tmp);
2448 : 183 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2449 : 183 : TREE_TYPE (tmp), img_idx, tmp);
2450 : 183 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2451 : : {
2452 : 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2453 : 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2454 : 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
2455 : 0 : TREE_TYPE (tmp), extent, tmp);
2456 : : }
2457 : : }
2458 : : else
2459 : 1932 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2460 : : {
2461 : 970 : gfc_init_se (&se, NULL);
2462 : 970 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2463 : 970 : gfc_add_block_to_block (block, &se.pre);
2464 : 970 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2465 : 970 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2466 : 970 : TREE_TYPE (lbound), se.expr, lbound);
2467 : 970 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2468 : : extent, tmp);
2469 : 970 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2470 : : img_idx, tmp);
2471 : 970 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2472 : : {
2473 : 8 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2474 : 8 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2475 : 8 : TREE_TYPE (ubound), ubound, lbound);
2476 : 8 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2477 : 8 : tmp, build_one_cst (TREE_TYPE (tmp)));
2478 : 8 : extent = fold_build2_loc (input_location, MULT_EXPR,
2479 : 8 : TREE_TYPE (tmp), extent, tmp);
2480 : : }
2481 : : }
2482 : 1145 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2483 : 1145 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2484 : 1145 : return fold_convert (integer_type_node, img_idx);
2485 : : }
2486 : :
2487 : :
2488 : : /* For each character array constructor subexpression without a ts.u.cl->length,
2489 : : replace it by its first element (if there aren't any elements, the length
2490 : : should already be set to zero). */
2491 : :
2492 : : static void
2493 : 123 : flatten_array_ctors_without_strlen (gfc_expr* e)
2494 : : {
2495 : 123 : gfc_actual_arglist* arg;
2496 : 123 : gfc_constructor* c;
2497 : :
2498 : 123 : if (!e)
2499 : : return;
2500 : :
2501 : 123 : switch (e->expr_type)
2502 : : {
2503 : :
2504 : 0 : case EXPR_OP:
2505 : 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2506 : 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2507 : 0 : break;
2508 : :
2509 : 0 : case EXPR_COMPCALL:
2510 : : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2511 : 0 : gcc_unreachable ();
2512 : :
2513 : 12 : case EXPR_FUNCTION:
2514 : 36 : for (arg = e->value.function.actual; arg; arg = arg->next)
2515 : 24 : flatten_array_ctors_without_strlen (arg->expr);
2516 : : break;
2517 : :
2518 : 0 : case EXPR_ARRAY:
2519 : :
2520 : : /* We've found what we're looking for. */
2521 : 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2522 : : {
2523 : 0 : gfc_constructor *c;
2524 : 0 : gfc_expr* new_expr;
2525 : :
2526 : 0 : gcc_assert (e->value.constructor);
2527 : :
2528 : 0 : c = gfc_constructor_first (e->value.constructor);
2529 : 0 : new_expr = c->expr;
2530 : 0 : c->expr = NULL;
2531 : :
2532 : 0 : flatten_array_ctors_without_strlen (new_expr);
2533 : 0 : gfc_replace_expr (e, new_expr);
2534 : 0 : break;
2535 : : }
2536 : :
2537 : : /* Otherwise, fall through to handle constructor elements. */
2538 : 0 : gcc_fallthrough ();
2539 : 0 : case EXPR_STRUCTURE:
2540 : 0 : for (c = gfc_constructor_first (e->value.constructor);
2541 : 0 : c; c = gfc_constructor_next (c))
2542 : 0 : flatten_array_ctors_without_strlen (c->expr);
2543 : : break;
2544 : :
2545 : : default:
2546 : : break;
2547 : :
2548 : : }
2549 : : }
2550 : :
2551 : :
2552 : : /* Generate code to initialize a string length variable. Returns the
2553 : : value. For array constructors, cl->length might be NULL and in this case,
2554 : : the first element of the constructor is needed. expr is the original
2555 : : expression so we can access it but can be NULL if this is not needed. */
2556 : :
2557 : : void
2558 : 3137 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2559 : : {
2560 : 3137 : gfc_se se;
2561 : :
2562 : 3137 : gfc_init_se (&se, NULL);
2563 : :
2564 : 3137 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2565 : 991 : return;
2566 : :
2567 : : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2568 : : "flatten" array constructors by taking their first element; all elements
2569 : : should be the same length or a cl->length should be present. */
2570 : 2162 : if (!cl->length)
2571 : : {
2572 : 115 : gfc_expr* expr_flat;
2573 : 115 : if (!expr)
2574 : : return;
2575 : 99 : expr_flat = gfc_copy_expr (expr);
2576 : 99 : flatten_array_ctors_without_strlen (expr_flat);
2577 : 99 : gfc_resolve_expr (expr_flat);
2578 : 99 : if (expr_flat->rank)
2579 : 30 : gfc_conv_expr_descriptor (&se, expr_flat);
2580 : : else
2581 : 69 : gfc_conv_expr (&se, expr_flat);
2582 : 99 : if (expr_flat->expr_type != EXPR_VARIABLE)
2583 : 75 : gfc_add_block_to_block (pblock, &se.pre);
2584 : 99 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2585 : 99 : gfc_add_block_to_block (pblock, &se.post);
2586 : 99 : gfc_free_expr (expr_flat);
2587 : : }
2588 : : else
2589 : : {
2590 : : /* Convert cl->length. */
2591 : 2047 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2592 : 2047 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2593 : : gfc_charlen_type_node, se.expr,
2594 : 2047 : build_zero_cst (TREE_TYPE (se.expr)));
2595 : 2047 : gfc_add_block_to_block (pblock, &se.pre);
2596 : : }
2597 : :
2598 : 2146 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2599 : 1414 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2600 : : else
2601 : 732 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2602 : : }
2603 : :
2604 : :
2605 : : static void
2606 : 6371 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2607 : : const char *name, locus *where)
2608 : : {
2609 : 6371 : tree tmp;
2610 : 6371 : tree type;
2611 : 6371 : tree fault;
2612 : 6371 : gfc_se start;
2613 : 6371 : gfc_se end;
2614 : 6371 : char *msg;
2615 : 6371 : mpz_t length;
2616 : :
2617 : 6371 : type = gfc_get_character_type (kind, ref->u.ss.length);
2618 : 6371 : type = build_pointer_type (type);
2619 : :
2620 : 6371 : gfc_init_se (&start, se);
2621 : 6371 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2622 : 6371 : gfc_add_block_to_block (&se->pre, &start.pre);
2623 : :
2624 : 6371 : if (integer_onep (start.expr))
2625 : 2036 : gfc_conv_string_parameter (se);
2626 : : else
2627 : : {
2628 : 4335 : tmp = start.expr;
2629 : 4335 : STRIP_NOPS (tmp);
2630 : : /* Avoid multiple evaluation of substring start. */
2631 : 4335 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2632 : 1617 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2633 : :
2634 : : /* Change the start of the string. */
2635 : 4335 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2636 : 1070 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2637 : 4455 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2638 : : tmp = se->expr;
2639 : : else
2640 : 950 : tmp = build_fold_indirect_ref_loc (input_location,
2641 : : se->expr);
2642 : : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2643 : 4335 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2644 : : {
2645 : 4215 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2646 : 4215 : se->expr = gfc_build_addr_expr (type, tmp);
2647 : : }
2648 : : }
2649 : :
2650 : : /* Length = end + 1 - start. */
2651 : 6371 : gfc_init_se (&end, se);
2652 : 6371 : if (ref->u.ss.end == NULL)
2653 : 177 : end.expr = se->string_length;
2654 : : else
2655 : : {
2656 : 6194 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2657 : 6194 : gfc_add_block_to_block (&se->pre, &end.pre);
2658 : : }
2659 : 6371 : tmp = end.expr;
2660 : 6371 : STRIP_NOPS (tmp);
2661 : 6371 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2662 : 2243 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2663 : :
2664 : 6371 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2665 : 416 : && (ref->u.ss.start->symtree
2666 : 167 : && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
2667 : : {
2668 : 160 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2669 : : logical_type_node, start.expr,
2670 : : end.expr);
2671 : :
2672 : : /* Check lower bound. */
2673 : 160 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2674 : : start.expr,
2675 : 160 : build_one_cst (TREE_TYPE (start.expr)));
2676 : 160 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2677 : : logical_type_node, nonempty, fault);
2678 : 160 : if (name)
2679 : 159 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2680 : : "is less than one", name);
2681 : : else
2682 : 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2683 : : "is less than one");
2684 : 160 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2685 : : fold_convert (long_integer_type_node,
2686 : : start.expr));
2687 : 160 : free (msg);
2688 : :
2689 : : /* Check upper bound. */
2690 : 160 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2691 : : end.expr, se->string_length);
2692 : 160 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2693 : : logical_type_node, nonempty, fault);
2694 : 160 : if (name)
2695 : 159 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2696 : : "exceeds string length (%%ld)", name);
2697 : : else
2698 : 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2699 : : "exceeds string length (%%ld)");
2700 : 160 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2701 : : fold_convert (long_integer_type_node, end.expr),
2702 : : fold_convert (long_integer_type_node,
2703 : : se->string_length));
2704 : 160 : free (msg);
2705 : : }
2706 : :
2707 : : /* Try to calculate the length from the start and end expressions. */
2708 : 6371 : if (ref->u.ss.end
2709 : 6371 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2710 : : {
2711 : 5201 : HOST_WIDE_INT i_len;
2712 : :
2713 : 5201 : i_len = gfc_mpz_get_hwi (length) + 1;
2714 : 5201 : if (i_len < 0)
2715 : : i_len = 0;
2716 : :
2717 : 5201 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2718 : 5201 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2719 : : }
2720 : : else
2721 : : {
2722 : 1170 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2723 : : fold_convert (gfc_charlen_type_node, end.expr),
2724 : : fold_convert (gfc_charlen_type_node, start.expr));
2725 : 1170 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2726 : 1170 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2727 : 1170 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2728 : 1170 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2729 : : }
2730 : :
2731 : 6371 : se->string_length = tmp;
2732 : 6371 : }
2733 : :
2734 : :
2735 : : /* Convert a derived type component reference. */
2736 : :
2737 : : void
2738 : 139047 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2739 : : {
2740 : 139047 : gfc_component *c;
2741 : 139047 : tree tmp;
2742 : 139047 : tree decl;
2743 : 139047 : tree field;
2744 : 139047 : tree context;
2745 : :
2746 : 139047 : c = ref->u.c.component;
2747 : :
2748 : 139047 : if (c->backend_decl == NULL_TREE
2749 : 6 : && ref->u.c.sym != NULL)
2750 : 6 : gfc_get_derived_type (ref->u.c.sym);
2751 : :
2752 : 139047 : field = c->backend_decl;
2753 : 139047 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2754 : 139047 : decl = se->expr;
2755 : 139047 : context = DECL_FIELD_CONTEXT (field);
2756 : :
2757 : : /* Components can correspond to fields of different containing
2758 : : types, as components are created without context, whereas
2759 : : a concrete use of a component has the type of decl as context.
2760 : : So, if the type doesn't match, we search the corresponding
2761 : : FIELD_DECL in the parent type. To not waste too much time
2762 : : we cache this result in norestrict_decl.
2763 : : On the other hand, if the context is a UNION or a MAP (a
2764 : : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2765 : :
2766 : 139047 : if (context != TREE_TYPE (decl)
2767 : 139047 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2768 : 9090 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2769 : : {
2770 : 9090 : tree f2 = c->norestrict_decl;
2771 : 15709 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2772 : 4794 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2773 : 4794 : if (TREE_CODE (f2) == FIELD_DECL
2774 : 4794 : && DECL_NAME (f2) == DECL_NAME (field))
2775 : : break;
2776 : 9090 : gcc_assert (f2);
2777 : 9090 : c->norestrict_decl = f2;
2778 : 9090 : field = f2;
2779 : : }
2780 : :
2781 : 139047 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2782 : 0 : && strcmp ("_data", c->name) == 0)
2783 : : {
2784 : : /* Found a ref to the _data component. Store the associated ref to
2785 : : the vptr in se->class_vptr. */
2786 : 0 : se->class_vptr = gfc_class_vptr_get (decl);
2787 : : }
2788 : : else
2789 : 139047 : se->class_vptr = NULL_TREE;
2790 : :
2791 : 139047 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2792 : : decl, field, NULL_TREE);
2793 : :
2794 : 139047 : se->expr = tmp;
2795 : :
2796 : : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2797 : : strlen () conditional below. */
2798 : 139047 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2799 : 7567 : && !c->ts.deferred
2800 : 4985 : && !c->attr.pdt_string)
2801 : : {
2802 : 4859 : tmp = c->ts.u.cl->backend_decl;
2803 : : /* Components must always be constant length. */
2804 : 4859 : gcc_assert (tmp && INTEGER_CST_P (tmp));
2805 : 4859 : se->string_length = tmp;
2806 : : }
2807 : :
2808 : 139047 : if (gfc_deferred_strlen (c, &field))
2809 : : {
2810 : 2708 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2811 : 2708 : TREE_TYPE (field),
2812 : : decl, field, NULL_TREE);
2813 : 2708 : se->string_length = tmp;
2814 : : }
2815 : :
2816 : 139047 : if (((c->attr.pointer || c->attr.allocatable)
2817 : 79703 : && (!c->attr.dimension && !c->attr.codimension)
2818 : 48015 : && c->ts.type != BT_CHARACTER)
2819 : 92839 : || c->attr.proc_pointer)
2820 : 51001 : se->expr = build_fold_indirect_ref_loc (input_location,
2821 : : se->expr);
2822 : 139047 : }
2823 : :
2824 : :
2825 : : /* This function deals with component references to components of the
2826 : : parent type for derived type extensions. */
2827 : : void
2828 : 55912 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2829 : : {
2830 : 55912 : gfc_component *c;
2831 : 55912 : gfc_component *cmp;
2832 : 55912 : gfc_symbol *dt;
2833 : 55912 : gfc_ref parent;
2834 : :
2835 : 55912 : dt = ref->u.c.sym;
2836 : 55912 : c = ref->u.c.component;
2837 : :
2838 : : /* Return if the component is in this type, i.e. not in the parent type. */
2839 : 97477 : for (cmp = dt->components; cmp; cmp = cmp->next)
2840 : 88540 : if (c == cmp)
2841 : 46975 : return;
2842 : :
2843 : : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2844 : 8937 : parent.type = REF_COMPONENT;
2845 : 8937 : parent.next = NULL;
2846 : 8937 : parent.u.c.sym = dt;
2847 : 8937 : parent.u.c.component = dt->components;
2848 : :
2849 : 8937 : if (dt->backend_decl == NULL)
2850 : 0 : gfc_get_derived_type (dt);
2851 : :
2852 : : /* Build the reference and call self. */
2853 : 8937 : gfc_conv_component_ref (se, &parent);
2854 : 8937 : parent.u.c.sym = dt->components->ts.u.derived;
2855 : 8937 : parent.u.c.component = c;
2856 : 8937 : conv_parent_component_references (se, &parent);
2857 : : }
2858 : :
2859 : :
2860 : : static void
2861 : 234 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2862 : : {
2863 : 234 : tree res = se->expr;
2864 : :
2865 : 234 : switch (ref->u.i)
2866 : : {
2867 : 104 : case INQUIRY_RE:
2868 : 208 : res = fold_build1_loc (input_location, REALPART_EXPR,
2869 : 104 : TREE_TYPE (TREE_TYPE (res)), res);
2870 : 104 : break;
2871 : :
2872 : 103 : case INQUIRY_IM:
2873 : 206 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
2874 : 103 : TREE_TYPE (TREE_TYPE (res)), res);
2875 : 103 : break;
2876 : :
2877 : 7 : case INQUIRY_KIND:
2878 : 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2879 : 7 : ts->kind);
2880 : 7 : se->string_length = NULL_TREE;
2881 : 7 : break;
2882 : :
2883 : 20 : case INQUIRY_LEN:
2884 : 20 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2885 : : se->string_length);
2886 : 20 : se->string_length = NULL_TREE;
2887 : 20 : break;
2888 : :
2889 : 0 : default:
2890 : 0 : gcc_unreachable ();
2891 : : }
2892 : 234 : se->expr = res;
2893 : 234 : }
2894 : :
2895 : : /* Dereference VAR where needed if it is a pointer, reference, etc.
2896 : : according to Fortran semantics. */
2897 : :
2898 : : tree
2899 : 1022062 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
2900 : : bool is_classarray)
2901 : : {
2902 : 1022062 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
2903 : : return var;
2904 : 246078 : if (is_CFI_desc (sym, NULL))
2905 : 11780 : return build_fold_indirect_ref_loc (input_location, var);
2906 : :
2907 : : /* Characters are entirely different from other types, they are treated
2908 : : separately. */
2909 : 234298 : if (sym->ts.type == BT_CHARACTER)
2910 : : {
2911 : : /* Dereference character pointer dummy arguments
2912 : : or results. */
2913 : 26118 : if ((sym->attr.pointer || sym->attr.allocatable
2914 : 15678 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2915 : 10776 : && (sym->attr.dummy
2916 : : || sym->attr.function
2917 : 10776 : || sym->attr.result))
2918 : 3453 : var = build_fold_indirect_ref_loc (input_location, var);
2919 : : }
2920 : 208180 : else if (!sym->attr.value)
2921 : : {
2922 : : /* Dereference temporaries for class array dummy arguments. */
2923 : 146387 : if (sym->attr.dummy && is_classarray
2924 : 213349 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
2925 : : {
2926 : 4051 : if (!descriptor_only_p)
2927 : 2011 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
2928 : :
2929 : 4051 : var = build_fold_indirect_ref_loc (input_location, var);
2930 : : }
2931 : :
2932 : : /* Dereference non-character scalar dummy arguments. */
2933 : 207503 : if (sym->attr.dummy && !sym->attr.dimension
2934 : 90277 : && !(sym->attr.codimension && sym->attr.allocatable)
2935 : 90215 : && (sym->ts.type != BT_CLASS
2936 : 16379 : || (!CLASS_DATA (sym)->attr.dimension
2937 : 9818 : && !(CLASS_DATA (sym)->attr.codimension
2938 : : && CLASS_DATA (sym)->attr.allocatable))))
2939 : 83522 : var = build_fold_indirect_ref_loc (input_location, var);
2940 : :
2941 : : /* Dereference scalar hidden result. */
2942 : 207503 : if (flag_f2c && sym->ts.type == BT_COMPLEX
2943 : 306 : && (sym->attr.function || sym->attr.result)
2944 : 108 : && !sym->attr.dimension && !sym->attr.pointer
2945 : 60 : && !sym->attr.always_explicit)
2946 : 36 : var = build_fold_indirect_ref_loc (input_location, var);
2947 : :
2948 : : /* Dereference non-character, non-class pointer variables.
2949 : : These must be dummies, results, or scalars. */
2950 : 207503 : if (!is_classarray
2951 : 201332 : && (sym->attr.pointer || sym->attr.allocatable
2952 : 160931 : || gfc_is_associate_pointer (sym)
2953 : 157040 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2954 : 207503 : && (sym->attr.dummy
2955 : : || sym->attr.function
2956 : 61037 : || sym->attr.result
2957 : 27828 : || (!sym->attr.dimension
2958 : 27827 : && (!sym->attr.codimension || !sym->attr.allocatable))))
2959 : 61036 : var = build_fold_indirect_ref_loc (input_location, var);
2960 : : /* Now treat the class array pointer variables accordingly. */
2961 : 146467 : else if (sym->ts.type == BT_CLASS
2962 : 16704 : && sym->attr.dummy
2963 : 16379 : && (CLASS_DATA (sym)->attr.dimension
2964 : 16379 : || CLASS_DATA (sym)->attr.codimension)
2965 : 6797 : && ((CLASS_DATA (sym)->as
2966 : 6797 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2967 : : || CLASS_DATA (sym)->attr.allocatable
2968 : 5898 : || CLASS_DATA (sym)->attr.class_pointer))
2969 : 2642 : var = build_fold_indirect_ref_loc (input_location, var);
2970 : : /* And the case where a non-dummy, non-result, non-function,
2971 : : non-allocable and non-pointer classarray is present. This case was
2972 : : previously covered by the first if, but with introducing the
2973 : : condition !is_classarray there, that case has to be covered
2974 : : explicitly. */
2975 : 143825 : else if (sym->ts.type == BT_CLASS
2976 : : && !sym->attr.dummy
2977 : : && !sym->attr.function
2978 : 14062 : && !sym->attr.result
2979 : 325 : && (CLASS_DATA (sym)->attr.dimension
2980 : 325 : || CLASS_DATA (sym)->attr.codimension)
2981 : 325 : && (sym->assoc
2982 : 0 : || !CLASS_DATA (sym)->attr.allocatable)
2983 : 325 : && !CLASS_DATA (sym)->attr.class_pointer)
2984 : 325 : var = build_fold_indirect_ref_loc (input_location, var);
2985 : : }
2986 : :
2987 : : return var;
2988 : : }
2989 : :
2990 : : /* Return the contents of a variable. Also handles reference/pointer
2991 : : variables (all Fortran pointer references are implicit). */
2992 : :
2993 : : static void
2994 : 1138214 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2995 : : {
2996 : 1138214 : gfc_ss *ss;
2997 : 1138214 : gfc_ref *ref;
2998 : 1138214 : gfc_symbol *sym;
2999 : 1138214 : tree parent_decl = NULL_TREE;
3000 : 1138214 : int parent_flag;
3001 : 1138214 : bool return_value;
3002 : 1138214 : bool alternate_entry;
3003 : 1138214 : bool entry_master;
3004 : 1138214 : bool is_classarray;
3005 : 1138214 : bool first_time = true;
3006 : :
3007 : 1138214 : sym = expr->symtree->n.sym;
3008 : 1138214 : is_classarray = IS_CLASS_ARRAY (sym);
3009 : 1138214 : ss = se->ss;
3010 : 1138214 : if (ss != NULL)
3011 : : {
3012 : 99719 : gfc_ss_info *ss_info = ss->info;
3013 : :
3014 : : /* Check that something hasn't gone horribly wrong. */
3015 : 99719 : gcc_assert (ss != gfc_ss_terminator);
3016 : 99719 : gcc_assert (ss_info->expr == expr);
3017 : :
3018 : : /* A scalarized term. We already know the descriptor. */
3019 : 99719 : se->expr = ss_info->data.array.descriptor;
3020 : 99719 : se->string_length = ss_info->string_length;
3021 : 99719 : ref = ss_info->data.array.ref;
3022 : 99719 : if (ref)
3023 : 99577 : gcc_assert (ref->type == REF_ARRAY
3024 : : && ref->u.ar.type != AR_ELEMENT);
3025 : : else
3026 : 142 : gfc_conv_tmp_array_ref (se);
3027 : : }
3028 : : else
3029 : : {
3030 : 1038495 : tree se_expr = NULL_TREE;
3031 : :
3032 : 1038495 : se->expr = gfc_get_symbol_decl (sym);
3033 : :
3034 : : /* Deal with references to a parent results or entries by storing
3035 : : the current_function_decl and moving to the parent_decl. */
3036 : 1038495 : return_value = sym->attr.function && sym->result == sym;
3037 : 17890 : alternate_entry = sym->attr.function && sym->attr.entry
3038 : 1039569 : && sym->result == sym;
3039 : 2076990 : entry_master = sym->attr.result
3040 : 9240 : && sym->ns->proc_name->attr.entry_master
3041 : 1038876 : && !gfc_return_by_reference (sym->ns->proc_name);
3042 : 1038495 : if (current_function_decl)
3043 : 1021653 : parent_decl = DECL_CONTEXT (current_function_decl);
3044 : :
3045 : 1038495 : if ((se->expr == parent_decl && return_value)
3046 : 1038384 : || (sym->ns && sym->ns->proc_name
3047 : 1034081 : && parent_decl
3048 : 1017239 : && sym->ns->proc_name->backend_decl == parent_decl
3049 : 29919 : && (alternate_entry || entry_master)))
3050 : : parent_flag = 1;
3051 : : else
3052 : 1038351 : parent_flag = 0;
3053 : :
3054 : : /* Special case for assigning the return value of a function.
3055 : : Self recursive functions must have an explicit return value. */
3056 : 1038495 : if (return_value && (se->expr == current_function_decl || parent_flag))
3057 : 10918 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3058 : :
3059 : : /* Similarly for alternate entry points. */
3060 : 1027577 : else if (alternate_entry
3061 : 1041 : && (sym->ns->proc_name->backend_decl == current_function_decl
3062 : 0 : || parent_flag))
3063 : : {
3064 : 1041 : gfc_entry_list *el = NULL;
3065 : :
3066 : 1608 : for (el = sym->ns->entries; el; el = el->next)
3067 : 1608 : if (sym == el->sym)
3068 : : {
3069 : 1041 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3070 : 1041 : break;
3071 : : }
3072 : : }
3073 : :
3074 : 1026536 : else if (entry_master
3075 : 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3076 : 0 : || parent_flag))
3077 : 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3078 : :
3079 : 12254 : if (se_expr)
3080 : 12254 : se->expr = se_expr;
3081 : :
3082 : : /* Procedure actual arguments. Look out for temporary variables
3083 : : with the same attributes as function values. */
3084 : 1026241 : else if (!sym->attr.temporary
3085 : 1026173 : && sym->attr.flavor == FL_PROCEDURE
3086 : 17243 : && se->expr != current_function_decl)
3087 : : {
3088 : 17217 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3089 : : {
3090 : 15725 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3091 : 15725 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3092 : : }
3093 : 17217 : return;
3094 : : }
3095 : :
3096 : 1021278 : if (sym->ts.type == BT_CLASS
3097 : 58540 : && sym->attr.class_ok
3098 : 58352 : && sym->ts.u.derived->attr.is_class)
3099 : 58352 : se->class_container = se->expr;
3100 : :
3101 : : /* Dereference the expression, where needed. */
3102 : 1021278 : se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3103 : : is_classarray);
3104 : :
3105 : 1021278 : ref = expr->ref;
3106 : : }
3107 : :
3108 : : /* For character variables, also get the length. */
3109 : 1120997 : if (sym->ts.type == BT_CHARACTER)
3110 : : {
3111 : : /* If the character length of an entry isn't set, get the length from
3112 : : the master function instead. */
3113 : 145648 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3114 : 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3115 : : else
3116 : 145648 : se->string_length = sym->ts.u.cl->backend_decl;
3117 : 145648 : gcc_assert (se->string_length);
3118 : : }
3119 : :
3120 : 1120997 : gfc_typespec *ts = &sym->ts;
3121 : 1467253 : while (ref)
3122 : : {
3123 : 616799 : switch (ref->type)
3124 : : {
3125 : 479408 : case REF_ARRAY:
3126 : : /* Return the descriptor if that's what we want and this is an array
3127 : : section reference. */
3128 : 479408 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3129 : : return;
3130 : : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3131 : : /* Return the descriptor for array pointers and allocations. */
3132 : 216331 : if (se->want_pointer
3133 : 19667 : && ref->next == NULL && (se->descriptor_only))
3134 : : return;
3135 : :
3136 : 208865 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3137 : : /* Return a pointer to an element. */
3138 : 208865 : break;
3139 : :
3140 : 131059 : case REF_COMPONENT:
3141 : 131059 : ts = &ref->u.c.component->ts;
3142 : 131059 : if (first_time && is_classarray && sym->attr.dummy
3143 : 4686 : && se->descriptor_only
3144 : 3342 : && !CLASS_DATA (sym)->attr.allocatable
3145 : 3342 : && !CLASS_DATA (sym)->attr.class_pointer
3146 : 2445 : && CLASS_DATA (sym)->as
3147 : 2445 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3148 : 2040 : && strcmp ("_data", ref->u.c.component->name) == 0)
3149 : : /* Skip the first ref of a _data component, because for class
3150 : : arrays that one is already done by introducing a temporary
3151 : : array descriptor. */
3152 : : break;
3153 : :
3154 : 129019 : if (ref->u.c.sym->attr.extension)
3155 : 46884 : conv_parent_component_references (se, ref);
3156 : :
3157 : 129019 : gfc_conv_component_ref (se, ref);
3158 : :
3159 : 129019 : if (ref->u.c.component->ts.type == BT_CLASS
3160 : 10091 : && ref->u.c.component->attr.class_ok
3161 : 10091 : && ref->u.c.component->ts.u.derived->attr.is_class)
3162 : 10091 : se->class_container = se->expr;
3163 : 118928 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3164 : 116434 : && ref->u.c.sym->attr.is_class))
3165 : 62673 : se->class_container = NULL_TREE;
3166 : :
3167 : 129019 : if (!ref->next && ref->u.c.sym->attr.codimension
3168 : 0 : && se->want_pointer && se->descriptor_only)
3169 : : return;
3170 : :
3171 : : break;
3172 : :
3173 : 6098 : case REF_SUBSTRING:
3174 : 6098 : gfc_conv_substring (se, ref, expr->ts.kind,
3175 : 6098 : expr->symtree->name, &expr->where);
3176 : 6098 : break;
3177 : :
3178 : 234 : case REF_INQUIRY:
3179 : 234 : conv_inquiry (se, ref, expr, ts);
3180 : 234 : break;
3181 : :
3182 : 0 : default:
3183 : 0 : gcc_unreachable ();
3184 : 346256 : break;
3185 : : }
3186 : 346256 : first_time = false;
3187 : 346256 : ref = ref->next;
3188 : : }
3189 : : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3190 : : separately. */
3191 : 850454 : if (se->want_pointer)
3192 : : {
3193 : 116363 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3194 : 6326 : gfc_conv_string_parameter (se);
3195 : : else
3196 : 110037 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3197 : : }
3198 : : }
3199 : :
3200 : :
3201 : : /* Unary ops are easy... Or they would be if ! was a valid op. */
3202 : :
3203 : : static void
3204 : 26439 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3205 : : {
3206 : 26439 : gfc_se operand;
3207 : 26439 : tree type;
3208 : :
3209 : 26439 : gcc_assert (expr->ts.type != BT_CHARACTER);
3210 : : /* Initialize the operand. */
3211 : 26439 : gfc_init_se (&operand, se);
3212 : 26439 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3213 : 26439 : gfc_add_block_to_block (&se->pre, &operand.pre);
3214 : :
3215 : 26439 : type = gfc_typenode_for_spec (&expr->ts);
3216 : :
3217 : : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3218 : : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3219 : : All other unary operators have an equivalent GIMPLE unary operator. */
3220 : 26439 : if (code == TRUTH_NOT_EXPR)
3221 : 18220 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3222 : 18220 : build_int_cst (type, 0));
3223 : : else
3224 : 8219 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3225 : :
3226 : 26439 : }
3227 : :
3228 : : /* Expand power operator to optimal multiplications when a value is raised
3229 : : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3230 : : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3231 : : Programming", 3rd Edition, 1998. */
3232 : :
3233 : : /* This code is mostly duplicated from expand_powi in the backend.
3234 : : We establish the "optimal power tree" lookup table with the defined size.
3235 : : The items in the table are the exponents used to calculate the index
3236 : : exponents. Any integer n less than the value can get an "addition chain",
3237 : : with the first node being one. */
3238 : : #define POWI_TABLE_SIZE 256
3239 : :
3240 : : /* The table is from builtins.cc. */
3241 : : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3242 : : {
3243 : : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3244 : : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3245 : : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3246 : : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3247 : : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3248 : : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3249 : : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3250 : : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3251 : : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3252 : : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3253 : : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3254 : : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3255 : : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3256 : : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3257 : : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3258 : : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3259 : : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3260 : : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3261 : : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3262 : : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3263 : : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3264 : : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3265 : : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3266 : : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3267 : : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3268 : : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3269 : : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3270 : : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3271 : : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3272 : : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3273 : : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3274 : : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3275 : : };
3276 : :
3277 : : /* If n is larger than lookup table's max index, we use the "window
3278 : : method". */
3279 : : #define POWI_WINDOW_SIZE 3
3280 : :
3281 : : /* Recursive function to expand the power operator. The temporary
3282 : : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3283 : : static tree
3284 : 4368 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3285 : : {
3286 : 4368 : tree op0;
3287 : 4368 : tree op1;
3288 : 4368 : tree tmp;
3289 : 4368 : int digit;
3290 : :
3291 : 4368 : if (n < POWI_TABLE_SIZE)
3292 : : {
3293 : 3509 : if (tmpvar[n])
3294 : : return tmpvar[n];
3295 : :
3296 : 1177 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3297 : 1177 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3298 : : }
3299 : 859 : else if (n & 1)
3300 : : {
3301 : 223 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3302 : 223 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3303 : 223 : op1 = gfc_conv_powi (se, digit, tmpvar);
3304 : : }
3305 : : else
3306 : : {
3307 : 636 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3308 : 636 : op1 = op0;
3309 : : }
3310 : :
3311 : 2036 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3312 : 2036 : tmp = gfc_evaluate_now (tmp, &se->pre);
3313 : :
3314 : 2036 : if (n < POWI_TABLE_SIZE)
3315 : 1177 : tmpvar[n] = tmp;
3316 : :
3317 : : return tmp;
3318 : : }
3319 : :
3320 : :
3321 : : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3322 : : return 1. Else return 0 and a call to runtime library functions
3323 : : will have to be built. */
3324 : : static int
3325 : 1727 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3326 : : {
3327 : 1727 : tree cond;
3328 : 1727 : tree tmp;
3329 : 1727 : tree type;
3330 : 1727 : tree vartmp[POWI_TABLE_SIZE];
3331 : 1727 : HOST_WIDE_INT m;
3332 : 1727 : unsigned HOST_WIDE_INT n;
3333 : 1727 : int sgn;
3334 : 1727 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3335 : :
3336 : : /* If exponent is too large, we won't expand it anyway, so don't bother
3337 : : with large integer values. */
3338 : 1727 : if (!wi::fits_shwi_p (wrhs))
3339 : : return 0;
3340 : :
3341 : 1727 : m = wrhs.to_shwi ();
3342 : : /* Use the wide_int's routine to reliably get the absolute value on all
3343 : : platforms. Then convert it to a HOST_WIDE_INT like above. */
3344 : 1727 : n = wi::abs (wrhs).to_shwi ();
3345 : :
3346 : 1727 : type = TREE_TYPE (lhs);
3347 : 1727 : sgn = tree_int_cst_sgn (rhs);
3348 : :
3349 : 1727 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3350 : 3454 : || optimize_size) && (m > 2 || m < -1))
3351 : : return 0;
3352 : :
3353 : : /* rhs == 0 */
3354 : 1251 : if (sgn == 0)
3355 : : {
3356 : 167 : se->expr = gfc_build_const (type, integer_one_node);
3357 : 167 : return 1;
3358 : : }
3359 : :
3360 : : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3361 : 1084 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3362 : : {
3363 : 152 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3364 : 152 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3365 : 152 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3366 : 152 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3367 : :
3368 : : /* If rhs is even,
3369 : : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3370 : 152 : if ((n & 1) == 0)
3371 : : {
3372 : 72 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3373 : : logical_type_node, tmp, cond);
3374 : 72 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3375 : 72 : tmp, build_int_cst (type, 1),
3376 : 72 : build_int_cst (type, 0));
3377 : 72 : return 1;
3378 : : }
3379 : : /* If rhs is odd,
3380 : : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3381 : 80 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3382 : 80 : build_int_cst (type, -1),
3383 : 80 : build_int_cst (type, 0));
3384 : 80 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3385 : 80 : cond, build_int_cst (type, 1), tmp);
3386 : 80 : return 1;
3387 : : }
3388 : :
3389 : 932 : memset (vartmp, 0, sizeof (vartmp));
3390 : 932 : vartmp[1] = lhs;
3391 : 932 : if (sgn == -1)
3392 : : {
3393 : 91 : tmp = gfc_build_const (type, integer_one_node);
3394 : 91 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3395 : : vartmp[1]);
3396 : : }
3397 : :
3398 : 932 : se->expr = gfc_conv_powi (se, n, vartmp);
3399 : :
3400 : 932 : return 1;
3401 : : }
3402 : :
3403 : :
3404 : : /* Power op (**). Constant integer exponent has special handling. */
3405 : :
3406 : : static void
3407 : 3180 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3408 : : {
3409 : 3180 : tree gfc_int4_type_node;
3410 : 3180 : int kind;
3411 : 3180 : int ikind;
3412 : 3180 : int res_ikind_1, res_ikind_2;
3413 : 3180 : gfc_se lse;
3414 : 3180 : gfc_se rse;
3415 : 3180 : tree fndecl = NULL;
3416 : :
3417 : 3180 : gfc_init_se (&lse, se);
3418 : 3180 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3419 : 3180 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3420 : 3180 : gfc_add_block_to_block (&se->pre, &lse.pre);
3421 : :
3422 : 3180 : gfc_init_se (&rse, se);
3423 : 3180 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3424 : 3180 : gfc_add_block_to_block (&se->pre, &rse.pre);
3425 : :
3426 : 3180 : if (expr->value.op.op2->ts.type == BT_INTEGER
3427 : 2316 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3428 : 1727 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3429 : 1476 : return;
3430 : :
3431 : 1929 : if (INTEGER_CST_P (lse.expr)
3432 : 1929 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3433 : : {
3434 : 231 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3435 : 231 : HOST_WIDE_INT v;
3436 : 231 : unsigned HOST_WIDE_INT w;
3437 : 231 : int kind, ikind, bit_size;
3438 : :
3439 : 231 : v = wlhs.to_shwi ();
3440 : 231 : w = absu_hwi (v);
3441 : :
3442 : 231 : kind = expr->value.op.op1->ts.kind;
3443 : 231 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3444 : 231 : bit_size = gfc_integer_kinds[ikind].bit_size;
3445 : :
3446 : 231 : if (v == 1)
3447 : : {
3448 : : /* 1**something is always 1. */
3449 : 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3450 : 225 : return;
3451 : : }
3452 : 196 : else if (v == -1)
3453 : : {
3454 : : /* (-1)**n is 1 - ((n & 1) << 1) */
3455 : 44 : tree type;
3456 : 44 : tree tmp;
3457 : :
3458 : 44 : type = TREE_TYPE (lse.expr);
3459 : 44 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3460 : 44 : rse.expr, build_int_cst (type, 1));
3461 : 44 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3462 : 44 : tmp, build_int_cst (type, 1));
3463 : 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3464 : 44 : build_int_cst (type, 1), tmp);
3465 : 44 : se->expr = tmp;
3466 : 44 : return;
3467 : : }
3468 : 152 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3469 : : {
3470 : : /* Here v is +/- 2**e. The further simplification uses
3471 : : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3472 : : 1<<(4*n), etc., but we have to make sure to return zero
3473 : : if the number of bits is too large. */
3474 : 146 : tree lshift;
3475 : 146 : tree type;
3476 : 146 : tree shift;
3477 : 146 : tree ge;
3478 : 146 : tree cond;
3479 : 146 : tree num_bits;
3480 : 146 : tree cond2;
3481 : 146 : tree tmp1;
3482 : :
3483 : 146 : type = TREE_TYPE (lse.expr);
3484 : :
3485 : 146 : if (w == 2)
3486 : 86 : shift = rse.expr;
3487 : 60 : else if (w == 4)
3488 : 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3489 : 12 : TREE_TYPE (rse.expr),
3490 : : rse.expr, rse.expr);
3491 : : else
3492 : : {
3493 : : /* use popcount for fast log2(w) */
3494 : 48 : int e = wi::popcount (w-1);
3495 : 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3496 : 48 : TREE_TYPE (rse.expr),
3497 : 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3498 : : rse.expr);
3499 : : }
3500 : :
3501 : 146 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3502 : 146 : build_int_cst (type, 1), shift);
3503 : 146 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3504 : 146 : rse.expr, build_int_cst (type, 0));
3505 : 146 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3506 : 146 : build_int_cst (type, 0));
3507 : 146 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3508 : 146 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3509 : : rse.expr, num_bits);
3510 : 146 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3511 : 146 : build_int_cst (type, 0), cond);
3512 : 146 : if (v > 0)
3513 : : {
3514 : 104 : se->expr = tmp1;
3515 : : }
3516 : : else
3517 : : {
3518 : : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3519 : 42 : tree tmp2;
3520 : 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3521 : 42 : rse.expr, build_int_cst (type, 1));
3522 : 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3523 : 42 : tmp2, build_int_cst (type, 1));
3524 : 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3525 : 42 : build_int_cst (type, 1), tmp2);
3526 : 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3527 : : tmp1, tmp2);
3528 : : }
3529 : 146 : return;
3530 : : }
3531 : : }
3532 : :
3533 : 1704 : gfc_int4_type_node = gfc_get_int_type (4);
3534 : :
3535 : : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3536 : : library routine. But in the end, we have to convert the result back
3537 : : if this case applies -- with res_ikind_K, we keep track whether operand K
3538 : : falls into this case. */
3539 : 1704 : res_ikind_1 = -1;
3540 : 1704 : res_ikind_2 = -1;
3541 : :
3542 : 1704 : kind = expr->value.op.op1->ts.kind;
3543 : 1704 : switch (expr->value.op.op2->ts.type)
3544 : : {
3545 : 840 : case BT_INTEGER:
3546 : 840 : ikind = expr->value.op.op2->ts.kind;
3547 : 840 : switch (ikind)
3548 : : {
3549 : 144 : case 1:
3550 : 144 : case 2:
3551 : 144 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3552 : 144 : res_ikind_2 = ikind;
3553 : : /* Fall through. */
3554 : :
3555 : : case 4:
3556 : : ikind = 0;
3557 : : break;
3558 : :
3559 : : case 8:
3560 : : ikind = 1;
3561 : : break;
3562 : :
3563 : 6 : case 16:
3564 : 6 : ikind = 2;
3565 : 6 : break;
3566 : :
3567 : 0 : default:
3568 : 0 : gcc_unreachable ();
3569 : : }
3570 : 840 : switch (kind)
3571 : : {
3572 : 0 : case 1:
3573 : 0 : case 2:
3574 : 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
3575 : : {
3576 : 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
3577 : 0 : res_ikind_1 = kind;
3578 : : }
3579 : : else
3580 : 0 : gcc_unreachable ();
3581 : : /* Fall through. */
3582 : :
3583 : : case 4:
3584 : : kind = 0;
3585 : : break;
3586 : :
3587 : : case 8:
3588 : : kind = 1;
3589 : : break;
3590 : :
3591 : 6 : case 10:
3592 : 6 : kind = 2;
3593 : 6 : break;
3594 : :
3595 : 18 : case 16:
3596 : 18 : kind = 3;
3597 : 18 : break;
3598 : :
3599 : 0 : default:
3600 : 0 : gcc_unreachable ();
3601 : : }
3602 : :
3603 : 840 : switch (expr->value.op.op1->ts.type)
3604 : : {
3605 : 96 : case BT_INTEGER:
3606 : 96 : if (kind == 3) /* Case 16 was not handled properly above. */
3607 : 6 : kind = 2;
3608 : 96 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3609 : 96 : break;
3610 : :
3611 : 557 : case BT_REAL:
3612 : : /* Use builtins for real ** int4. */
3613 : 557 : if (ikind == 0)
3614 : : {
3615 : 500 : switch (kind)
3616 : : {
3617 : 327 : case 0:
3618 : 327 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3619 : 327 : break;
3620 : :
3621 : 155 : case 1:
3622 : 155 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3623 : 155 : break;
3624 : :
3625 : 6 : case 2:
3626 : 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3627 : 6 : break;
3628 : :
3629 : 12 : case 3:
3630 : : /* Use the __builtin_powil() only if real(kind=16) is
3631 : : actually the C long double type. */
3632 : 12 : if (!gfc_real16_is_float128)
3633 : 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3634 : : break;
3635 : :
3636 : : default:
3637 : : gcc_unreachable ();
3638 : : }
3639 : : }
3640 : :
3641 : : /* If we don't have a good builtin for this, go for the
3642 : : library function. */
3643 : 488 : if (!fndecl)
3644 : 69 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3645 : : break;
3646 : :
3647 : 187 : case BT_COMPLEX:
3648 : 187 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3649 : 187 : break;
3650 : :
3651 : 0 : default:
3652 : 0 : gcc_unreachable ();
3653 : : }
3654 : : break;
3655 : :
3656 : 135 : case BT_REAL:
3657 : 135 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3658 : 135 : break;
3659 : :
3660 : 729 : case BT_COMPLEX:
3661 : 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3662 : 729 : break;
3663 : :
3664 : 0 : default:
3665 : 0 : gcc_unreachable ();
3666 : 1704 : break;
3667 : : }
3668 : :
3669 : 1704 : se->expr = build_call_expr_loc (input_location,
3670 : : fndecl, 2, lse.expr, rse.expr);
3671 : :
3672 : : /* Convert the result back if it is of wrong integer kind. */
3673 : 1704 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
3674 : : {
3675 : : /* We want the maximum of both operand kinds as result. */
3676 : 0 : if (res_ikind_1 < res_ikind_2)
3677 : 0 : res_ikind_1 = res_ikind_2;
3678 : 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3679 : : }
3680 : : }
3681 : :
3682 : :
3683 : : /* Generate code to allocate a string temporary. */
3684 : :
3685 : : tree
3686 : 4408 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3687 : : {
3688 : 4408 : tree var;
3689 : 4408 : tree tmp;
3690 : :
3691 : 4408 : if (gfc_can_put_var_on_stack (len))
3692 : : {
3693 : : /* Create a temporary variable to hold the result. */
3694 : 3904 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3695 : 1952 : TREE_TYPE (len), len,
3696 : 1952 : build_int_cst (TREE_TYPE (len), 1));
3697 : 1952 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3698 : :
3699 : 1952 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3700 : 1952 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3701 : : else
3702 : 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
3703 : :
3704 : 1952 : var = gfc_create_var (tmp, "str");
3705 : 1952 : var = gfc_build_addr_expr (type, var);
3706 : : }
3707 : : else
3708 : : {
3709 : : /* Allocate a temporary to hold the result. */
3710 : 2456 : var = gfc_create_var (type, "pstr");
3711 : 2456 : gcc_assert (POINTER_TYPE_P (type));
3712 : 2456 : tmp = TREE_TYPE (type);
3713 : 2456 : if (TREE_CODE (tmp) == ARRAY_TYPE)
3714 : 2456 : tmp = TREE_TYPE (tmp);
3715 : 2456 : tmp = TYPE_SIZE_UNIT (tmp);
3716 : 2456 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3717 : : fold_convert (size_type_node, len),
3718 : : fold_convert (size_type_node, tmp));
3719 : 2456 : tmp = gfc_call_malloc (&se->pre, type, tmp);
3720 : 2456 : gfc_add_modify (&se->pre, var, tmp);
3721 : :
3722 : : /* Free the temporary afterwards. */
3723 : 2456 : tmp = gfc_call_free (var);
3724 : 2456 : gfc_add_expr_to_block (&se->post, tmp);
3725 : : }
3726 : :
3727 : 4408 : return var;
3728 : : }
3729 : :
3730 : :
3731 : : /* Handle a string concatenation operation. A temporary will be allocated to
3732 : : hold the result. */
3733 : :
3734 : : static void
3735 : 1162 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3736 : : {
3737 : 1162 : gfc_se lse, rse;
3738 : 1162 : tree len, type, var, tmp, fndecl;
3739 : :
3740 : 1162 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3741 : : && expr->value.op.op2->ts.type == BT_CHARACTER);
3742 : 1162 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3743 : :
3744 : 1162 : gfc_init_se (&lse, se);
3745 : 1162 : gfc_conv_expr (&lse, expr->value.op.op1);
3746 : 1162 : gfc_conv_string_parameter (&lse);
3747 : 1162 : gfc_init_se (&rse, se);
3748 : 1162 : gfc_conv_expr (&rse, expr->value.op.op2);
3749 : 1162 : gfc_conv_string_parameter (&rse);
3750 : :
3751 : 1162 : gfc_add_block_to_block (&se->pre, &lse.pre);
3752 : 1162 : gfc_add_block_to_block (&se->pre, &rse.pre);
3753 : :
3754 : 1162 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3755 : 1162 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3756 : 1162 : if (len == NULL_TREE)
3757 : : {
3758 : 1031 : len = fold_build2_loc (input_location, PLUS_EXPR,
3759 : : gfc_charlen_type_node,
3760 : : fold_convert (gfc_charlen_type_node,
3761 : : lse.string_length),
3762 : : fold_convert (gfc_charlen_type_node,
3763 : : rse.string_length));
3764 : : }
3765 : :
3766 : 1162 : type = build_pointer_type (type);
3767 : :
3768 : 1162 : var = gfc_conv_string_tmp (se, type, len);
3769 : :
3770 : : /* Do the actual concatenation. */
3771 : 1162 : if (expr->ts.kind == 1)
3772 : 1098 : fndecl = gfor_fndecl_concat_string;
3773 : 64 : else if (expr->ts.kind == 4)
3774 : 64 : fndecl = gfor_fndecl_concat_string_char4;
3775 : : else
3776 : 0 : gcc_unreachable ();
3777 : :
3778 : 1162 : tmp = build_call_expr_loc (input_location,
3779 : : fndecl, 6, len, var, lse.string_length, lse.expr,
3780 : : rse.string_length, rse.expr);
3781 : 1162 : gfc_add_expr_to_block (&se->pre, tmp);
3782 : :
3783 : : /* Add the cleanup for the operands. */
3784 : 1162 : gfc_add_block_to_block (&se->pre, &rse.post);
3785 : 1162 : gfc_add_block_to_block (&se->pre, &lse.post);
3786 : :
3787 : 1162 : se->expr = var;
3788 : 1162 : se->string_length = len;
3789 : 1162 : }
3790 : :
3791 : : /* Translates an op expression. Common (binary) cases are handled by this
3792 : : function, others are passed on. Recursion is used in either case.
3793 : : We use the fact that (op1.ts == op2.ts) (except for the power
3794 : : operator **).
3795 : : Operators need no special handling for scalarized expressions as long as
3796 : : they call gfc_conv_simple_val to get their operands.
3797 : : Character strings get special handling. */
3798 : :
3799 : : static void
3800 : 341053 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3801 : : {
3802 : 341053 : enum tree_code code;
3803 : 341053 : gfc_se lse;
3804 : 341053 : gfc_se rse;
3805 : 341053 : tree tmp, type;
3806 : 341053 : int lop;
3807 : 341053 : int checkstring;
3808 : :
3809 : 341053 : checkstring = 0;
3810 : 341053 : lop = 0;
3811 : 341053 : switch (expr->value.op.op)
3812 : : {
3813 : 14478 : case INTRINSIC_PARENTHESES:
3814 : 14478 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3815 : 3541 : && flag_protect_parens)
3816 : : {
3817 : 3398 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
3818 : 3398 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3819 : 41867 : return;
3820 : : }
3821 : :
3822 : : /* Fallthrough. */
3823 : 11086 : case INTRINSIC_UPLUS:
3824 : 11086 : gfc_conv_expr (se, expr->value.op.op1);
3825 : 11086 : return;
3826 : :
3827 : 4821 : case INTRINSIC_UMINUS:
3828 : 4821 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3829 : 4821 : return;
3830 : :
3831 : 18220 : case INTRINSIC_NOT:
3832 : 18220 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3833 : 18220 : return;
3834 : :
3835 : : case INTRINSIC_PLUS:
3836 : : code = PLUS_EXPR;
3837 : : break;
3838 : :
3839 : 25909 : case INTRINSIC_MINUS:
3840 : 25909 : code = MINUS_EXPR;
3841 : 25909 : break;
3842 : :
3843 : 29361 : case INTRINSIC_TIMES:
3844 : 29361 : code = MULT_EXPR;
3845 : 29361 : break;
3846 : :
3847 : 5921 : case INTRINSIC_DIVIDE:
3848 : : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3849 : : an integer, we must round towards zero, so we use a
3850 : : TRUNC_DIV_EXPR. */
3851 : 5921 : if (expr->ts.type == BT_INTEGER)
3852 : : code = TRUNC_DIV_EXPR;
3853 : : else
3854 : 2608 : code = RDIV_EXPR;
3855 : : break;
3856 : :
3857 : 3180 : case INTRINSIC_POWER:
3858 : 3180 : gfc_conv_power_op (se, expr);
3859 : 3180 : return;
3860 : :
3861 : 1162 : case INTRINSIC_CONCAT:
3862 : 1162 : gfc_conv_concat_op (se, expr);
3863 : 1162 : return;
3864 : :
3865 : 4526 : case INTRINSIC_AND:
3866 : 4526 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3867 : : lop = 1;
3868 : : break;
3869 : :
3870 : 23920 : case INTRINSIC_OR:
3871 : 23920 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3872 : : lop = 1;
3873 : : break;
3874 : :
3875 : : /* EQV and NEQV only work on logicals, but since we represent them
3876 : : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3877 : 11784 : case INTRINSIC_EQ:
3878 : 11784 : case INTRINSIC_EQ_OS:
3879 : 11784 : case INTRINSIC_EQV:
3880 : 11784 : code = EQ_EXPR;
3881 : 11784 : checkstring = 1;
3882 : 11784 : lop = 1;
3883 : 11784 : break;
3884 : :
3885 : 135486 : case INTRINSIC_NE:
3886 : 135486 : case INTRINSIC_NE_OS:
3887 : 135486 : case INTRINSIC_NEQV:
3888 : 135486 : code = NE_EXPR;
3889 : 135486 : checkstring = 1;
3890 : 135486 : lop = 1;
3891 : 135486 : break;
3892 : :
3893 : 11340 : case INTRINSIC_GT:
3894 : 11340 : case INTRINSIC_GT_OS:
3895 : 11340 : code = GT_EXPR;
3896 : 11340 : checkstring = 1;
3897 : 11340 : lop = 1;
3898 : 11340 : break;
3899 : :
3900 : 1656 : case INTRINSIC_GE:
3901 : 1656 : case INTRINSIC_GE_OS:
3902 : 1656 : code = GE_EXPR;
3903 : 1656 : checkstring = 1;
3904 : 1656 : lop = 1;
3905 : 1656 : break;
3906 : :
3907 : 4065 : case INTRINSIC_LT:
3908 : 4065 : case INTRINSIC_LT_OS:
3909 : 4065 : code = LT_EXPR;
3910 : 4065 : checkstring = 1;
3911 : 4065 : lop = 1;
3912 : 4065 : break;
3913 : :
3914 : 2514 : case INTRINSIC_LE:
3915 : 2514 : case INTRINSIC_LE_OS:
3916 : 2514 : code = LE_EXPR;
3917 : 2514 : checkstring = 1;
3918 : 2514 : lop = 1;
3919 : 2514 : break;
3920 : :
3921 : 0 : case INTRINSIC_USER:
3922 : 0 : case INTRINSIC_ASSIGN:
3923 : : /* These should be converted into function calls by the frontend. */
3924 : 0 : gcc_unreachable ();
3925 : :
3926 : 0 : default:
3927 : 0 : fatal_error (input_location, "Unknown intrinsic op");
3928 : 299186 : return;
3929 : : }
3930 : :
3931 : : /* The only exception to this is **, which is handled separately anyway. */
3932 : 299186 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3933 : :
3934 : 299186 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3935 : 268382 : checkstring = 0;
3936 : :
3937 : : /* lhs */
3938 : 299186 : gfc_init_se (&lse, se);
3939 : 299186 : gfc_conv_expr (&lse, expr->value.op.op1);
3940 : 299186 : gfc_add_block_to_block (&se->pre, &lse.pre);
3941 : :
3942 : : /* rhs */
3943 : 299186 : gfc_init_se (&rse, se);
3944 : 299186 : gfc_conv_expr (&rse, expr->value.op.op2);
3945 : 299186 : gfc_add_block_to_block (&se->pre, &rse.pre);
3946 : :
3947 : 299186 : if (checkstring)
3948 : : {
3949 : 30804 : gfc_conv_string_parameter (&lse);
3950 : 30804 : gfc_conv_string_parameter (&rse);
3951 : :
3952 : 61608 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3953 : : rse.string_length, rse.expr,
3954 : 30804 : expr->value.op.op1->ts.kind,
3955 : : code);
3956 : 30804 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3957 : 30804 : gfc_add_block_to_block (&lse.post, &rse.post);
3958 : : }
3959 : :
3960 : 299186 : type = gfc_typenode_for_spec (&expr->ts);
3961 : :
3962 : 299186 : if (lop)
3963 : : {
3964 : : /* The result of logical ops is always logical_type_node. */
3965 : 195291 : tmp = fold_build2_loc (input_location, code, logical_type_node,
3966 : : lse.expr, rse.expr);
3967 : 195291 : se->expr = convert (type, tmp);
3968 : : }
3969 : : else
3970 : 103895 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3971 : :
3972 : : /* Add the post blocks. */
3973 : 299186 : gfc_add_block_to_block (&se->post, &rse.post);
3974 : 299186 : gfc_add_block_to_block (&se->post, &lse.post);
3975 : : }
3976 : :
3977 : : /* If a string's length is one, we convert it to a single character. */
3978 : :
3979 : : tree
3980 : 125032 : gfc_string_to_single_character (tree len, tree str, int kind)
3981 : : {
3982 : :
3983 : 125032 : if (len == NULL
3984 : 125032 : || !tree_fits_uhwi_p (len)
3985 : 230421 : || !POINTER_TYPE_P (TREE_TYPE (str)))
3986 : : return NULL_TREE;
3987 : :
3988 : 105338 : if (TREE_INT_CST_LOW (len) == 1)
3989 : : {
3990 : 20779 : str = fold_convert (gfc_get_pchar_type (kind), str);
3991 : 20779 : return build_fold_indirect_ref_loc (input_location, str);
3992 : : }
3993 : :
3994 : 84559 : if (kind == 1
3995 : 69096 : && TREE_CODE (str) == ADDR_EXPR
3996 : 59685 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3997 : 43034 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3998 : 26195 : && array_ref_low_bound (TREE_OPERAND (str, 0))
3999 : 26195 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4000 : 26195 : && TREE_INT_CST_LOW (len) > 1
4001 : 109024 : && TREE_INT_CST_LOW (len)
4002 : : == (unsigned HOST_WIDE_INT)
4003 : 24465 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4004 : : {
4005 : 24465 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4006 : 24465 : ret = build_fold_indirect_ref_loc (input_location, ret);
4007 : 24465 : if (TREE_CODE (ret) == INTEGER_CST)
4008 : : {
4009 : 24465 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4010 : 24465 : int i, length = TREE_STRING_LENGTH (string_cst);
4011 : 24465 : const char *ptr = TREE_STRING_POINTER (string_cst);
4012 : :
4013 : 36048 : for (i = 1; i < length; i++)
4014 : 35490 : if (ptr[i] != ' ')
4015 : : return NULL_TREE;
4016 : :
4017 : : return ret;
4018 : : }
4019 : : }
4020 : :
4021 : : return NULL_TREE;
4022 : : }
4023 : :
4024 : :
4025 : : static void
4026 : 171 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4027 : : {
4028 : 171 : gcc_assert (expr);
4029 : :
4030 : : /* We used to modify the tree here. Now it is done earlier in
4031 : : the front-end, so we only check it here to avoid regressions. */
4032 : 171 : if (sym->backend_decl)
4033 : : {
4034 : 66 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4035 : 66 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4036 : 66 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4037 : 66 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4038 : : }
4039 : :
4040 : : /* If we have a constant character expression, make it into an
4041 : : integer of type C char. */
4042 : 171 : if ((*expr)->expr_type == EXPR_CONSTANT)
4043 : : {
4044 : 165 : gfc_typespec ts;
4045 : 165 : gfc_clear_ts (&ts);
4046 : :
4047 : 330 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4048 : 165 : (*expr)->value.character.string[0]);
4049 : 165 : gfc_replace_expr (*expr, tmp);
4050 : : }
4051 : 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4052 : : {
4053 : 6 : if ((*expr)->ref == NULL)
4054 : : {
4055 : 12 : se->expr = gfc_string_to_single_character
4056 : 6 : (build_int_cst (integer_type_node, 1),
4057 : 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4058 : : gfc_get_symbol_decl
4059 : 6 : ((*expr)->symtree->n.sym)),
4060 : : (*expr)->ts.kind);
4061 : : }
4062 : : else
4063 : : {
4064 : 0 : gfc_conv_variable (se, *expr);
4065 : 0 : se->expr = gfc_string_to_single_character
4066 : 0 : (build_int_cst (integer_type_node, 1),
4067 : : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4068 : : se->expr),
4069 : 0 : (*expr)->ts.kind);
4070 : : }
4071 : : }
4072 : 171 : }
4073 : :
4074 : : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4075 : : if STR is a string literal, otherwise return -1. */
4076 : :
4077 : : static int
4078 : 28756 : gfc_optimize_len_trim (tree len, tree str, int kind)
4079 : : {
4080 : 28756 : if (kind == 1
4081 : 24140 : && TREE_CODE (str) == ADDR_EXPR
4082 : 20943 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4083 : 13570 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4084 : 8579 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4085 : 8579 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4086 : 8579 : && tree_fits_uhwi_p (len)
4087 : 8579 : && tree_to_uhwi (len) >= 1
4088 : 28756 : && tree_to_uhwi (len)
4089 : 8535 : == (unsigned HOST_WIDE_INT)
4090 : 8535 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4091 : : {
4092 : 8535 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4093 : 8535 : folded = build_fold_indirect_ref_loc (input_location, folded);
4094 : 8535 : if (TREE_CODE (folded) == INTEGER_CST)
4095 : : {
4096 : 8535 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4097 : 8535 : int length = TREE_STRING_LENGTH (string_cst);
4098 : 8535 : const char *ptr = TREE_STRING_POINTER (string_cst);
4099 : :
4100 : 11741 : for (; length > 0; length--)
4101 : 11741 : if (ptr[length - 1] != ' ')
4102 : : break;
4103 : :
4104 : 8535 : return length;
4105 : : }
4106 : : }
4107 : : return -1;
4108 : : }
4109 : :
4110 : : /* Helper to build a call to memcmp. */
4111 : :
4112 : : static tree
4113 : 11546 : build_memcmp_call (tree s1, tree s2, tree n)
4114 : : {
4115 : 11546 : tree tmp;
4116 : :
4117 : 11546 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4118 : 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4119 : : else
4120 : 11546 : s1 = fold_convert (pvoid_type_node, s1);
4121 : :
4122 : 11546 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4123 : 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4124 : : else
4125 : 11546 : s2 = fold_convert (pvoid_type_node, s2);
4126 : :
4127 : 11546 : n = fold_convert (size_type_node, n);
4128 : :
4129 : 11546 : tmp = build_call_expr_loc (input_location,
4130 : : builtin_decl_explicit (BUILT_IN_MEMCMP),
4131 : : 3, s1, s2, n);
4132 : :
4133 : 11546 : return fold_convert (integer_type_node, tmp);
4134 : : }
4135 : :
4136 : : /* Compare two strings. If they are all single characters, the result is the
4137 : : subtraction of them. Otherwise, we build a library call. */
4138 : :
4139 : : tree
4140 : 30903 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4141 : : enum tree_code code)
4142 : : {
4143 : 30903 : tree sc1;
4144 : 30903 : tree sc2;
4145 : 30903 : tree fndecl;
4146 : :
4147 : 30903 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4148 : 30903 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4149 : :
4150 : 30903 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4151 : 30903 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4152 : :
4153 : 30903 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4154 : : {
4155 : : /* Deal with single character specially. */
4156 : 4612 : sc1 = fold_convert (integer_type_node, sc1);
4157 : 4612 : sc2 = fold_convert (integer_type_node, sc2);
4158 : 4612 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4159 : 4612 : sc1, sc2);
4160 : : }
4161 : :
4162 : 26291 : if ((code == EQ_EXPR || code == NE_EXPR)
4163 : 25725 : && optimize
4164 : 21599 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4165 : : {
4166 : : /* If one string is a string literal with LEN_TRIM longer
4167 : : than the length of the second string, the strings
4168 : : compare unequal. */
4169 : 14378 : int len = gfc_optimize_len_trim (len1, str1, kind);
4170 : 14378 : if (len > 0 && compare_tree_int (len2, len) < 0)
4171 : 0 : return integer_one_node;
4172 : 14378 : len = gfc_optimize_len_trim (len2, str2, kind);
4173 : 14378 : if (len > 0 && compare_tree_int (len1, len) < 0)
4174 : 0 : return integer_one_node;
4175 : : }
4176 : :
4177 : : /* We can compare via memcpy if the strings are known to be equal
4178 : : in length and they are
4179 : : - kind=1
4180 : : - kind=4 and the comparison is for (in)equality. */
4181 : :
4182 : 17480 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4183 : 17147 : && tree_int_cst_equal (len1, len2)
4184 : 37897 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4185 : : {
4186 : 11546 : tree tmp;
4187 : 11546 : tree chartype;
4188 : :
4189 : 11546 : chartype = gfc_get_char_type (kind);
4190 : 11546 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4191 : 11546 : fold_convert (TREE_TYPE(len1),
4192 : : TYPE_SIZE_UNIT(chartype)),
4193 : : len1);
4194 : 11546 : return build_memcmp_call (str1, str2, tmp);
4195 : : }
4196 : :
4197 : : /* Build a call for the comparison. */
4198 : 14745 : if (kind == 1)
4199 : 11998 : fndecl = gfor_fndecl_compare_string;
4200 : 2747 : else if (kind == 4)
4201 : 2747 : fndecl = gfor_fndecl_compare_string_char4;
4202 : : else
4203 : 0 : gcc_unreachable ();
4204 : :
4205 : 14745 : return build_call_expr_loc (input_location, fndecl, 4,
4206 : 14745 : len1, str1, len2, str2);
4207 : : }
4208 : :
4209 : :
4210 : : /* Return the backend_decl for a procedure pointer component. */
4211 : :
4212 : : static tree
4213 : 1570 : get_proc_ptr_comp (gfc_expr *e)
4214 : : {
4215 : 1570 : gfc_se comp_se;
4216 : 1570 : gfc_expr *e2;
4217 : 1570 : expr_t old_type;
4218 : :
4219 : 1570 : gfc_init_se (&comp_se, NULL);
4220 : 1570 : e2 = gfc_copy_expr (e);
4221 : : /* We have to restore the expr type later so that gfc_free_expr frees
4222 : : the exact same thing that was allocated.
4223 : : TODO: This is ugly. */
4224 : 1570 : old_type = e2->expr_type;
4225 : 1570 : e2->expr_type = EXPR_VARIABLE;
4226 : 1570 : gfc_conv_expr (&comp_se, e2);
4227 : 1570 : e2->expr_type = old_type;
4228 : 1570 : gfc_free_expr (e2);
4229 : 1570 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4230 : : }
4231 : :
4232 : :
4233 : : /* Convert a typebound function reference from a class object. */
4234 : : static void
4235 : 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4236 : : {
4237 : 80 : gfc_ref *ref;
4238 : 80 : tree var;
4239 : :
4240 : 80 : if (!VAR_P (base_object))
4241 : : {
4242 : 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4243 : 0 : gfc_add_modify (&se->pre, var, base_object);
4244 : : }
4245 : 80 : se->expr = gfc_class_vptr_get (base_object);
4246 : 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4247 : 80 : ref = expr->ref;
4248 : 308 : while (ref && ref->next)
4249 : : ref = ref->next;
4250 : 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4251 : 80 : if (ref->u.c.sym->attr.extension)
4252 : 0 : conv_parent_component_references (se, ref);
4253 : 80 : gfc_conv_component_ref (se, ref);
4254 : 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4255 : 80 : }
4256 : :
4257 : :
4258 : : static void
4259 : 109025 : conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
4260 : : gfc_actual_arglist *actual_args)
4261 : : {
4262 : 109025 : tree tmp;
4263 : :
4264 : 109025 : if (gfc_is_proc_ptr_comp (expr))
4265 : 1570 : tmp = get_proc_ptr_comp (expr);
4266 : 107455 : else if (sym->attr.dummy)
4267 : : {
4268 : 763 : tmp = gfc_get_symbol_decl (sym);
4269 : 763 : if (sym->attr.proc_pointer)
4270 : 83 : tmp = build_fold_indirect_ref_loc (input_location,
4271 : : tmp);
4272 : 763 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4273 : : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4274 : : }
4275 : : else
4276 : : {
4277 : 106692 : if (!sym->backend_decl)
4278 : 27776 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4279 : :
4280 : 106692 : TREE_USED (sym->backend_decl) = 1;
4281 : :
4282 : 106692 : tmp = sym->backend_decl;
4283 : :
4284 : 106692 : if (sym->attr.cray_pointee)
4285 : : {
4286 : : /* TODO - make the cray pointee a pointer to a procedure,
4287 : : assign the pointer to it and use it for the call. This
4288 : : will do for now! */
4289 : 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4290 : : gfc_get_symbol_decl (sym->cp_pointer));
4291 : 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4292 : : }
4293 : :
4294 : 106692 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4295 : : {
4296 : 106135 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4297 : 106135 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4298 : : }
4299 : : }
4300 : 109025 : se->expr = tmp;
4301 : 109025 : }
4302 : :
4303 : :
4304 : : /* Initialize MAPPING. */
4305 : :
4306 : : void
4307 : 109142 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4308 : : {
4309 : 109142 : mapping->syms = NULL;
4310 : 109142 : mapping->charlens = NULL;
4311 : 109142 : }
4312 : :
4313 : :
4314 : : /* Free all memory held by MAPPING (but not MAPPING itself). */
4315 : :
4316 : : void
4317 : 109142 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4318 : : {
4319 : 109142 : gfc_interface_sym_mapping *sym;
4320 : 109142 : gfc_interface_sym_mapping *nextsym;
4321 : 109142 : gfc_charlen *cl;
4322 : 109142 : gfc_charlen *nextcl;
4323 : :
4324 : 137405 : for (sym = mapping->syms; sym; sym = nextsym)
4325 : : {
4326 : 28263 : nextsym = sym->next;
4327 : 28263 : sym->new_sym->n.sym->formal = NULL;
4328 : 28263 : gfc_free_symbol (sym->new_sym->n.sym);
4329 : 28263 : gfc_free_expr (sym->expr);
4330 : 28263 : free (sym->new_sym);
4331 : 28263 : free (sym);
4332 : : }
4333 : 112982 : for (cl = mapping->charlens; cl; cl = nextcl)
4334 : : {
4335 : 3840 : nextcl = cl->next;
4336 : 3840 : gfc_free_expr (cl->length);
4337 : 3840 : free (cl);
4338 : : }
4339 : 109142 : }
4340 : :
4341 : :
4342 : : /* Return a copy of gfc_charlen CL. Add the returned structure to
4343 : : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4344 : :
4345 : : static gfc_charlen *
4346 : 3840 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4347 : : gfc_charlen * cl)
4348 : : {
4349 : 3840 : gfc_charlen *new_charlen;
4350 : :
4351 : 3840 : new_charlen = gfc_get_charlen ();
4352 : 3840 : new_charlen->next = mapping->charlens;
4353 : 3840 : new_charlen->length = gfc_copy_expr (cl->length);
4354 : :
4355 : 3840 : mapping->charlens = new_charlen;
4356 : 3840 : return new_charlen;
4357 : : }
4358 : :
4359 : :
4360 : : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4361 : : array variable that can be used as the actual argument for dummy
4362 : : argument SYM. Add any initialization code to BLOCK. PACKED is as
4363 : : for gfc_get_nodesc_array_type and DATA points to the first element
4364 : : in the passed array. */
4365 : :
4366 : : static tree
4367 : 5883 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4368 : : gfc_packed packed, tree data)
4369 : : {
4370 : 5883 : tree type;
4371 : 5883 : tree var;
4372 : :
4373 : 5883 : type = gfc_typenode_for_spec (&sym->ts);
4374 : 11766 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4375 : : !sym->attr.target && !sym->attr.pointer
4376 : 5883 : && !sym->attr.proc_pointer);
4377 : :
4378 : 5883 : var = gfc_create_var (type, "ifm");
4379 : 5883 : gfc_add_modify (block, var, fold_convert (type, data));
4380 : :
4381 : 5883 : return var;
4382 : : }
4383 : :
4384 : :
4385 : : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4386 : : and offset of descriptorless array type TYPE given that it has the same
4387 : : size as DESC. Add any set-up code to BLOCK. */
4388 : :
4389 : : static void
4390 : 5613 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4391 : : {
4392 : 5613 : int n;
4393 : 5613 : tree dim;
4394 : 5613 : tree offset;
4395 : 5613 : tree tmp;
4396 : :
4397 : 5613 : offset = gfc_index_zero_node;
4398 : 6652 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4399 : : {
4400 : 1039 : dim = gfc_rank_cst[n];
4401 : 1039 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4402 : 1039 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4403 : : {
4404 : 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4405 : 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4406 : 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4407 : 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4408 : : }
4409 : 1038 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4410 : : {
4411 : 1038 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4412 : : gfc_array_index_type,
4413 : : gfc_conv_descriptor_ubound_get (desc, dim),
4414 : : gfc_conv_descriptor_lbound_get (desc, dim));
4415 : 3114 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4416 : : gfc_array_index_type,
4417 : 1038 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4418 : 1038 : tmp = gfc_evaluate_now (tmp, block);
4419 : 1038 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4420 : : }
4421 : 4156 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4422 : 1039 : GFC_TYPE_ARRAY_LBOUND (type, n),
4423 : 1039 : GFC_TYPE_ARRAY_STRIDE (type, n));
4424 : 1039 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4425 : : gfc_array_index_type, offset, tmp);
4426 : : }
4427 : 5613 : offset = gfc_evaluate_now (offset, block);
4428 : 5613 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4429 : 5613 : }
4430 : :
4431 : :
4432 : : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4433 : : in SE. The caller may still use se->expr and se->string_length after
4434 : : calling this function. */
4435 : :
4436 : : void
4437 : 28263 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4438 : : gfc_symbol * sym, gfc_se * se,
4439 : : gfc_expr *expr)
4440 : : {
4441 : 28263 : gfc_interface_sym_mapping *sm;
4442 : 28263 : tree desc;
4443 : 28263 : tree tmp;
4444 : 28263 : tree value;
4445 : 28263 : gfc_symbol *new_sym;
4446 : 28263 : gfc_symtree *root;
4447 : 28263 : gfc_symtree *new_symtree;
4448 : :
4449 : : /* Create a new symbol to represent the actual argument. */
4450 : 28263 : new_sym = gfc_new_symbol (sym->name, NULL);
4451 : 28263 : new_sym->ts = sym->ts;
4452 : 28263 : new_sym->as = gfc_copy_array_spec (sym->as);
4453 : 28263 : new_sym->attr.referenced = 1;
4454 : 28263 : new_sym->attr.dimension = sym->attr.dimension;
4455 : 28263 : new_sym->attr.contiguous = sym->attr.contiguous;
4456 : 28263 : new_sym->attr.codimension = sym->attr.codimension;
4457 : 28263 : new_sym->attr.pointer = sym->attr.pointer;
4458 : 28263 : new_sym->attr.allocatable = sym->attr.allocatable;
4459 : 28263 : new_sym->attr.flavor = sym->attr.flavor;
4460 : 28263 : new_sym->attr.function = sym->attr.function;
4461 : :
4462 : : /* Ensure that the interface is available and that
4463 : : descriptors are passed for array actual arguments. */
4464 : 28263 : if (sym->attr.flavor == FL_PROCEDURE)
4465 : : {
4466 : 36 : new_sym->formal = expr->symtree->n.sym->formal;
4467 : 36 : new_sym->attr.always_explicit
4468 : 36 : = expr->symtree->n.sym->attr.always_explicit;
4469 : : }
4470 : :
4471 : : /* Create a fake symtree for it. */
4472 : 28263 : root = NULL;
4473 : 28263 : new_symtree = gfc_new_symtree (&root, sym->name);
4474 : 28263 : new_symtree->n.sym = new_sym;
4475 : 28263 : gcc_assert (new_symtree == root);
4476 : :
4477 : : /* Create a dummy->actual mapping. */
4478 : 28263 : sm = XCNEW (gfc_interface_sym_mapping);
4479 : 28263 : sm->next = mapping->syms;
4480 : 28263 : sm->old = sym;
4481 : 28263 : sm->new_sym = new_symtree;
4482 : 28263 : sm->expr = gfc_copy_expr (expr);
4483 : 28263 : mapping->syms = sm;
4484 : :
4485 : : /* Stabilize the argument's value. */
4486 : 28263 : if (!sym->attr.function && se)
4487 : 28165 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
4488 : :
4489 : 28263 : if (sym->ts.type == BT_CHARACTER)
4490 : : {
4491 : : /* Create a copy of the dummy argument's length. */
4492 : 1969 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4493 : 1969 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
4494 : :
4495 : : /* If the length is specified as "*", record the length that
4496 : : the caller is passing. We should use the callee's length
4497 : : in all other cases. */
4498 : 1969 : if (!new_sym->ts.u.cl->length && se)
4499 : : {
4500 : 1765 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4501 : 1765 : new_sym->ts.u.cl->backend_decl = se->string_length;
4502 : : }
4503 : : }
4504 : :
4505 : 28249 : if (!se)
4506 : 62 : return;
4507 : :
4508 : : /* Use the passed value as-is if the argument is a function. */
4509 : 28201 : if (sym->attr.flavor == FL_PROCEDURE)
4510 : 36 : value = se->expr;
4511 : :
4512 : : /* If the argument is a pass-by-value scalar, use the value as is. */
4513 : 28165 : else if (!sym->attr.dimension && sym->attr.value)
4514 : 39 : value = se->expr;
4515 : :
4516 : : /* If the argument is either a string or a pointer to a string,
4517 : : convert it to a boundless character type. */
4518 : 28126 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4519 : : {
4520 : 1120 : tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4521 : 1120 : tmp = build_pointer_type (tmp);
4522 : 1120 : if (sym->attr.pointer)
4523 : 126 : value = build_fold_indirect_ref_loc (input_location,
4524 : : se->expr);
4525 : : else
4526 : 994 : value = se->expr;
4527 : 1120 : value = fold_convert (tmp, value);
4528 : : }
4529 : :
4530 : : /* If the argument is a scalar, a pointer to an array or an allocatable,
4531 : : dereference it. */
4532 : 27006 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4533 : 20322 : value = build_fold_indirect_ref_loc (input_location,
4534 : : se->expr);
4535 : :
4536 : : /* For character(*), use the actual argument's descriptor. */
4537 : 6684 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4538 : 801 : value = build_fold_indirect_ref_loc (input_location,
4539 : : se->expr);
4540 : :
4541 : : /* If the argument is an array descriptor, use it to determine
4542 : : information about the actual argument's shape. */
4543 : 5883 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4544 : 5883 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4545 : : {
4546 : : /* Get the actual argument's descriptor. */
4547 : 5613 : desc = build_fold_indirect_ref_loc (input_location,
4548 : : se->expr);
4549 : :
4550 : : /* Create the replacement variable. */
4551 : 5613 : tmp = gfc_conv_descriptor_data_get (desc);
4552 : 5613 : value = gfc_get_interface_mapping_array (&se->pre, sym,
4553 : : PACKED_NO, tmp);
4554 : :
4555 : : /* Use DESC to work out the upper bounds, strides and offset. */
4556 : 5613 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4557 : : }
4558 : : else
4559 : : /* Otherwise we have a packed array. */
4560 : 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
4561 : : PACKED_FULL, se->expr);
4562 : :
4563 : 28201 : new_sym->backend_decl = value;
4564 : : }
4565 : :
4566 : :
4567 : : /* Called once all dummy argument mappings have been added to MAPPING,
4568 : : but before the mapping is used to evaluate expressions. Pre-evaluate
4569 : : the length of each argument, adding any initialization code to PRE and
4570 : : any finalization code to POST. */
4571 : :
4572 : : static void
4573 : 109105 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4574 : : stmtblock_t * pre, stmtblock_t * post)
4575 : : {
4576 : 109105 : gfc_interface_sym_mapping *sym;
4577 : 109105 : gfc_expr *expr;
4578 : 109105 : gfc_se se;
4579 : :
4580 : 137306 : for (sym = mapping->syms; sym; sym = sym->next)
4581 : 28201 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4582 : 1955 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4583 : : {
4584 : 190 : expr = sym->new_sym->n.sym->ts.u.cl->length;
4585 : 190 : gfc_apply_interface_mapping_to_expr (mapping, expr);
4586 : 190 : gfc_init_se (&se, NULL);
4587 : 190 : gfc_conv_expr (&se, expr);
4588 : 190 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4589 : 190 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
4590 : 190 : gfc_add_block_to_block (pre, &se.pre);
4591 : 190 : gfc_add_block_to_block (post, &se.post);
4592 : :
4593 : 190 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4594 : : }
4595 : 109105 : }
4596 : :
4597 : :
4598 : : /* Like gfc_apply_interface_mapping_to_expr, but applied to
4599 : : constructor C. */
4600 : :
4601 : : static void
4602 : 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4603 : : gfc_constructor_base base)
4604 : : {
4605 : 47 : gfc_constructor *c;
4606 : 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4607 : : {
4608 : 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4609 : 381 : if (c->iterator)
4610 : : {
4611 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4612 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4613 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4614 : : }
4615 : : }
4616 : 47 : }
4617 : :
4618 : :
4619 : : /* Like gfc_apply_interface_mapping_to_expr, but applied to
4620 : : reference REF. */
4621 : :
4622 : : static void
4623 : 13266 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4624 : : gfc_ref * ref)
4625 : : {
4626 : 13266 : int n;
4627 : :
4628 : 14666 : for (; ref; ref = ref->next)
4629 : 1400 : switch (ref->type)
4630 : : {
4631 : : case REF_ARRAY:
4632 : 2821 : for (n = 0; n < ref->u.ar.dimen; n++)
4633 : : {
4634 : 1599 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4635 : 1599 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4636 : 1599 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4637 : : }
4638 : : break;
4639 : :
4640 : : case REF_COMPONENT:
4641 : : case REF_INQUIRY:
4642 : : break;
4643 : :
4644 : 43 : case REF_SUBSTRING:
4645 : 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4646 : 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4647 : 43 : break;
4648 : : }
4649 : 13266 : }
4650 : :
4651 : :
4652 : : /* Convert intrinsic function calls into result expressions. */
4653 : :
4654 : : static bool
4655 : 2190 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4656 : : {
4657 : 2190 : gfc_symbol *sym;
4658 : 2190 : gfc_expr *new_expr;
4659 : 2190 : gfc_expr *arg1;
4660 : 2190 : gfc_expr *arg2;
4661 : 2190 : int d, dup;
4662 : :
4663 : 2190 : arg1 = expr->value.function.actual->expr;
4664 : 2190 : if (expr->value.function.actual->next)
4665 : 2069 : arg2 = expr->value.function.actual->next->expr;
4666 : : else
4667 : : arg2 = NULL;
4668 : :
4669 : 2190 : sym = arg1->symtree->n.sym;
4670 : :
4671 : 2190 : if (sym->attr.dummy)
4672 : : return false;
4673 : :
4674 : 2123 : new_expr = NULL;
4675 : :
4676 : 2123 : switch (expr->value.function.isym->id)
4677 : : {
4678 : 875 : case GFC_ISYM_LEN:
4679 : : /* TODO figure out why this condition is necessary. */
4680 : 875 : if (sym->attr.function
4681 : 43 : && (arg1->ts.u.cl->length == NULL
4682 : 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4683 : 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4684 : : return false;
4685 : :
4686 : 832 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4687 : 832 : break;
4688 : :
4689 : 277 : case GFC_ISYM_LEN_TRIM:
4690 : 277 : new_expr = gfc_copy_expr (arg1);
4691 : 277 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4692 : :
4693 : 277 : if (!new_expr)
4694 : : return false;
4695 : :
4696 : 277 : gfc_replace_expr (arg1, new_expr);
4697 : 277 : return true;
4698 : :
4699 : 556 : case GFC_ISYM_SIZE:
4700 : 556 : if (!sym->as || sym->as->rank == 0)
4701 : : return false;
4702 : :
4703 : 498 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4704 : : {
4705 : 328 : dup = mpz_get_si (arg2->value.integer);
4706 : 328 : d = dup - 1;
4707 : : }
4708 : : else
4709 : : {
4710 : 498 : dup = sym->as->rank;
4711 : 498 : d = 0;
4712 : : }
4713 : :
4714 : 510 : for (; d < dup; d++)
4715 : : {
4716 : 498 : gfc_expr *tmp;
4717 : :
4718 : 498 : if (!sym->as->upper[d] || !sym->as->lower[d])
4719 : : {
4720 : 486 : gfc_free_expr (new_expr);
4721 : 486 : return false;
4722 : : }
4723 : :
4724 : 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4725 : : gfc_get_int_expr (gfc_default_integer_kind,
4726 : : NULL, 1));
4727 : 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4728 : 12 : if (new_expr)
4729 : 0 : new_expr = gfc_multiply (new_expr, tmp);
4730 : : else
4731 : : new_expr = tmp;
4732 : : }
4733 : : break;
4734 : :
4735 : 44 : case GFC_ISYM_LBOUND:
4736 : 44 : case GFC_ISYM_UBOUND:
4737 : : /* TODO These implementations of lbound and ubound do not limit if
4738 : : the size < 0, according to F95's 13.14.53 and 13.14.113. */
4739 : :
4740 : 44 : if (!sym->as || sym->as->rank == 0)
4741 : : return false;
4742 : :
4743 : 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4744 : 38 : d = mpz_get_si (arg2->value.integer) - 1;
4745 : : else
4746 : : return false;
4747 : :
4748 : 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4749 : : {
4750 : 23 : if (sym->as->lower[d])
4751 : 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
4752 : : }
4753 : : else
4754 : : {
4755 : 15 : if (sym->as->upper[d])
4756 : 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
4757 : : }
4758 : : break;
4759 : :
4760 : : default:
4761 : : break;
4762 : : }
4763 : :
4764 : 1253 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4765 : 1253 : if (!new_expr)
4766 : : return false;
4767 : :
4768 : 113 : gfc_replace_expr (expr, new_expr);
4769 : 113 : return true;
4770 : : }
4771 : :
4772 : :
4773 : : static void
4774 : 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4775 : : gfc_interface_mapping * mapping)
4776 : : {
4777 : 24 : gfc_formal_arglist *f;
4778 : 24 : gfc_actual_arglist *actual;
4779 : :
4780 : 24 : actual = expr->value.function.actual;
4781 : 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4782 : :
4783 : 72 : for (; f && actual; f = f->next, actual = actual->next)
4784 : : {
4785 : 24 : if (!actual->expr)
4786 : 0 : continue;
4787 : :
4788 : 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4789 : : }
4790 : :
4791 : 24 : if (map_expr->symtree->n.sym->attr.dimension)
4792 : : {
4793 : 6 : int d;
4794 : 6 : gfc_array_spec *as;
4795 : :
4796 : 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4797 : :
4798 : 18 : for (d = 0; d < as->rank; d++)
4799 : : {
4800 : 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4801 : 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4802 : : }
4803 : :
4804 : 6 : expr->value.function.esym->as = as;
4805 : : }
4806 : :
4807 : 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4808 : : {
4809 : 0 : expr->value.function.esym->ts.u.cl->length
4810 : 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4811 : :
4812 : 0 : gfc_apply_interface_mapping_to_expr (mapping,
4813 : 0 : expr->value.function.esym->ts.u.cl->length);
4814 : : }
4815 : 24 : }
4816 : :
4817 : :
4818 : : /* EXPR is a copy of an expression that appeared in the interface
4819 : : associated with MAPPING. Walk it recursively looking for references to
4820 : : dummy arguments that MAPPING maps to actual arguments. Replace each such
4821 : : reference with a reference to the associated actual argument. */
4822 : :
4823 : : static void
4824 : 21551 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4825 : : gfc_expr * expr)
4826 : : {
4827 : 23080 : gfc_interface_sym_mapping *sym;
4828 : 23080 : gfc_actual_arglist *actual;
4829 : :
4830 : 23080 : if (!expr)
4831 : : return;
4832 : :
4833 : : /* Copying an expression does not copy its length, so do that here. */
4834 : 13266 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4835 : : {
4836 : 1871 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4837 : 1871 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4838 : : }
4839 : :
4840 : : /* Apply the mapping to any references. */
4841 : 13266 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4842 : :
4843 : : /* ...and to the expression's symbol, if it has one. */
4844 : : /* TODO Find out why the condition on expr->symtree had to be moved into
4845 : : the loop rather than being outside it, as originally. */
4846 : 32687 : for (sym = mapping->syms; sym; sym = sym->next)
4847 : 19421 : if (expr->symtree && sym->old == expr->symtree->n.sym)
4848 : : {
4849 : 2819 : if (sym->new_sym->n.sym->backend_decl)
4850 : 2775 : expr->symtree = sym->new_sym;
4851 : 44 : else if (sym->expr)
4852 : 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4853 : : }
4854 : :
4855 : : /* ...and to subexpressions in expr->value. */
4856 : 13266 : switch (expr->expr_type)
4857 : : {
4858 : : case EXPR_VARIABLE:
4859 : : case EXPR_CONSTANT:
4860 : : case EXPR_NULL:
4861 : : case EXPR_SUBSTRING:
4862 : : break;
4863 : :
4864 : 1529 : case EXPR_OP:
4865 : 1529 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4866 : 1529 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4867 : 1529 : break;
4868 : :
4869 : 2919 : case EXPR_FUNCTION:
4870 : 9346 : for (actual = expr->value.function.actual; actual; actual = actual->next)
4871 : 6427 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4872 : :
4873 : 2919 : if (expr->value.function.esym == NULL
4874 : 2608 : && expr->value.function.isym != NULL
4875 : 2608 : && expr->value.function.actual
4876 : 2607 : && expr->value.function.actual->expr
4877 : 2607 : && expr->value.function.actual->expr->symtree
4878 : 5109 : && gfc_map_intrinsic_function (expr, mapping))
4879 : : break;
4880 : :
4881 : 5945 : for (sym = mapping->syms; sym; sym = sym->next)
4882 : 3416 : if (sym->old == expr->value.function.esym)
4883 : : {
4884 : 24 : expr->value.function.esym = sym->new_sym->n.sym;
4885 : 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4886 : 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
4887 : : }
4888 : : break;
4889 : :
4890 : 47 : case EXPR_ARRAY:
4891 : 47 : case EXPR_STRUCTURE:
4892 : 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4893 : 47 : break;
4894 : :
4895 : 0 : case EXPR_COMPCALL:
4896 : 0 : case EXPR_PPC:
4897 : 0 : case EXPR_UNKNOWN:
4898 : 0 : gcc_unreachable ();
4899 : : break;
4900 : : }
4901 : :
4902 : : return;
4903 : : }
4904 : :
4905 : :
4906 : : /* Evaluate interface expression EXPR using MAPPING. Store the result
4907 : : in SE. */
4908 : :
4909 : : void
4910 : 4710 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4911 : : gfc_se * se, gfc_expr * expr)
4912 : : {
4913 : 4710 : expr = gfc_copy_expr (expr);
4914 : 4710 : gfc_apply_interface_mapping_to_expr (mapping, expr);
4915 : 4710 : gfc_conv_expr (se, expr);
4916 : 4710 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
4917 : 4710 : gfc_free_expr (expr);
4918 : 4710 : }
4919 : :
4920 : :
4921 : : /* Returns a reference to a temporary array into which a component of
4922 : : an actual argument derived type array is copied and then returned
4923 : : after the function call. */
4924 : : void
4925 : 2139 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4926 : : sym_intent intent, bool formal_ptr,
4927 : : const gfc_symbol *fsym, const char *proc_name,
4928 : : gfc_symbol *sym, bool check_contiguous)
4929 : : {
4930 : 2139 : gfc_se lse;
4931 : 2139 : gfc_se rse;
4932 : 2139 : gfc_ss *lss;
4933 : 2139 : gfc_ss *rss;
4934 : 2139 : gfc_loopinfo loop;
4935 : 2139 : gfc_loopinfo loop2;
4936 : 2139 : gfc_array_info *info;
4937 : 2139 : tree offset;
4938 : 2139 : tree tmp_index;
4939 : 2139 : tree tmp;
4940 : 2139 : tree base_type;
4941 : 2139 : tree size;
4942 : 2139 : stmtblock_t body;
4943 : 2139 : int n;
4944 : 2139 : int dimen;
4945 : 2139 : gfc_se work_se;
4946 : 2139 : gfc_se *parmse;
4947 : 2139 : bool pass_optional;
4948 : :
4949 : 2139 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4950 : :
4951 : 2139 : if (pass_optional || check_contiguous)
4952 : : {
4953 : 1326 : gfc_init_se (&work_se, NULL);
4954 : 1326 : parmse = &work_se;
4955 : : }
4956 : : else
4957 : : parmse = se;
4958 : :
4959 : 2139 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
4960 : : {
4961 : : /* We will create a temporary array, so let us warn. */
4962 : 868 : char * msg;
4963 : :
4964 : 868 : if (fsym && proc_name)
4965 : 868 : msg = xasprintf ("An array temporary was created for argument "
4966 : 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
4967 : : else
4968 : 0 : msg = xasprintf ("An array temporary was created");
4969 : :
4970 : 868 : tmp = build_int_cst (logical_type_node, 1);
4971 : 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4972 : : &expr->where, msg);
4973 : 868 : free (msg);
4974 : : }
4975 : :
4976 : 2139 : gfc_init_se (&lse, NULL);
4977 : 2139 : gfc_init_se (&rse, NULL);
4978 : :
4979 : : /* Walk the argument expression. */
4980 : 2139 : rss = gfc_walk_expr (expr);
4981 : :
4982 : 2139 : gcc_assert (rss != gfc_ss_terminator);
4983 : :
4984 : : /* Initialize the scalarizer. */
4985 : 2139 : gfc_init_loopinfo (&loop);
4986 : 2139 : gfc_add_ss_to_loop (&loop, rss);
4987 : :
4988 : : /* Calculate the bounds of the scalarization. */
4989 : 2139 : gfc_conv_ss_startstride (&loop);
4990 : :
4991 : : /* Build an ss for the temporary. */
4992 : 2139 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4993 : 150 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4994 : :
4995 : 2139 : base_type = gfc_typenode_for_spec (&expr->ts);
4996 : 2139 : if (GFC_ARRAY_TYPE_P (base_type)
4997 : 2139 : || GFC_DESCRIPTOR_TYPE_P (base_type))
4998 : 0 : base_type = gfc_get_element_type (base_type);
4999 : :
5000 : 2139 : if (expr->ts.type == BT_CLASS)
5001 : 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5002 : :
5003 : 3223 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5004 : 1084 : ? expr->ts.u.cl->backend_decl
5005 : : : NULL),
5006 : : loop.dimen);
5007 : :
5008 : 2139 : parmse->string_length = loop.temp_ss->info->string_length;
5009 : :
5010 : : /* Associate the SS with the loop. */
5011 : 2139 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5012 : :
5013 : : /* Setup the scalarizing loops. */
5014 : 2139 : gfc_conv_loop_setup (&loop, &expr->where);
5015 : :
5016 : : /* Pass the temporary descriptor back to the caller. */
5017 : 2139 : info = &loop.temp_ss->info->data.array;
5018 : 2139 : parmse->expr = info->descriptor;
5019 : :
5020 : : /* Setup the gfc_se structures. */
5021 : 2139 : gfc_copy_loopinfo_to_se (&lse, &loop);
5022 : 2139 : gfc_copy_loopinfo_to_se (&rse, &loop);
5023 : :
5024 : 2139 : rse.ss = rss;
5025 : 2139 : lse.ss = loop.temp_ss;
5026 : 2139 : gfc_mark_ss_chain_used (rss, 1);
5027 : 2139 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5028 : :
5029 : : /* Start the scalarized loop body. */
5030 : 2139 : gfc_start_scalarized_body (&loop, &body);
5031 : :
5032 : : /* Translate the expression. */
5033 : 2139 : gfc_conv_expr (&rse, expr);
5034 : :
5035 : : /* Reset the offset for the function call since the loop
5036 : : is zero based on the data pointer. Note that the temp
5037 : : comes first in the loop chain since it is added second. */
5038 : 2139 : if (gfc_is_class_array_function (expr))
5039 : : {
5040 : 13 : tmp = loop.ss->loop_chain->info->data.array.descriptor;
5041 : 13 : gfc_conv_descriptor_offset_set (&loop.pre, tmp,
5042 : : gfc_index_zero_node);
5043 : : }
5044 : :
5045 : 2139 : gfc_conv_tmp_array_ref (&lse);
5046 : :
5047 : 2139 : if (intent != INTENT_OUT)
5048 : : {
5049 : 2096 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5050 : 2096 : gfc_add_expr_to_block (&body, tmp);
5051 : 2096 : gcc_assert (rse.ss == gfc_ss_terminator);
5052 : 2096 : gfc_trans_scalarizing_loops (&loop, &body);
5053 : : }
5054 : : else
5055 : : {
5056 : : /* Make sure that the temporary declaration survives by merging
5057 : : all the loop declarations into the current context. */
5058 : 100 : for (n = 0; n < loop.dimen; n++)
5059 : : {
5060 : 57 : gfc_merge_block_scope (&body);
5061 : 57 : body = loop.code[loop.order[n]];
5062 : : }
5063 : 43 : gfc_merge_block_scope (&body);
5064 : : }
5065 : :
5066 : : /* Add the post block after the second loop, so that any
5067 : : freeing of allocated memory is done at the right time. */
5068 : 2139 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5069 : :
5070 : : /**********Copy the temporary back again.*********/
5071 : :
5072 : 2139 : gfc_init_se (&lse, NULL);
5073 : 2139 : gfc_init_se (&rse, NULL);
5074 : :
5075 : : /* Walk the argument expression. */
5076 : 2139 : lss = gfc_walk_expr (expr);
5077 : 2139 : rse.ss = loop.temp_ss;
5078 : 2139 : lse.ss = lss;
5079 : :
5080 : : /* Initialize the scalarizer. */
5081 : 2139 : gfc_init_loopinfo (&loop2);
5082 : 2139 : gfc_add_ss_to_loop (&loop2, lss);
5083 : :
5084 : 2139 : dimen = rse.ss->dimen;
5085 : :
5086 : : /* Skip the write-out loop for this case. */
5087 : 2139 : if (gfc_is_class_array_function (expr))
5088 : 13 : goto class_array_fcn;
5089 : :
5090 : : /* Calculate the bounds of the scalarization. */
5091 : 2126 : gfc_conv_ss_startstride (&loop2);
5092 : :
5093 : : /* Setup the scalarizing loops. */
5094 : 2126 : gfc_conv_loop_setup (&loop2, &expr->where);
5095 : :
5096 : 2126 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5097 : 2126 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5098 : :
5099 : 2126 : gfc_mark_ss_chain_used (lss, 1);
5100 : 2126 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5101 : :
5102 : : /* Declare the variable to hold the temporary offset and start the
5103 : : scalarized loop body. */
5104 : 2126 : offset = gfc_create_var (gfc_array_index_type, NULL);
5105 : 2126 : gfc_start_scalarized_body (&loop2, &body);
5106 : :
5107 : : /* Build the offsets for the temporary from the loop variables. The
5108 : : temporary array has lbounds of zero and strides of one in all
5109 : : dimensions, so this is very simple. The offset is only computed
5110 : : outside the innermost loop, so the overall transfer could be
5111 : : optimized further. */
5112 : 2126 : info = &rse.ss->info->data.array;
5113 : :
5114 : 2126 : tmp_index = gfc_index_zero_node;
5115 : 3412 : for (n = dimen - 1; n > 0; n--)
5116 : : {
5117 : 1286 : tree tmp_str;
5118 : 1286 : tmp = rse.loop->loopvar[n];
5119 : 1286 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5120 : : tmp, rse.loop->from[n]);
5121 : 1286 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5122 : : tmp, tmp_index);
5123 : :
5124 : 2572 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5125 : : gfc_array_index_type,
5126 : 1286 : rse.loop->to[n-1], rse.loop->from[n-1]);
5127 : 1286 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5128 : : gfc_array_index_type,
5129 : : tmp_str, gfc_index_one_node);
5130 : :
5131 : 1286 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5132 : : gfc_array_index_type, tmp, tmp_str);
5133 : : }
5134 : :
5135 : 4252 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5136 : : gfc_array_index_type,
5137 : 2126 : tmp_index, rse.loop->from[0]);
5138 : 2126 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5139 : :
5140 : 4252 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5141 : : gfc_array_index_type,
5142 : 2126 : rse.loop->loopvar[0], offset);
5143 : :
5144 : : /* Now use the offset for the reference. */
5145 : 2126 : tmp = build_fold_indirect_ref_loc (input_location,
5146 : : info->data);
5147 : 2126 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5148 : :
5149 : 2126 : if (expr->ts.type == BT_CHARACTER)
5150 : 1084 : rse.string_length = expr->ts.u.cl->backend_decl;
5151 : :
5152 : 2126 : gfc_conv_expr (&lse, expr);
5153 : :
5154 : 2126 : gcc_assert (lse.ss == gfc_ss_terminator);
5155 : :
5156 : 2126 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5157 : 2126 : gfc_add_expr_to_block (&body, tmp);
5158 : :
5159 : : /* Generate the copying loops. */
5160 : 2126 : gfc_trans_scalarizing_loops (&loop2, &body);
5161 : :
5162 : : /* Wrap the whole thing up by adding the second loop to the post-block
5163 : : and following it by the post-block of the first loop. In this way,
5164 : : if the temporary needs freeing, it is done after use! */
5165 : 2126 : if (intent != INTENT_IN)
5166 : : {
5167 : 1154 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5168 : 1154 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5169 : : }
5170 : :
5171 : 972 : class_array_fcn:
5172 : :
5173 : 2139 : gfc_add_block_to_block (&parmse->post, &loop.post);
5174 : :
5175 : 2139 : gfc_cleanup_loop (&loop);
5176 : 2139 : gfc_cleanup_loop (&loop2);
5177 : :
5178 : : /* Pass the string length to the argument expression. */
5179 : 2139 : if (expr->ts.type == BT_CHARACTER)
5180 : 1084 : parmse->string_length = expr->ts.u.cl->backend_decl;
5181 : :
5182 : : /* Determine the offset for pointer formal arguments and set the
5183 : : lbounds to one. */
5184 : 2139 : if (formal_ptr)
5185 : : {
5186 : 0 : size = gfc_index_one_node;
5187 : 0 : offset = gfc_index_zero_node;
5188 : 0 : for (n = 0; n < dimen; n++)
5189 : : {
5190 : 0 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5191 : : gfc_rank_cst[n]);
5192 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5193 : : gfc_array_index_type, tmp,
5194 : : gfc_index_one_node);
5195 : 0 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5196 : : parmse->expr,
5197 : : gfc_rank_cst[n],
5198 : : tmp);
5199 : 0 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5200 : : parmse->expr,
5201 : : gfc_rank_cst[n],
5202 : : gfc_index_one_node);
5203 : 0 : size = gfc_evaluate_now (size, &parmse->pre);
5204 : 0 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5205 : : gfc_array_index_type,
5206 : : offset, size);
5207 : 0 : offset = gfc_evaluate_now (offset, &parmse->pre);
5208 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5209 : : gfc_array_index_type,
5210 : 0 : rse.loop->to[n], rse.loop->from[n]);
5211 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5212 : : gfc_array_index_type,
5213 : : tmp, gfc_index_one_node);
5214 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
5215 : : gfc_array_index_type, size, tmp);
5216 : : }
5217 : :
5218 : 0 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5219 : : offset);
5220 : : }
5221 : :
5222 : : /* We want either the address for the data or the address of the descriptor,
5223 : : depending on the mode of passing array arguments. */
5224 : 2139 : if (g77)
5225 : 368 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5226 : : else
5227 : 1771 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5228 : :
5229 : : /* Basically make this into
5230 : :
5231 : : if (present)
5232 : : {
5233 : : if (contiguous)
5234 : : {
5235 : : pointer = a;
5236 : : }
5237 : : else
5238 : : {
5239 : : parmse->pre();
5240 : : pointer = parmse->expr;
5241 : : }
5242 : : }
5243 : : else
5244 : : pointer = NULL;
5245 : :
5246 : : foo (pointer);
5247 : : if (present && !contiguous)
5248 : : se->post();
5249 : :
5250 : : */
5251 : :
5252 : 2139 : if (pass_optional || check_contiguous)
5253 : : {
5254 : 1326 : tree type;
5255 : 1326 : stmtblock_t else_block;
5256 : 1326 : tree pre_stmts, post_stmts;
5257 : 1326 : tree pointer;
5258 : 1326 : tree else_stmt;
5259 : 1326 : tree present_var = NULL_TREE;
5260 : 1326 : tree cont_var = NULL_TREE;
5261 : 1326 : tree post_cond;
5262 : :
5263 : 1326 : type = TREE_TYPE (parmse->expr);
5264 : 1326 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5265 : 1003 : type = TREE_TYPE (type);
5266 : 1326 : pointer = gfc_create_var (type, "arg_ptr");
5267 : :
5268 : 1326 : if (check_contiguous)
5269 : : {
5270 : 1326 : gfc_se cont_se, array_se;
5271 : 1326 : stmtblock_t if_block, else_block;
5272 : 1326 : tree if_stmt, else_stmt;
5273 : 1326 : mpz_t size;
5274 : 1326 : bool size_set;
5275 : :
5276 : 1326 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5277 : :
5278 : : /* If the size is known to be one at compile-time, set
5279 : : cont_var to true unconditionally. This may look
5280 : : inelegant, but we're only doing this during
5281 : : optimization, so the statements will be optimized away,
5282 : : and this saves complexity here. */
5283 : :
5284 : 1326 : size_set = gfc_array_size (expr, &size);
5285 : 1326 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5286 : : {
5287 : 36 : gfc_add_modify (&se->pre, cont_var,
5288 : : build_one_cst (boolean_type_node));
5289 : : }
5290 : : else
5291 : : {
5292 : : /* cont_var = is_contiguous (expr); . */
5293 : 1290 : gfc_init_se (&cont_se, parmse);
5294 : 1290 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5295 : 1290 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5296 : 1290 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5297 : 1290 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5298 : : }
5299 : :
5300 : 1326 : if (size_set)
5301 : 1157 : mpz_clear (size);
5302 : :
5303 : : /* arrayse->expr = descriptor of a. */
5304 : 1326 : gfc_init_se (&array_se, se);
5305 : 1326 : gfc_conv_expr_descriptor (&array_se, expr);
5306 : 1326 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5307 : 1326 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5308 : :
5309 : : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5310 : 1326 : gfc_init_block (&if_block);
5311 : 1326 : if (GFC_DESCRIPTOR_TYPE_P (type))
5312 : 1003 : gfc_add_modify (&if_block, pointer, array_se.expr);
5313 : : else
5314 : : {
5315 : 323 : tmp = gfc_conv_array_data (array_se.expr);
5316 : 323 : tmp = fold_convert (type, tmp);
5317 : 323 : gfc_add_modify (&if_block, pointer, tmp);
5318 : : }
5319 : 1326 : if_stmt = gfc_finish_block (&if_block);
5320 : :
5321 : : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5322 : 1326 : gfc_init_block (&else_block);
5323 : 1326 : gfc_add_block_to_block (&else_block, &parmse->pre);
5324 : 1326 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5325 : 1326 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5326 : : : parmse->expr);
5327 : 1326 : gfc_add_modify (&else_block, pointer, tmp);
5328 : 1326 : else_stmt = gfc_finish_block (&else_block);
5329 : :
5330 : : /* And put the above into an if statement. */
5331 : 1326 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5332 : : gfc_likely (cont_var,
5333 : : PRED_FORTRAN_CONTIGUOUS),
5334 : : if_stmt, else_stmt);
5335 : : }
5336 : : else
5337 : : {
5338 : : /* pointer = pramse->expr; . */
5339 : 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5340 : 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5341 : : }
5342 : :
5343 : 1326 : if (pass_optional)
5344 : : {
5345 : 26 : present_var = gfc_create_var (boolean_type_node, "present");
5346 : :
5347 : : /* present_var = present(sym); . */
5348 : 26 : tmp = gfc_conv_expr_present (sym);
5349 : 26 : tmp = fold_convert (boolean_type_node, tmp);
5350 : 26 : gfc_add_modify (&se->pre, present_var, tmp);
5351 : :
5352 : : /* else_stmt = { pointer = NULL; } . */
5353 : 26 : gfc_init_block (&else_block);
5354 : 26 : if (GFC_DESCRIPTOR_TYPE_P (type))
5355 : 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5356 : : null_pointer_node);
5357 : : else
5358 : 26 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5359 : 26 : else_stmt = gfc_finish_block (&else_block);
5360 : :
5361 : 26 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5362 : : gfc_likely (present_var,
5363 : : PRED_FORTRAN_ABSENT_DUMMY),
5364 : : pre_stmts, else_stmt);
5365 : 26 : gfc_add_expr_to_block (&se->pre, tmp);
5366 : : }
5367 : : else
5368 : 1300 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5369 : :
5370 : 1326 : post_stmts = gfc_finish_block (&parmse->post);
5371 : :
5372 : : /* Put together the post stuff, plus the optional
5373 : : deallocation. */
5374 : 1326 : if (check_contiguous)
5375 : : {
5376 : : /* !cont_var. */
5377 : 1326 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5378 : : cont_var,
5379 : : build_zero_cst (boolean_type_node));
5380 : 1326 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5381 : :
5382 : 1326 : if (pass_optional)
5383 : : {
5384 : 26 : tree present_likely = gfc_likely (present_var,
5385 : : PRED_FORTRAN_ABSENT_DUMMY);
5386 : 26 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5387 : : boolean_type_node, present_likely,
5388 : : tmp);
5389 : : }
5390 : : else
5391 : : post_cond = tmp;
5392 : : }
5393 : : else
5394 : : {
5395 : 0 : gcc_assert (pass_optional);
5396 : : post_cond = present_var;
5397 : : }
5398 : :
5399 : 1326 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5400 : : post_stmts, build_empty_stmt (input_location));
5401 : 1326 : gfc_add_expr_to_block (&se->post, tmp);
5402 : 1326 : if (GFC_DESCRIPTOR_TYPE_P (type))
5403 : : {
5404 : 1003 : type = TREE_TYPE (parmse->expr);
5405 : 1003 : if (POINTER_TYPE_P (type))
5406 : : {
5407 : 1003 : pointer = gfc_build_addr_expr (type, pointer);
5408 : 1003 : if (pass_optional)
5409 : : {
5410 : 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5411 : 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5412 : : tmp, pointer,
5413 : : fold_convert (type,
5414 : : null_pointer_node));
5415 : : }
5416 : : }
5417 : : else
5418 : 0 : gcc_assert (!pass_optional);
5419 : : }
5420 : 1326 : se->expr = pointer;
5421 : : }
5422 : :
5423 : 2139 : return;
5424 : : }
5425 : :
5426 : :
5427 : : /* Generate the code for argument list functions. */
5428 : :
5429 : : static void
5430 : 3517 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5431 : : {
5432 : : /* Pass by value for g77 %VAL(arg), pass the address
5433 : : indirectly for %LOC, else by reference. Thus %REF
5434 : : is a "do-nothing" and %LOC is the same as an F95
5435 : : pointer. */
5436 : 3517 : if (strcmp (name, "%VAL") == 0)
5437 : 3445 : gfc_conv_expr (se, expr);
5438 : 72 : else if (strcmp (name, "%LOC") == 0)
5439 : : {
5440 : 36 : gfc_conv_expr_reference (se, expr);
5441 : 36 : se->expr = gfc_build_addr_expr (NULL, se->expr);
5442 : : }
5443 : 36 : else if (strcmp (name, "%REF") == 0)
5444 : 36 : gfc_conv_expr_reference (se, expr);
5445 : : else
5446 : 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
5447 : 3517 : }
5448 : :
5449 : :
5450 : : /* This function tells whether the middle-end representation of the expression
5451 : : E given as input may point to data otherwise accessible through a variable
5452 : : (sub-)reference.
5453 : : It is assumed that the only expressions that may alias are variables,
5454 : : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5455 : : may alias.
5456 : : This function is used to decide whether freeing an expression's allocatable
5457 : : components is safe or should be avoided.
5458 : :
5459 : : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5460 : : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5461 : : is necessary because for array constructors, aliasing depends on how
5462 : : the array is used:
5463 : : - If E is an array constructor used as argument to an elemental procedure,
5464 : : the array, which is generated through shallow copy by the scalarizer,
5465 : : is used directly and can alias the expressions it was copied from.
5466 : : - If E is an array constructor used as argument to a non-elemental
5467 : : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5468 : : the array as in the previous case, but then that array is used
5469 : : to initialize a new descriptor through deep copy. There is no alias
5470 : : possible in that case.
5471 : : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5472 : : above. */
5473 : :
5474 : : static bool
5475 : 6899 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5476 : : {
5477 : 6899 : gfc_constructor *c;
5478 : :
5479 : 6899 : if (e->expr_type == EXPR_VARIABLE)
5480 : : return true;
5481 : 336 : else if (e->expr_type == EXPR_FUNCTION)
5482 : : {
5483 : 138 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5484 : :
5485 : 138 : if (proc_ifc->result != NULL
5486 : 138 : && ((proc_ifc->result->ts.type == BT_CLASS
5487 : 25 : && proc_ifc->result->ts.u.derived->attr.is_class
5488 : 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5489 : 138 : || proc_ifc->result->attr.pointer))
5490 : : return true;
5491 : : else
5492 : : return false;
5493 : : }
5494 : 198 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5495 : : return false;
5496 : :
5497 : 54 : for (c = gfc_constructor_first (e->value.constructor);
5498 : 78 : c; c = gfc_constructor_next (c))
5499 : 54 : if (c->expr
5500 : 54 : && expr_may_alias_variables (c->expr, array_may_alias))
5501 : : return true;
5502 : :
5503 : : return false;
5504 : : }
5505 : :
5506 : :
5507 : : /* A helper function to set the dtype for unallocated or unassociated
5508 : : entities. */
5509 : :
5510 : : static void
5511 : 711 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5512 : : {
5513 : 711 : tree tmp;
5514 : 711 : tree desc;
5515 : 711 : tree cond;
5516 : 711 : tree type;
5517 : 711 : stmtblock_t block;
5518 : :
5519 : : /* TODO Figure out how to handle optional dummies. */
5520 : 711 : if (e && e->expr_type == EXPR_VARIABLE
5521 : 711 : && e->symtree->n.sym->attr.optional)
5522 : 72 : return;
5523 : :
5524 : 639 : desc = parmse->expr;
5525 : 639 : if (desc == NULL_TREE)
5526 : : return;
5527 : :
5528 : 639 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
5529 : 639 : desc = build_fold_indirect_ref_loc (input_location, desc);
5530 : 639 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
5531 : 192 : desc = gfc_class_data_get (desc);
5532 : 639 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5533 : : return;
5534 : :
5535 : 639 : gfc_init_block (&block);
5536 : 639 : tmp = gfc_conv_descriptor_data_get (desc);
5537 : 639 : cond = fold_build2_loc (input_location, EQ_EXPR,
5538 : : logical_type_node, tmp,
5539 : 639 : build_int_cst (TREE_TYPE (tmp), 0));
5540 : 639 : tmp = gfc_conv_descriptor_dtype (desc);
5541 : 639 : type = gfc_get_element_type (TREE_TYPE (desc));
5542 : 1278 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5543 : 639 : TREE_TYPE (tmp), tmp,
5544 : : gfc_get_dtype_rank_type (e->rank, type));
5545 : 639 : gfc_add_expr_to_block (&block, tmp);
5546 : 639 : cond = build3_v (COND_EXPR, cond,
5547 : : gfc_finish_block (&block),
5548 : : build_empty_stmt (input_location));
5549 : 639 : gfc_add_expr_to_block (&parmse->pre, cond);
5550 : : }
5551 : :
5552 : :
5553 : :
5554 : : /* Provide an interface between gfortran array descriptors and the F2018:18.4
5555 : : ISO_Fortran_binding array descriptors. */
5556 : :
5557 : : static void
5558 : 6338 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5559 : : {
5560 : 6338 : stmtblock_t block, block2;
5561 : 6338 : tree cfi, gfc, tmp, tmp2;
5562 : 6338 : tree present = NULL;
5563 : 6338 : tree gfc_strlen = NULL;
5564 : 6338 : tree rank;
5565 : 6338 : gfc_se se;
5566 : :
5567 : 6338 : if (fsym->attr.optional
5568 : 932 : && e->expr_type == EXPR_VARIABLE
5569 : 932 : && e->symtree->n.sym->attr.optional)
5570 : 7 : present = gfc_conv_expr_present (e->symtree->n.sym);
5571 : :
5572 : 6338 : gfc_init_block (&block);
5573 : :
5574 : : /* Convert original argument to a tree. */
5575 : 6338 : gfc_init_se (&se, NULL);
5576 : 6338 : if (e->rank == 0)
5577 : : {
5578 : 602 : se.want_pointer = 1;
5579 : 602 : gfc_conv_expr (&se, e);
5580 : 602 : gfc = se.expr;
5581 : : /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5582 : 602 : if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
5583 : 20 : gfc = gfc_build_addr_expr (NULL, gfc);
5584 : : }
5585 : : else
5586 : : {
5587 : : /* If the actual argument can be noncontiguous, copy-in/out is required,
5588 : : if the dummy has either the CONTIGUOUS attribute or is an assumed-
5589 : : length assumed-length/assumed-size CHARACTER array. This only
5590 : : applies if the actual argument is a "variable"; if it's some
5591 : : non-lvalue expression, we are going to evaluate it to a
5592 : : temporary below anyway. */
5593 : 5736 : se.force_no_tmp = 1;
5594 : 5736 : if ((fsym->attr.contiguous
5595 : 4655 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
5596 : 1297 : && (fsym->as->type == AS_ASSUMED_SIZE
5597 : 865 : || fsym->as->type == AS_EXPLICIT)))
5598 : 1945 : && !gfc_is_simply_contiguous (e, false, true)
5599 : 6745 : && gfc_expr_is_variable (e))
5600 : : {
5601 : 1003 : bool optional = fsym->attr.optional;
5602 : 1003 : fsym->attr.optional = 0;
5603 : 1003 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
5604 : 1003 : fsym->attr.pointer, fsym,
5605 : 1003 : fsym->ns->proc_name->name, NULL,
5606 : : /* check_contiguous= */ true);
5607 : 1003 : fsym->attr.optional = optional;
5608 : : }
5609 : : else
5610 : 4733 : gfc_conv_expr_descriptor (&se, e);
5611 : 5736 : gfc = se.expr;
5612 : : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5613 : : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5614 : : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5615 : : While sm is fine as it uses span*stride and not elem_len. */
5616 : 5736 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
5617 : 1003 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
5618 : 4733 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
5619 : 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
5620 : : }
5621 : 6338 : if (e->ts.type == BT_CHARACTER)
5622 : : {
5623 : 3259 : if (se.string_length)
5624 : : gfc_strlen = se.string_length;
5625 : 865 : else if (e->ts.u.cl->backend_decl)
5626 : : gfc_strlen = e->ts.u.cl->backend_decl;
5627 : : else
5628 : 0 : gcc_unreachable ();
5629 : : }
5630 : 6338 : gfc_add_block_to_block (&block, &se.pre);
5631 : :
5632 : : /* Create array descriptor and set version, rank, attribute, type. */
5633 : 12371 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
5634 : : ? GFC_MAX_DIMENSIONS : e->rank,
5635 : : false), "cfi");
5636 : : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5637 : 6338 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
5638 : : {
5639 : 2302 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
5640 : 2302 : tmp = build_pointer_type (tmp);
5641 : 2302 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
5642 : 2302 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
5643 : : }
5644 : : else
5645 : 4036 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
5646 : :
5647 : 6338 : tmp = gfc_get_cfi_desc_version (cfi);
5648 : 6338 : gfc_add_modify (&block, tmp,
5649 : 6338 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
5650 : 6338 : if (e->rank < 0)
5651 : 305 : rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
5652 : : else
5653 : 6033 : rank = build_int_cst (signed_char_type_node, e->rank);
5654 : 6338 : tmp = gfc_get_cfi_desc_rank (cfi);
5655 : 6338 : gfc_add_modify (&block, tmp, rank);
5656 : 6338 : int itype = CFI_type_other;
5657 : 6338 : if (e->ts.f90_type == BT_VOID)
5658 : 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5659 : 96 : ? CFI_type_cfunptr : CFI_type_cptr);
5660 : : else
5661 : : {
5662 : 6242 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
5663 : 1 : e->ts = fsym->ts;
5664 : 6242 : switch (e->ts.type)
5665 : : {
5666 : 2248 : case BT_INTEGER:
5667 : 2248 : case BT_LOGICAL:
5668 : 2248 : case BT_REAL:
5669 : 2248 : case BT_COMPLEX:
5670 : 2248 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
5671 : 2248 : break;
5672 : 3260 : case BT_CHARACTER:
5673 : 3260 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
5674 : 3260 : break;
5675 : : case BT_DERIVED:
5676 : 6338 : itype = CFI_type_struct;
5677 : : break;
5678 : 0 : case BT_VOID:
5679 : 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5680 : 0 : ? CFI_type_cfunptr : CFI_type_cptr);
5681 : : break;
5682 : : case BT_ASSUMED:
5683 : : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5684 : : break;
5685 : 1 : case BT_CLASS:
5686 : 1 : if (fsym->ts.type == BT_ASSUMED)
5687 : : {
5688 : : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
5689 : : // type specifier is assumed-type and is an unlimited polymorphic
5690 : : // entity." The actual argument _data component is passed.
5691 : : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5692 : : break;
5693 : : }
5694 : : else
5695 : 0 : gcc_unreachable ();
5696 : 0 : case BT_PROCEDURE:
5697 : 0 : case BT_HOLLERITH:
5698 : 0 : case BT_UNION:
5699 : 0 : case BT_BOZ:
5700 : 0 : case BT_UNKNOWN:
5701 : : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5702 : 0 : gcc_unreachable ();
5703 : : }
5704 : : }
5705 : :
5706 : 6338 : tmp = gfc_get_cfi_desc_type (cfi);
5707 : 6338 : gfc_add_modify (&block, tmp,
5708 : 6338 : build_int_cst (TREE_TYPE (tmp), itype));
5709 : :
5710 : 6338 : int attr = CFI_attribute_other;
5711 : 6338 : if (fsym->attr.pointer)
5712 : : attr = CFI_attribute_pointer;
5713 : 5576 : else if (fsym->attr.allocatable)
5714 : 433 : attr = CFI_attribute_allocatable;
5715 : 6338 : tmp = gfc_get_cfi_desc_attribute (cfi);
5716 : 6338 : gfc_add_modify (&block, tmp,
5717 : 6338 : build_int_cst (TREE_TYPE (tmp), attr));
5718 : :
5719 : : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
5720 : : That is very sensible for undefined pointers, but the C code might assume
5721 : : that the pointer retains the value, in particular, if it was NULL. */
5722 : 6338 : if (e->rank == 0)
5723 : : {
5724 : 602 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5725 : 602 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
5726 : : }
5727 : : else
5728 : : {
5729 : 5736 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5730 : 5736 : tmp2 = gfc_conv_descriptor_data_get (gfc);
5731 : 5736 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
5732 : : }
5733 : :
5734 : : /* Set elem_len if known - must be before the next if block.
5735 : : Note that allocatable implies 'len=:'. */
5736 : 6338 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
5737 : : {
5738 : : /* Length is known at compile time; use 'block' for it. */
5739 : 3024 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
5740 : 3024 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5741 : 3024 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5742 : : }
5743 : :
5744 : 6338 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
5745 : 91 : goto done;
5746 : :
5747 : : /* When allocatable + intent out, free the cfi descriptor. */
5748 : 6247 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
5749 : : {
5750 : 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5751 : 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
5752 : 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
5753 : 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
5754 : 90 : gfc_add_modify (&block, tmp,
5755 : 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
5756 : 90 : goto done;
5757 : : }
5758 : :
5759 : : /* If not unallocated/unassociated. */
5760 : 6157 : gfc_init_block (&block2);
5761 : :
5762 : : /* Set elem_len, which may be only known at run time. */
5763 : 6157 : if (e->ts.type == BT_CHARACTER
5764 : 3260 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
5765 : : {
5766 : 3258 : gcc_assert (gfc_strlen);
5767 : 3259 : tmp = gfc_strlen;
5768 : 3259 : if (e->ts.kind != 1)
5769 : 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5770 : : gfc_charlen_type_node, tmp,
5771 : : build_int_cst (gfc_charlen_type_node,
5772 : 1117 : e->ts.kind));
5773 : 3259 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5774 : 3259 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5775 : : }
5776 : 2898 : else if (e->ts.type == BT_ASSUMED)
5777 : : {
5778 : 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
5779 : 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5780 : 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5781 : : }
5782 : :
5783 : 6157 : if (e->ts.type == BT_ASSUMED)
5784 : : {
5785 : : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
5786 : : an CFI descriptor. Use the type in the descriptor as it provide
5787 : : mode information. (Quality of implementation feature.) */
5788 : 54 : tree cond;
5789 : 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
5790 : 54 : tree type = fold_convert (TREE_TYPE (ctype),
5791 : : gfc_conv_descriptor_type (gfc));
5792 : 54 : tree kind = fold_convert (TREE_TYPE (ctype),
5793 : : gfc_conv_descriptor_elem_len (gfc));
5794 : 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
5795 : 54 : kind, build_int_cst (TREE_TYPE (type),
5796 : 54 : CFI_type_kind_shift));
5797 : :
5798 : : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
5799 : : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
5800 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5801 : 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
5802 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5803 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
5804 : 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5805 : : ctype,
5806 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
5807 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5808 : : tmp, tmp2);
5809 : : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
5810 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5811 : 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
5812 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5813 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
5814 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5815 : : tmp, tmp2);
5816 : : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
5817 : : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
5818 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5819 : 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
5820 : 54 : tmp = build_int_cst (TREE_TYPE (type),
5821 : 54 : CFI_type_from_type_kind (CFI_type_Character, 1));
5822 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5823 : : ctype, tmp);
5824 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5825 : : tmp, tmp2);
5826 : : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
5827 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5828 : 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
5829 : 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
5830 : 54 : kind, build_int_cst (TREE_TYPE (type), 2));
5831 : 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
5832 : 54 : build_int_cst (TREE_TYPE (type),
5833 : 54 : CFI_type_Complex));
5834 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5835 : : ctype, tmp);
5836 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5837 : : tmp, tmp2);
5838 : : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
5839 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5840 : 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
5841 : 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5842 : 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
5843 : 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5844 : : cond, tmp);
5845 : 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5846 : 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
5847 : 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5848 : : cond, tmp);
5849 : 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
5850 : : type, kind);
5851 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5852 : : ctype, tmp);
5853 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5854 : : tmp, tmp2);
5855 : 54 : gfc_add_expr_to_block (&block2, tmp2);
5856 : : }
5857 : :
5858 : 6157 : if (e->rank != 0)
5859 : : {
5860 : : /* Loop: for (i = 0; i < rank; ++i). */
5861 : 5621 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5862 : : /* Loop body. */
5863 : 5621 : stmtblock_t loop_body;
5864 : 5621 : gfc_init_block (&loop_body);
5865 : : /* cfi->dim[i].lower_bound = (allocatable/pointer)
5866 : : ? gfc->dim[i].lbound : 0 */
5867 : 5621 : if (fsym->attr.pointer || fsym->attr.allocatable)
5868 : 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
5869 : : else
5870 : 4973 : tmp = gfc_index_zero_node;
5871 : 5621 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
5872 : : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
5873 : 5621 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5874 : : gfc_conv_descriptor_ubound_get (gfc, idx),
5875 : : gfc_conv_descriptor_lbound_get (gfc, idx));
5876 : 5621 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5877 : : tmp, gfc_index_one_node);
5878 : 5621 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
5879 : : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
5880 : 5621 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5881 : : gfc_conv_descriptor_stride_get (gfc, idx),
5882 : : gfc_conv_descriptor_span_get (gfc));
5883 : 5621 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
5884 : :
5885 : : /* Generate loop. */
5886 : 5621 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
5887 : 5621 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
5888 : : gfc_finish_block (&loop_body));
5889 : :
5890 : 5621 : if (e->expr_type == EXPR_VARIABLE
5891 : 5459 : && e->ref
5892 : 5459 : && e->ref->u.ar.type == AR_FULL
5893 : 2624 : && e->symtree->n.sym->attr.dummy
5894 : 904 : && e->symtree->n.sym->as
5895 : 904 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
5896 : : {
5897 : 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
5898 : 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
5899 : : }
5900 : : }
5901 : :
5902 : 6157 : if (fsym->attr.allocatable || fsym->attr.pointer)
5903 : : {
5904 : 1014 : tmp = gfc_get_cfi_desc_base_addr (cfi),
5905 : 1014 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5906 : : tmp, null_pointer_node);
5907 : 1014 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
5908 : : build_empty_stmt (input_location));
5909 : 1014 : gfc_add_expr_to_block (&block, tmp);
5910 : : }
5911 : : else
5912 : 5143 : gfc_add_block_to_block (&block, &block2);
5913 : :
5914 : :
5915 : 6338 : done:
5916 : 6338 : if (present)
5917 : : {
5918 : 7 : parmse->expr = build3_loc (input_location, COND_EXPR,
5919 : 7 : TREE_TYPE (parmse->expr),
5920 : : present, parmse->expr, null_pointer_node);
5921 : 7 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
5922 : : build_empty_stmt (input_location));
5923 : 7 : gfc_add_expr_to_block (&parmse->pre, tmp);
5924 : : }
5925 : : else
5926 : 6331 : gfc_add_block_to_block (&parmse->pre, &block);
5927 : :
5928 : 6338 : gfc_init_block (&block);
5929 : :
5930 : 6338 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
5931 : 1195 : || fsym->attr.intent == INTENT_IN)
5932 : 5351 : goto post_call;
5933 : :
5934 : 987 : gfc_init_block (&block2);
5935 : 987 : if (e->rank == 0)
5936 : : {
5937 : 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5938 : 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
5939 : : }
5940 : : else
5941 : : {
5942 : 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5943 : 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
5944 : :
5945 : 559 : if (fsym->attr.allocatable)
5946 : : {
5947 : : /* gfc->span = cfi->elem_len. */
5948 : 252 : tmp = fold_convert (gfc_array_index_type,
5949 : : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
5950 : : }
5951 : : else
5952 : : {
5953 : : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
5954 : : ? cfi->dim[0].sm : cfi->elem_len). */
5955 : 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
5956 : 307 : tmp2 = fold_convert (gfc_array_index_type,
5957 : : gfc_get_cfi_desc_elem_len (cfi));
5958 : 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
5959 : : gfc_array_index_type, tmp, tmp2);
5960 : 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5961 : : tmp, gfc_index_zero_node);
5962 : 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
5963 : : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
5964 : : }
5965 : 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
5966 : :
5967 : : /* Calculate offset + set lbound, ubound and stride. */
5968 : 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
5969 : : /* Loop: for (i = 0; i < rank; ++i). */
5970 : 559 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5971 : : /* Loop body. */
5972 : 559 : stmtblock_t loop_body;
5973 : 559 : gfc_init_block (&loop_body);
5974 : : /* gfc->dim[i].lbound = ... */
5975 : 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
5976 : 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
5977 : :
5978 : : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
5979 : 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5980 : : gfc_conv_descriptor_lbound_get (gfc, idx),
5981 : : gfc_index_one_node);
5982 : 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5983 : : gfc_get_cfi_dim_extent (cfi, idx), tmp);
5984 : 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
5985 : :
5986 : : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
5987 : 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
5988 : 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5989 : : gfc_array_index_type, tmp,
5990 : : fold_convert (gfc_array_index_type,
5991 : : gfc_get_cfi_desc_elem_len (cfi)));
5992 : 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
5993 : :
5994 : : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
5995 : 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5996 : : gfc_conv_descriptor_stride_get (gfc, idx),
5997 : : gfc_conv_descriptor_lbound_get (gfc, idx));
5998 : 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5999 : : gfc_conv_descriptor_offset_get (gfc), tmp);
6000 : 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6001 : : /* Generate loop. */
6002 : 559 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6003 : 559 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6004 : : gfc_finish_block (&loop_body));
6005 : : }
6006 : :
6007 : 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6008 : : {
6009 : 60 : tmp = fold_convert (gfc_charlen_type_node,
6010 : : gfc_get_cfi_desc_elem_len (cfi));
6011 : 60 : if (e->ts.kind != 1)
6012 : 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6013 : : gfc_charlen_type_node, tmp,
6014 : : build_int_cst (gfc_charlen_type_node,
6015 : 24 : e->ts.kind));
6016 : 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6017 : : }
6018 : :
6019 : 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6020 : 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6021 : : tmp, null_pointer_node);
6022 : 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6023 : : build_empty_stmt (input_location));
6024 : 987 : gfc_add_expr_to_block (&block, tmp);
6025 : :
6026 : 6338 : post_call:
6027 : 6338 : gfc_add_block_to_block (&block, &se.post);
6028 : 6338 : if (present && block.head)
6029 : : {
6030 : 0 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6031 : : build_empty_stmt (input_location));
6032 : 0 : gfc_add_expr_to_block (&parmse->post, tmp);
6033 : : }
6034 : 6338 : else if (block.head)
6035 : 1552 : gfc_add_block_to_block (&parmse->post, &block);
6036 : 6338 : }
6037 : :
6038 : :
6039 : : /* Generate code for a procedure call. Note can return se->post != NULL.
6040 : : If se->direct_byref is set then se->expr contains the return parameter.
6041 : : Return nonzero, if the call has alternate specifiers.
6042 : : 'expr' is only needed for procedure pointer components. */
6043 : :
6044 : : int
6045 : 115291 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6046 : : gfc_actual_arglist * args, gfc_expr * expr,
6047 : : vec<tree, va_gc> *append_args)
6048 : : {
6049 : 115291 : gfc_interface_mapping mapping;
6050 : 115291 : vec<tree, va_gc> *arglist;
6051 : 115291 : vec<tree, va_gc> *retargs;
6052 : 115291 : tree tmp;
6053 : 115291 : tree fntype;
6054 : 115291 : gfc_se parmse;
6055 : 115291 : gfc_array_info *info;
6056 : 115291 : int byref;
6057 : 115291 : int parm_kind;
6058 : 115291 : tree type;
6059 : 115291 : tree var;
6060 : 115291 : tree len;
6061 : 115291 : tree base_object;
6062 : 115291 : vec<tree, va_gc> *stringargs;
6063 : 115291 : vec<tree, va_gc> *optionalargs;
6064 : 115291 : tree result = NULL;
6065 : 115291 : gfc_formal_arglist *formal;
6066 : 115291 : gfc_actual_arglist *arg;
6067 : 115291 : int has_alternate_specifier = 0;
6068 : 115291 : bool need_interface_mapping;
6069 : 115291 : bool callee_alloc;
6070 : 115291 : bool ulim_copy;
6071 : 115291 : gfc_typespec ts;
6072 : 115291 : gfc_charlen cl;
6073 : 115291 : gfc_expr *e;
6074 : 115291 : gfc_symbol *fsym;
6075 : 115291 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6076 : 115291 : gfc_component *comp = NULL;
6077 : 115291 : int arglen;
6078 : 115291 : unsigned int argc;
6079 : :
6080 : 115291 : arglist = NULL;
6081 : 115291 : retargs = NULL;
6082 : 115291 : stringargs = NULL;
6083 : 115291 : optionalargs = NULL;
6084 : 115291 : var = NULL_TREE;
6085 : 115291 : len = NULL_TREE;
6086 : 115291 : gfc_clear_ts (&ts);
6087 : :
6088 : 115291 : comp = gfc_get_proc_ptr_comp (expr);
6089 : :
6090 : 230582 : bool elemental_proc = (comp
6091 : 1696 : && comp->ts.interface
6092 : 1651 : && comp->ts.interface->attr.elemental)
6093 : 1510 : || (comp && comp->attr.elemental)
6094 : 116801 : || sym->attr.elemental;
6095 : :
6096 : 115291 : if (se->ss != NULL)
6097 : : {
6098 : 19531 : if (!elemental_proc)
6099 : : {
6100 : 17271 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6101 : 17271 : if (se->ss->info->useflags)
6102 : : {
6103 : 6186 : gcc_assert ((!comp && gfc_return_by_reference (sym)
6104 : : && sym->result->attr.dimension)
6105 : : || (comp && comp->attr.dimension)
6106 : : || gfc_is_class_array_function (expr));
6107 : 6186 : gcc_assert (se->loop != NULL);
6108 : : /* Access the previously obtained result. */
6109 : 6186 : gfc_conv_tmp_array_ref (se);
6110 : 6186 : return 0;
6111 : : }
6112 : : }
6113 : 13345 : info = &se->ss->info->data.array;
6114 : : }
6115 : : else
6116 : : info = NULL;
6117 : :
6118 : 109105 : stmtblock_t post, clobbers, dealloc_blk;
6119 : 109105 : gfc_init_block (&post);
6120 : 109105 : gfc_init_block (&clobbers);
6121 : 109105 : gfc_init_block (&dealloc_blk);
6122 : 109105 : gfc_init_interface_mapping (&mapping);
6123 : 109105 : if (!comp)
6124 : : {
6125 : 107455 : formal = gfc_sym_get_dummy_args (sym);
6126 : 107455 : need_interface_mapping = sym->attr.dimension ||
6127 : 96562 : (sym->ts.type == BT_CHARACTER
6128 : 2753 : && sym->ts.u.cl->length
6129 : 2296 : && sym->ts.u.cl->length->expr_type
6130 : : != EXPR_CONSTANT);
6131 : : }
6132 : : else
6133 : : {
6134 : 1650 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
6135 : 1650 : need_interface_mapping = comp->attr.dimension ||
6136 : 1593 : (comp->ts.type == BT_CHARACTER
6137 : 67 : && comp->ts.u.cl->length
6138 : 58 : && comp->ts.u.cl->length->expr_type
6139 : : != EXPR_CONSTANT);
6140 : : }
6141 : :
6142 : 109105 : base_object = NULL_TREE;
6143 : : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6144 : : is the third and fourth argument to such a function call a value
6145 : : denoting the number of elements to copy (i.e., most of the time the
6146 : : length of a deferred length string). */
6147 : 218210 : ulim_copy = (formal == NULL)
6148 : 26214 : && UNLIMITED_POLY (sym)
6149 : 109130 : && comp && (strcmp ("_copy", comp->name) == 0);
6150 : :
6151 : : /* Scan for allocatable actual arguments passed to allocatable dummy
6152 : : arguments with INTENT(OUT). As the corresponding actual arguments are
6153 : : deallocated before execution of the procedure, we evaluate actual
6154 : : argument expressions to avoid problems with possible dependencies. */
6155 : 109105 : bool force_eval_args = false;
6156 : 109105 : gfc_formal_arglist *tmp_formal;
6157 : 340665 : for (arg = args, tmp_formal = formal; arg != NULL;
6158 : 198452 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
6159 : : {
6160 : 232033 : e = arg->expr;
6161 : 232033 : fsym = tmp_formal ? tmp_formal->sym : NULL;
6162 : 223789 : if (e && fsym
6163 : 191790 : && e->expr_type == EXPR_VARIABLE
6164 : 81407 : && fsym->attr.intent == INTENT_OUT
6165 : 5341 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
6166 : 5341 : ? CLASS_DATA (fsym)->attr.allocatable
6167 : 4143 : : fsym->attr.allocatable)
6168 : 473 : && e->symtree
6169 : 473 : && e->symtree->n.sym
6170 : 455822 : && gfc_variable_attr (e, NULL).allocatable)
6171 : : {
6172 : : force_eval_args = true;
6173 : : break;
6174 : : }
6175 : : }
6176 : :
6177 : : /* Evaluate the arguments. */
6178 : 341522 : for (arg = args, argc = 0; arg != NULL;
6179 : 232417 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
6180 : : {
6181 : 232417 : bool finalized = false;
6182 : 232417 : tree derived_array = NULL_TREE;
6183 : :
6184 : 232417 : e = arg->expr;
6185 : 232417 : fsym = formal ? formal->sym : NULL;
6186 : 431726 : parm_kind = MISSING;
6187 : :
6188 : : /* If the procedure requires an explicit interface, the actual
6189 : : argument is passed according to the corresponding formal
6190 : : argument. If the corresponding formal argument is a POINTER,
6191 : : ALLOCATABLE or assumed shape, we do not use g77's calling
6192 : : convention, and pass the address of the array descriptor
6193 : : instead. Otherwise we use g77's calling convention, in other words
6194 : : pass the array data pointer without descriptor. */
6195 : 431726 : bool nodesc_arg = fsym != NULL
6196 : 199256 : && !(fsym->attr.pointer || fsym->attr.allocatable)
6197 : 192035 : && fsym->as
6198 : 32216 : && fsym->as->type != AS_ASSUMED_SHAPE
6199 : 219051 : && fsym->as->type != AS_ASSUMED_RANK;
6200 : 232417 : if (comp)
6201 : 2530 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
6202 : : else
6203 : 229887 : nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
6204 : :
6205 : : /* Class array expressions are sometimes coming completely unadorned
6206 : : with either arrayspec or _data component. Correct that here.
6207 : : OOP-TODO: Move this to the frontend. */
6208 : 232417 : if (e && e->expr_type == EXPR_VARIABLE
6209 : 95541 : && !e->ref
6210 : 45642 : && e->ts.type == BT_CLASS
6211 : 2390 : && (CLASS_DATA (e)->attr.codimension
6212 : 2390 : || CLASS_DATA (e)->attr.dimension))
6213 : : {
6214 : 0 : gfc_typespec temp_ts = e->ts;
6215 : 0 : gfc_add_class_array_ref (e);
6216 : 0 : e->ts = temp_ts;
6217 : : }
6218 : :
6219 : 232417 : if (e == NULL)
6220 : : {
6221 : 8250 : if (se->ignore_optional)
6222 : : {
6223 : : /* Some intrinsics have already been resolved to the correct
6224 : : parameters. */
6225 : 326 : continue;
6226 : : }
6227 : 8148 : else if (arg->label)
6228 : : {
6229 : 224 : has_alternate_specifier = 1;
6230 : 224 : continue;
6231 : : }
6232 : : else
6233 : : {
6234 : 7924 : gfc_init_se (&parmse, NULL);
6235 : :
6236 : : /* For scalar arguments with VALUE attribute which are passed by
6237 : : value, pass "0" and a hidden argument gives the optional
6238 : : status. */
6239 : 7924 : if (fsym && fsym->attr.optional && fsym->attr.value
6240 : 7088 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS
6241 : 228 : && !gfc_bt_struct (sym->ts.type))
6242 : : {
6243 : 228 : if (fsym->ts.type == BT_CHARACTER)
6244 : : {
6245 : : /* Pass a NULL pointer for an absent CHARACTER arg
6246 : : and a length of zero. */
6247 : 18 : parmse.expr = null_pointer_node;
6248 : 18 : parmse.string_length
6249 : 18 : = build_int_cst (gfc_charlen_type_node,
6250 : 18 : 0);
6251 : : }
6252 : : else
6253 : 210 : parmse.expr = fold_convert (gfc_sym_type (fsym),
6254 : : integer_zero_node);
6255 : 228 : vec_safe_push (optionalargs, boolean_false_node);
6256 : : }
6257 : : else
6258 : : {
6259 : : /* Pass a NULL pointer for an absent arg. */
6260 : 7696 : parmse.expr = null_pointer_node;
6261 : 7696 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
6262 : 7696 : if (dummy_arg
6263 : 7696 : && gfc_dummy_arg_get_typespec (*dummy_arg).type
6264 : : == BT_CHARACTER)
6265 : 815 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
6266 : 815 : 0);
6267 : : }
6268 : : }
6269 : : }
6270 : 224167 : else if (arg->expr->expr_type == EXPR_NULL
6271 : 175 : && fsym && !fsym->attr.pointer
6272 : 86 : && (fsym->ts.type != BT_CLASS
6273 : 12 : || !CLASS_DATA (fsym)->attr.class_pointer))
6274 : : {
6275 : : /* Pass a NULL pointer to denote an absent arg. */
6276 : 80 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
6277 : : && (fsym->ts.type != BT_CLASS
6278 : : || !CLASS_DATA (fsym)->attr.allocatable));
6279 : 80 : gfc_init_se (&parmse, NULL);
6280 : 80 : parmse.expr = null_pointer_node;
6281 : 80 : if (arg->associated_dummy
6282 : 80 : && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
6283 : : == BT_CHARACTER)
6284 : 0 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
6285 : : }
6286 : 224087 : else if (fsym && fsym->ts.type == BT_CLASS
6287 : 9489 : && e->ts.type == BT_DERIVED)
6288 : : {
6289 : : /* The derived type needs to be converted to a temporary
6290 : : CLASS object. */
6291 : 3781 : gfc_init_se (&parmse, se);
6292 : 3781 : gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
6293 : 3781 : fsym->attr.optional
6294 : 1008 : && e->expr_type == EXPR_VARIABLE
6295 : 1008 : && e->symtree->n.sym->attr.optional,
6296 : 3781 : CLASS_DATA (fsym)->attr.class_pointer
6297 : 3781 : || CLASS_DATA (fsym)->attr.allocatable,
6298 : : &derived_array);
6299 : : }
6300 : 188307 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
6301 : 709 : && e->ts.type != BT_PROCEDURE
6302 : 697 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
6303 : 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
6304 : : {
6305 : : /* The intrinsic type needs to be converted to a temporary
6306 : : CLASS object for the unlimited polymorphic formal. */
6307 : 697 : gfc_find_vtab (&e->ts);
6308 : 697 : gfc_init_se (&parmse, se);
6309 : 697 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
6310 : :
6311 : : }
6312 : 219609 : else if (se->ss && se->ss->info->useflags)
6313 : : {
6314 : 3863 : gfc_ss *ss;
6315 : :
6316 : 3863 : ss = se->ss;
6317 : :
6318 : : /* An elemental function inside a scalarized loop. */
6319 : 3863 : gfc_init_se (&parmse, se);
6320 : 3863 : parm_kind = ELEMENTAL;
6321 : :
6322 : : /* When no fsym is present, ulim_copy is set and this is a third or
6323 : : fourth argument, use call-by-value instead of by reference to
6324 : : hand the length properties to the copy routine (i.e., most of the
6325 : : time this will be a call to a __copy_character_* routine where the
6326 : : third and fourth arguments are the lengths of a deferred length
6327 : : char array). */
6328 : 3863 : if ((fsym && fsym->attr.value)
6329 : 3851 : || (ulim_copy && (argc == 2 || argc == 3)))
6330 : 12 : gfc_conv_expr (&parmse, e);
6331 : : else
6332 : 3851 : gfc_conv_expr_reference (&parmse, e);
6333 : :
6334 : 3863 : if (e->ts.type == BT_CHARACTER && !e->rank
6335 : 54 : && e->expr_type == EXPR_FUNCTION)
6336 : 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
6337 : : parmse.expr);
6338 : :
6339 : 3825 : if (fsym && fsym->ts.type == BT_DERIVED
6340 : 5076 : && gfc_is_class_container_ref (e))
6341 : : {
6342 : 24 : parmse.expr = gfc_class_data_get (parmse.expr);
6343 : :
6344 : 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6345 : 24 : && e->symtree->n.sym->attr.optional)
6346 : : {
6347 : 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
6348 : 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
6349 : 0 : TREE_TYPE (parmse.expr),
6350 : : cond, parmse.expr,
6351 : 0 : fold_convert (TREE_TYPE (parmse.expr),
6352 : : null_pointer_node));
6353 : : }
6354 : : }
6355 : :
6356 : : /* If we are passing an absent array as optional dummy to an
6357 : : elemental procedure, make sure that we pass NULL when the data
6358 : : pointer is NULL. We need this extra conditional because of
6359 : : scalarization which passes arrays elements to the procedure,
6360 : : ignoring the fact that the array can be absent/unallocated/... */
6361 : 3863 : if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
6362 : : {
6363 : 137 : tree descriptor_data;
6364 : :
6365 : 137 : descriptor_data = ss->info->data.array.data;
6366 : 137 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6367 : : descriptor_data,
6368 : 137 : fold_convert (TREE_TYPE (descriptor_data),
6369 : : null_pointer_node));
6370 : 137 : parmse.expr
6371 : 274 : = fold_build3_loc (input_location, COND_EXPR,
6372 : 137 : TREE_TYPE (parmse.expr),
6373 : : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
6374 : 137 : fold_convert (TREE_TYPE (parmse.expr),
6375 : : null_pointer_node),
6376 : : parmse.expr);
6377 : : }
6378 : :
6379 : : /* The scalarizer does not repackage the reference to a class
6380 : : array - instead it returns a pointer to the data element. */
6381 : 3863 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
6382 : 156 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
6383 : 156 : fsym->attr.intent != INTENT_IN
6384 : 156 : && (CLASS_DATA (fsym)->attr.class_pointer
6385 : : || CLASS_DATA (fsym)->attr.allocatable),
6386 : 156 : fsym->attr.optional
6387 : 0 : && e->expr_type == EXPR_VARIABLE
6388 : 0 : && e->symtree->n.sym->attr.optional,
6389 : 156 : CLASS_DATA (fsym)->attr.class_pointer
6390 : 156 : || CLASS_DATA (fsym)->attr.allocatable);
6391 : : }
6392 : : else
6393 : : {
6394 : 215746 : bool scalar;
6395 : 215746 : gfc_ss *argss;
6396 : :
6397 : 215746 : gfc_init_se (&parmse, NULL);
6398 : :
6399 : : /* Check whether the expression is a scalar or not; we cannot use
6400 : : e->rank as it can be nonzero for functions arguments. */
6401 : 215746 : argss = gfc_walk_expr (e);
6402 : 215746 : scalar = argss == gfc_ss_terminator;
6403 : 215746 : if (!scalar)
6404 : 47669 : gfc_free_ss_chain (argss);
6405 : :
6406 : : /* Special handling for passing scalar polymorphic coarrays;
6407 : : otherwise one passes "class->_data.data" instead of "&class". */
6408 : 215746 : if (e->rank == 0 && e->ts.type == BT_CLASS
6409 : 3268 : && fsym && fsym->ts.type == BT_CLASS
6410 : 2864 : && CLASS_DATA (fsym)->attr.codimension
6411 : 2864 : && !CLASS_DATA (fsym)->attr.dimension)
6412 : : {
6413 : 47 : gfc_add_class_array_ref (e);
6414 : 47 : parmse.want_coarray = 1;
6415 : 47 : scalar = false;
6416 : : }
6417 : :
6418 : : /* A scalar or transformational function. */
6419 : 215746 : if (scalar)
6420 : : {
6421 : 168030 : if (e->expr_type == EXPR_VARIABLE
6422 : 49373 : && e->symtree->n.sym->attr.cray_pointee
6423 : 378 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
6424 : : {
6425 : : /* The Cray pointer needs to be converted to a pointer to
6426 : : a type given by the expression. */
6427 : 6 : gfc_conv_expr (&parmse, e);
6428 : 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
6429 : 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
6430 : 6 : parmse.expr = convert (type, tmp);
6431 : : }
6432 : :
6433 : 168024 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
6434 : : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6435 : 602 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6436 : :
6437 : 167422 : else if (fsym && fsym->attr.value)
6438 : : {
6439 : 20464 : if (fsym->ts.type == BT_CHARACTER
6440 : 441 : && fsym->ts.is_c_interop
6441 : 180 : && fsym->ns->proc_name != NULL
6442 : 180 : && fsym->ns->proc_name->attr.is_bind_c)
6443 : : {
6444 : 171 : parmse.expr = NULL;
6445 : 171 : conv_scalar_char_value (fsym, &parmse, &e);
6446 : 171 : if (parmse.expr == NULL)
6447 : 165 : gfc_conv_expr (&parmse, e);
6448 : : }
6449 : : else
6450 : : {
6451 : 20293 : gfc_conv_expr (&parmse, e);
6452 : :
6453 : : /* ABI: actual arguments to CHARACTER(len=1),VALUE
6454 : : dummy arguments are actually passed by value.
6455 : : Strings are truncated to length 1. */
6456 : 20293 : if (gfc_length_one_character_type_p (&fsym->ts))
6457 : : {
6458 : 240 : if (e->expr_type == EXPR_CONSTANT
6459 : 42 : && e->value.character.length > 1)
6460 : : {
6461 : 12 : e->value.character.length = 1;
6462 : 12 : gfc_conv_expr (&parmse, e);
6463 : : }
6464 : :
6465 : 240 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6466 : 240 : gfc_conv_string_parameter (&parmse);
6467 : 240 : parmse.expr
6468 : 240 : = gfc_string_to_single_character (slen1,
6469 : : parmse.expr,
6470 : : e->ts.kind);
6471 : : /* Truncate resulting string to length 1. */
6472 : 240 : parmse.string_length = slen1;
6473 : : }
6474 : :
6475 : 20293 : if (fsym->attr.optional
6476 : 237 : && fsym->ts.type != BT_CLASS
6477 : 237 : && fsym->ts.type != BT_DERIVED)
6478 : : {
6479 : 237 : if (e->expr_type != EXPR_VARIABLE
6480 : 153 : || !e->symtree->n.sym->attr.optional
6481 : 48 : || e->ref != NULL)
6482 : 189 : vec_safe_push (optionalargs, boolean_true_node);
6483 : : else
6484 : : {
6485 : 48 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6486 : 48 : if (!e->symtree->n.sym->attr.value)
6487 : 24 : parmse.expr
6488 : 48 : = fold_build3_loc (input_location, COND_EXPR,
6489 : 24 : TREE_TYPE (parmse.expr),
6490 : : tmp, parmse.expr,
6491 : 24 : fold_convert (TREE_TYPE (parmse.expr),
6492 : : integer_zero_node));
6493 : :
6494 : 96 : vec_safe_push (optionalargs,
6495 : 48 : fold_convert (boolean_type_node,
6496 : : tmp));
6497 : : }
6498 : : }
6499 : : }
6500 : : }
6501 : :
6502 : 146958 : else if (arg->name && arg->name[0] == '%')
6503 : : /* Argument list functions %VAL, %LOC and %REF are signalled
6504 : : through arg->name. */
6505 : 3517 : conv_arglist_function (&parmse, arg->expr, arg->name);
6506 : 143441 : else if ((e->expr_type == EXPR_FUNCTION)
6507 : 7055 : && ((e->value.function.esym
6508 : 2025 : && e->value.function.esym->result->attr.pointer)
6509 : 6955 : || (!e->value.function.esym
6510 : 5030 : && e->symtree->n.sym->attr.pointer))
6511 : 100 : && fsym && fsym->attr.target)
6512 : : /* Make sure the function only gets called once. */
6513 : 8 : gfc_conv_expr_reference (&parmse, e);
6514 : 143433 : else if (e->expr_type == EXPR_FUNCTION
6515 : 7047 : && e->symtree->n.sym->result
6516 : 6020 : && e->symtree->n.sym->result != e->symtree->n.sym
6517 : 111 : && e->symtree->n.sym->result->attr.proc_pointer)
6518 : : {
6519 : : /* Functions returning procedure pointers. */
6520 : 18 : gfc_conv_expr (&parmse, e);
6521 : 18 : if (fsym && fsym->attr.proc_pointer)
6522 : 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6523 : : }
6524 : :
6525 : : else
6526 : : {
6527 : 143415 : bool defer_to_dealloc_blk = false;
6528 : 143415 : if (e->ts.type == BT_CLASS && fsym
6529 : 3209 : && fsym->ts.type == BT_CLASS
6530 : 2805 : && (!CLASS_DATA (fsym)->as
6531 : 350 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
6532 : 2455 : && CLASS_DATA (e)->attr.codimension)
6533 : : {
6534 : 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
6535 : 48 : gcc_assert (!CLASS_DATA (fsym)->as);
6536 : 48 : gfc_add_class_array_ref (e);
6537 : 48 : parmse.want_coarray = 1;
6538 : 48 : gfc_conv_expr_reference (&parmse, e);
6539 : 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
6540 : 48 : fsym->attr.optional
6541 : 48 : && e->expr_type == EXPR_VARIABLE);
6542 : : }
6543 : 143367 : else if (e->ts.type == BT_CLASS && fsym
6544 : 3161 : && fsym->ts.type == BT_CLASS
6545 : 2757 : && !CLASS_DATA (fsym)->as
6546 : 2407 : && !CLASS_DATA (e)->as
6547 : 2297 : && strcmp (fsym->ts.u.derived->name,
6548 : : e->ts.u.derived->name))
6549 : : {
6550 : 1498 : type = gfc_typenode_for_spec (&fsym->ts);
6551 : 1498 : var = gfc_create_var (type, fsym->name);
6552 : 1498 : gfc_conv_expr (&parmse, e);
6553 : 1498 : if (fsym->attr.optional
6554 : 153 : && e->expr_type == EXPR_VARIABLE
6555 : 153 : && e->symtree->n.sym->attr.optional)
6556 : : {
6557 : 66 : stmtblock_t block;
6558 : 66 : tree cond;
6559 : 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6560 : 66 : cond = fold_build2_loc (input_location, NE_EXPR,
6561 : : logical_type_node, tmp,
6562 : 66 : fold_convert (TREE_TYPE (tmp),
6563 : : null_pointer_node));
6564 : 66 : gfc_start_block (&block);
6565 : 66 : gfc_add_modify (&block, var,
6566 : : fold_build1_loc (input_location,
6567 : : VIEW_CONVERT_EXPR,
6568 : : type, parmse.expr));
6569 : 66 : gfc_add_expr_to_block (&parmse.pre,
6570 : : fold_build3_loc (input_location,
6571 : : COND_EXPR, void_type_node,
6572 : : cond, gfc_finish_block (&block),
6573 : : build_empty_stmt (input_location)));
6574 : 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6575 : 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
6576 : 66 : TREE_TYPE (parmse.expr),
6577 : : cond, parmse.expr,
6578 : 66 : fold_convert (TREE_TYPE (parmse.expr),
6579 : : null_pointer_node));
6580 : 66 : }
6581 : : else
6582 : : {
6583 : : /* Since the internal representation of unlimited
6584 : : polymorphic expressions includes an extra field
6585 : : that other class objects do not, a cast to the
6586 : : formal type does not work. */
6587 : 1432 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
6588 : : {
6589 : 65 : tree efield;
6590 : :
6591 : : /* Set the _data field. */
6592 : 65 : tmp = gfc_class_data_get (var);
6593 : 65 : efield = fold_convert (TREE_TYPE (tmp),
6594 : : gfc_class_data_get (parmse.expr));
6595 : 65 : gfc_add_modify (&parmse.pre, tmp, efield);
6596 : :
6597 : : /* Set the _vptr field. */
6598 : 65 : tmp = gfc_class_vptr_get (var);
6599 : 65 : efield = fold_convert (TREE_TYPE (tmp),
6600 : : gfc_class_vptr_get (parmse.expr));
6601 : 65 : gfc_add_modify (&parmse.pre, tmp, efield);
6602 : :
6603 : : /* Set the _len field. */
6604 : 65 : tmp = gfc_class_len_get (var);
6605 : 65 : gfc_add_modify (&parmse.pre, tmp,
6606 : 65 : build_int_cst (TREE_TYPE (tmp), 0));
6607 : 65 : }
6608 : : else
6609 : : {
6610 : 1367 : tmp = fold_build1_loc (input_location,
6611 : : VIEW_CONVERT_EXPR,
6612 : : type, parmse.expr);
6613 : 1367 : gfc_add_modify (&parmse.pre, var, tmp);
6614 : 1432 : ;
6615 : : }
6616 : 1432 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6617 : : }
6618 : : }
6619 : : else
6620 : : {
6621 : 141869 : gfc_conv_expr_reference (&parmse, e);
6622 : :
6623 : 141869 : gfc_symbol *dsym = fsym;
6624 : 141869 : gfc_dummy_arg *dummy;
6625 : :
6626 : : /* Use associated dummy as fallback for formal
6627 : : argument if there is no explicit interface. */
6628 : 141869 : if (dsym == NULL
6629 : 27468 : && (dummy = arg->associated_dummy)
6630 : 25034 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
6631 : 165461 : && dummy->u.non_intrinsic->sym)
6632 : : dsym = dummy->u.non_intrinsic->sym;
6633 : :
6634 : 141869 : if (dsym
6635 : 137993 : && dsym->attr.intent == INTENT_OUT
6636 : : && !dsym->attr.allocatable
6637 : 3045 : && !dsym->attr.pointer
6638 : 2888 : && e->expr_type == EXPR_VARIABLE
6639 : 2882 : && e->ref == NULL
6640 : 2780 : && e->symtree
6641 : 2780 : && e->symtree->n.sym
6642 : 2780 : && !e->symtree->n.sym->attr.dimension
6643 : 2780 : && e->ts.type != BT_CHARACTER
6644 : 2683 : && e->ts.type != BT_CLASS
6645 : 2477 : && (e->ts.type != BT_DERIVED
6646 : 455 : || (dsym->ts.type == BT_DERIVED
6647 : 455 : && e->ts.u.derived == dsym->ts.u.derived
6648 : : /* Types with allocatable components are
6649 : : excluded from clobbering because we need
6650 : : the unclobbered pointers to free the
6651 : : allocatable components in the callee.
6652 : : Same goes for finalizable types or types
6653 : : with finalizable components, we need to
6654 : : pass the unclobbered values to the
6655 : : finalization routines.
6656 : : For parameterized types, it's less clear
6657 : : but they may not have a constant size
6658 : : so better exclude them in any case. */
6659 : : && !e->ts.u.derived->attr.alloc_comp
6660 : 440 : && !e->ts.u.derived->attr.pdt_type
6661 : 315 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
6662 : 144170 : && !sym->attr.elemental)
6663 : : {
6664 : 968 : tree var;
6665 : 968 : var = build_fold_indirect_ref_loc (input_location,
6666 : : parmse.expr);
6667 : 968 : tree clobber = build_clobber (TREE_TYPE (var));
6668 : 968 : gfc_add_modify (&clobbers, var, clobber);
6669 : : }
6670 : : }
6671 : : /* Catch base objects that are not variables. */
6672 : 143415 : if (e->ts.type == BT_CLASS
6673 : 3209 : && e->expr_type != EXPR_VARIABLE
6674 : 275 : && expr && e == expr->base_expr)
6675 : 80 : base_object = build_fold_indirect_ref_loc (input_location,
6676 : : parmse.expr);
6677 : :
6678 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6679 : : allocated on entry, it must be deallocated. */
6680 : 115947 : if (fsym && fsym->attr.intent == INTENT_OUT
6681 : 2948 : && (fsym->attr.allocatable
6682 : 2809 : || (fsym->ts.type == BT_CLASS
6683 : 229 : && CLASS_DATA (fsym)->attr.allocatable))
6684 : 143702 : && !is_CFI_desc (fsym, NULL))
6685 : : {
6686 : 287 : stmtblock_t block;
6687 : 287 : tree ptr;
6688 : :
6689 : 287 : defer_to_dealloc_blk = true;
6690 : :
6691 : 287 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
6692 : : &parmse.pre);
6693 : :
6694 : 287 : if (parmse.class_container != NULL_TREE)
6695 : 155 : parmse.class_container
6696 : 155 : = gfc_evaluate_data_ref_now (parmse.class_container,
6697 : : &parmse.pre);
6698 : :
6699 : 287 : gfc_init_block (&block);
6700 : 287 : ptr = parmse.expr;
6701 : 287 : if (e->ts.type == BT_CLASS)
6702 : 155 : ptr = gfc_class_data_get (ptr);
6703 : :
6704 : 287 : tree cls = parmse.class_container;
6705 : 287 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
6706 : : NULL_TREE, true,
6707 : : e, e->ts, cls);
6708 : 287 : gfc_add_expr_to_block (&block, tmp);
6709 : 287 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6710 : : void_type_node, ptr,
6711 : : null_pointer_node);
6712 : 287 : gfc_add_expr_to_block (&block, tmp);
6713 : :
6714 : 287 : if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
6715 : : {
6716 : 18 : gfc_add_modify (&block, ptr,
6717 : 18 : fold_convert (TREE_TYPE (ptr),
6718 : : null_pointer_node));
6719 : 18 : gfc_add_expr_to_block (&block, tmp);
6720 : : }
6721 : 269 : else if (fsym->ts.type == BT_CLASS)
6722 : : {
6723 : 130 : gfc_symbol *vtab;
6724 : 130 : vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
6725 : 130 : tmp = gfc_get_symbol_decl (vtab);
6726 : 130 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6727 : 130 : ptr = gfc_class_vptr_get (parmse.expr);
6728 : 130 : gfc_add_modify (&block, ptr,
6729 : 130 : fold_convert (TREE_TYPE (ptr), tmp));
6730 : 130 : gfc_add_expr_to_block (&block, tmp);
6731 : : }
6732 : :
6733 : 287 : if (fsym->attr.optional
6734 : 42 : && e->expr_type == EXPR_VARIABLE
6735 : 42 : && e->symtree->n.sym->attr.optional)
6736 : : {
6737 : 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
6738 : : void_type_node,
6739 : 18 : gfc_conv_expr_present (e->symtree->n.sym),
6740 : : gfc_finish_block (&block),
6741 : : build_empty_stmt (input_location));
6742 : : }
6743 : : else
6744 : 269 : tmp = gfc_finish_block (&block);
6745 : :
6746 : 287 : gfc_add_expr_to_block (&dealloc_blk, tmp);
6747 : : }
6748 : :
6749 : : /* A class array element needs converting back to be a
6750 : : class object, if the formal argument is a class object. */
6751 : 143415 : if (fsym && fsym->ts.type == BT_CLASS
6752 : 2823 : && e->ts.type == BT_CLASS
6753 : 2805 : && ((CLASS_DATA (fsym)->as
6754 : 350 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
6755 : 2455 : || CLASS_DATA (e)->attr.dimension))
6756 : : {
6757 : 460 : gfc_se class_se = parmse;
6758 : 460 : gfc_init_block (&class_se.pre);
6759 : 460 : gfc_init_block (&class_se.post);
6760 : :
6761 : 460 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
6762 : 460 : fsym->attr.intent != INTENT_IN
6763 : 460 : && (CLASS_DATA (fsym)->attr.class_pointer
6764 : : || CLASS_DATA (fsym)->attr.allocatable),
6765 : 460 : fsym->attr.optional
6766 : 198 : && e->expr_type == EXPR_VARIABLE
6767 : 198 : && e->symtree->n.sym->attr.optional,
6768 : 460 : CLASS_DATA (fsym)->attr.class_pointer
6769 : 460 : || CLASS_DATA (fsym)->attr.allocatable);
6770 : :
6771 : 460 : parmse.expr = class_se.expr;
6772 : 920 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
6773 : 460 : ? &dealloc_blk
6774 : : : &parmse.pre;
6775 : 460 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
6776 : 460 : gfc_add_block_to_block (&parmse.post, &class_se.post);
6777 : : }
6778 : :
6779 : 115947 : if (fsym && (fsym->ts.type == BT_DERIVED
6780 : 104856 : || fsym->ts.type == BT_ASSUMED)
6781 : 11942 : && e->ts.type == BT_CLASS
6782 : 404 : && !CLASS_DATA (e)->attr.dimension
6783 : 404 : && !CLASS_DATA (e)->attr.codimension)
6784 : : {
6785 : 368 : parmse.expr = gfc_class_data_get (parmse.expr);
6786 : : /* The result is a class temporary, whose _data component
6787 : : must be freed to avoid a memory leak. */
6788 : 368 : if (e->expr_type == EXPR_FUNCTION
6789 : 17 : && CLASS_DATA (e)->attr.allocatable)
6790 : : {
6791 : 13 : tree zero;
6792 : :
6793 : : /* Finalize the expression. */
6794 : 13 : gfc_finalize_tree_expr (&parmse, NULL,
6795 : : gfc_expr_attr (e), e->rank);
6796 : 13 : gfc_add_block_to_block (&parmse.post,
6797 : : &parmse.finalblock);
6798 : :
6799 : : /* Then free the class _data. */
6800 : 13 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
6801 : 13 : tmp = fold_build2_loc (input_location, NE_EXPR,
6802 : : logical_type_node,
6803 : : parmse.expr, zero);
6804 : 13 : tmp = build3_v (COND_EXPR, tmp,
6805 : : gfc_call_free (parmse.expr),
6806 : : build_empty_stmt (input_location));
6807 : 13 : gfc_add_expr_to_block (&parmse.post, tmp);
6808 : 13 : gfc_add_modify (&parmse.post, parmse.expr, zero);
6809 : : }
6810 : : }
6811 : :
6812 : : /* Wrap scalar variable in a descriptor. We need to convert
6813 : : the address of a pointer back to the pointer itself before,
6814 : : we can assign it to the data field. */
6815 : :
6816 : 115947 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
6817 : 1143 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
6818 : : {
6819 : 1107 : tmp = parmse.expr;
6820 : 1107 : if (TREE_CODE (tmp) == ADDR_EXPR)
6821 : 643 : tmp = TREE_OPERAND (tmp, 0);
6822 : 1107 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
6823 : : fsym->attr);
6824 : 1107 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
6825 : : parmse.expr);
6826 : : }
6827 : 114840 : else if (fsym && e->expr_type != EXPR_NULL
6828 : 114747 : && ((fsym->attr.pointer
6829 : 1611 : && fsym->attr.flavor != FL_PROCEDURE)
6830 : 113142 : || (fsym->attr.proc_pointer
6831 : 154 : && !(e->expr_type == EXPR_VARIABLE
6832 : 154 : && e->symtree->n.sym->attr.dummy))
6833 : 113000 : || (fsym->attr.proc_pointer
6834 : 12 : && e->expr_type == EXPR_VARIABLE
6835 : 12 : && gfc_is_proc_ptr_comp (e))
6836 : 112994 : || (fsym->attr.allocatable
6837 : 824 : && fsym->attr.flavor != FL_PROCEDURE)))
6838 : : {
6839 : : /* Scalar pointer dummy args require an extra level of
6840 : : indirection. The null pointer already contains
6841 : : this level of indirection. */
6842 : 2571 : parm_kind = SCALAR_POINTER;
6843 : 2571 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6844 : : }
6845 : : }
6846 : : }
6847 : 47716 : else if (e->ts.type == BT_CLASS
6848 : 2282 : && fsym && fsym->ts.type == BT_CLASS
6849 : 2020 : && (CLASS_DATA (fsym)->attr.dimension
6850 : 2020 : || CLASS_DATA (fsym)->attr.codimension))
6851 : : {
6852 : : /* Pass a class array. */
6853 : 2020 : parmse.use_offset = 1;
6854 : 2020 : gfc_conv_expr_descriptor (&parmse, e);
6855 : 2020 : bool defer_to_dealloc_blk = false;
6856 : :
6857 : 2020 : if (fsym->attr.optional
6858 : 774 : && e->expr_type == EXPR_VARIABLE
6859 : 774 : && e->symtree->n.sym->attr.optional)
6860 : : {
6861 : 414 : stmtblock_t block;
6862 : :
6863 : 414 : gfc_init_block (&block);
6864 : 414 : gfc_add_block_to_block (&block, &parmse.pre);
6865 : :
6866 : 828 : tree t = fold_build3_loc (input_location, COND_EXPR,
6867 : : void_type_node,
6868 : 414 : gfc_conv_expr_present (e->symtree->n.sym),
6869 : : gfc_finish_block (&block),
6870 : : build_empty_stmt (input_location));
6871 : :
6872 : 414 : gfc_add_expr_to_block (&parmse.pre, t);
6873 : : }
6874 : :
6875 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6876 : : allocated on entry, it must be deallocated. */
6877 : 2020 : if (fsym->attr.intent == INTENT_OUT
6878 : 139 : && CLASS_DATA (fsym)->attr.allocatable)
6879 : : {
6880 : 109 : stmtblock_t block;
6881 : 109 : tree ptr;
6882 : :
6883 : : /* In case the data reference to deallocate is dependent on
6884 : : its own content, save the resulting pointer to a variable
6885 : : and only use that variable from now on, before the
6886 : : expression becomes invalid. */
6887 : 109 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
6888 : : &parmse.pre);
6889 : :
6890 : 109 : if (parmse.class_container != NULL_TREE)
6891 : 109 : parmse.class_container
6892 : 109 : = gfc_evaluate_data_ref_now (parmse.class_container,
6893 : : &parmse.pre);
6894 : :
6895 : 109 : gfc_init_block (&block);
6896 : 109 : ptr = parmse.expr;
6897 : 109 : ptr = gfc_class_data_get (ptr);
6898 : :
6899 : 109 : tree cls = parmse.class_container;
6900 : 109 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
6901 : : NULL_TREE, NULL_TREE,
6902 : : NULL_TREE, true, e,
6903 : : GFC_CAF_COARRAY_NOCOARRAY,
6904 : : cls);
6905 : 109 : gfc_add_expr_to_block (&block, tmp);
6906 : 109 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6907 : : void_type_node, ptr,
6908 : : null_pointer_node);
6909 : 109 : gfc_add_expr_to_block (&block, tmp);
6910 : 109 : gfc_reset_vptr (&block, e, parmse.class_container);
6911 : :
6912 : 109 : if (fsym->attr.optional
6913 : 30 : && e->expr_type == EXPR_VARIABLE
6914 : 30 : && (!e->ref
6915 : 30 : || (e->ref->type == REF_ARRAY
6916 : 0 : && e->ref->u.ar.type != AR_FULL))
6917 : 0 : && e->symtree->n.sym->attr.optional)
6918 : : {
6919 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
6920 : : void_type_node,
6921 : 0 : gfc_conv_expr_present (e->symtree->n.sym),
6922 : : gfc_finish_block (&block),
6923 : : build_empty_stmt (input_location));
6924 : : }
6925 : : else
6926 : 109 : tmp = gfc_finish_block (&block);
6927 : :
6928 : 109 : gfc_add_expr_to_block (&dealloc_blk, tmp);
6929 : 109 : defer_to_dealloc_blk = true;
6930 : : }
6931 : :
6932 : 2020 : gfc_se class_se = parmse;
6933 : 2020 : gfc_init_block (&class_se.pre);
6934 : 2020 : gfc_init_block (&class_se.post);
6935 : :
6936 : : /* The conversion does not repackage the reference to a class
6937 : : array - _data descriptor. */
6938 : 2020 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
6939 : 2020 : fsym->attr.intent != INTENT_IN
6940 : 2020 : && (CLASS_DATA (fsym)->attr.class_pointer
6941 : : || CLASS_DATA (fsym)->attr.allocatable),
6942 : 2020 : fsym->attr.optional
6943 : 774 : && e->expr_type == EXPR_VARIABLE
6944 : 774 : && e->symtree->n.sym->attr.optional,
6945 : 2020 : CLASS_DATA (fsym)->attr.class_pointer
6946 : 2020 : || CLASS_DATA (fsym)->attr.allocatable);
6947 : :
6948 : 2020 : parmse.expr = class_se.expr;
6949 : 4040 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
6950 : 2020 : ? &dealloc_blk
6951 : : : &parmse.pre;
6952 : 2020 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
6953 : 2020 : gfc_add_block_to_block (&parmse.post, &class_se.post);
6954 : 2020 : }
6955 : : else
6956 : : {
6957 : : /* If the argument is a function call that may not create
6958 : : a temporary for the result, we have to check that we
6959 : : can do it, i.e. that there is no alias between this
6960 : : argument and another one. */
6961 : 45696 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
6962 : : {
6963 : 377 : gfc_expr *iarg;
6964 : 377 : sym_intent intent;
6965 : :
6966 : 377 : if (fsym != NULL)
6967 : 368 : intent = fsym->attr.intent;
6968 : : else
6969 : : intent = INTENT_UNKNOWN;
6970 : :
6971 : 377 : if (gfc_check_fncall_dependency (e, intent, sym, args,
6972 : : NOT_ELEMENTAL))
6973 : 21 : parmse.force_tmp = 1;
6974 : :
6975 : 377 : iarg = e->value.function.actual->expr;
6976 : :
6977 : : /* Temporary needed if aliasing due to host association. */
6978 : 377 : if (sym->attr.contained
6979 : 114 : && !sym->attr.pure
6980 : 114 : && !sym->attr.implicit_pure
6981 : 36 : && !sym->attr.use_assoc
6982 : 36 : && iarg->expr_type == EXPR_VARIABLE
6983 : 36 : && sym->ns == iarg->symtree->n.sym->ns)
6984 : 36 : parmse.force_tmp = 1;
6985 : :
6986 : : /* Ditto within module. */
6987 : 377 : if (sym->attr.use_assoc
6988 : 377 : && !sym->attr.pure
6989 : 6 : && !sym->attr.implicit_pure
6990 : 0 : && iarg->expr_type == EXPR_VARIABLE
6991 : 0 : && sym->module == iarg->symtree->n.sym->module)
6992 : 0 : parmse.force_tmp = 1;
6993 : : }
6994 : :
6995 : : /* Special case for assumed-rank arrays: when passing an
6996 : : argument to a nonallocatable/nonpointer dummy, the bounds have
6997 : : to be reset as otherwise a last-dim ubound of -1 is
6998 : : indistinguishable from an assumed-size array in the callee. */
6999 : 45696 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7000 : 26461 : && fsym->as->type == AS_ASSUMED_RANK
7001 : 8077 : && e->rank != -1
7002 : 7800 : && e->expr_type == EXPR_VARIABLE
7003 : 7390 : && ((fsym->ts.type == BT_CLASS
7004 : 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7005 : 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7006 : 7390 : || (fsym->ts.type != BT_CLASS
7007 : 7390 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7008 : : {
7009 : : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7010 : 6943 : gfc_ref *ref;
7011 : 7189 : for (ref = e->ref; ref->next; ref = ref->next)
7012 : : ;
7013 : 6943 : if (ref->u.ar.type == AR_FULL
7014 : 6127 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7015 : 6019 : ref->u.ar.type = AR_SECTION;
7016 : : }
7017 : :
7018 : 45696 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7019 : : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7020 : 5736 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7021 : :
7022 : 39960 : else if (e->expr_type == EXPR_VARIABLE
7023 : 31640 : && is_subref_array (e)
7024 : 40476 : && !(fsym && fsym->attr.pointer))
7025 : : /* The actual argument is a component reference to an
7026 : : array of derived types. In this case, the argument
7027 : : is converted to a temporary, which is passed and then
7028 : : written back after the procedure call. */
7029 : 311 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7030 : 311 : fsym ? fsym->attr.intent : INTENT_INOUT,
7031 : 311 : fsym && fsym->attr.pointer);
7032 : :
7033 : 39649 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7034 : 261 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7035 : 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
7036 : : /* An assumed size class actual argument being passed to
7037 : : a 'no descriptor' formal argument just requires the
7038 : : data pointer to be passed. For class dummy arguments
7039 : : this is stored in the symbol backend decl.. */
7040 : 6 : parmse.expr = e->symtree->n.sym->backend_decl;
7041 : :
7042 : 39643 : else if (gfc_is_class_array_ref (e, NULL)
7043 : 39643 : && fsym && fsym->ts.type == BT_DERIVED)
7044 : : /* The actual argument is a component reference to an
7045 : : array of derived types. In this case, the argument
7046 : : is converted to a temporary, which is passed and then
7047 : : written back after the procedure call.
7048 : : OOP-TODO: Insert code so that if the dynamic type is
7049 : : the same as the declared type, copy-in/copy-out does
7050 : : not occur. */
7051 : 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7052 : 108 : fsym->attr.intent,
7053 : 108 : fsym->attr.pointer);
7054 : :
7055 : 39535 : else if (gfc_is_class_array_function (e)
7056 : 39535 : && fsym && fsym->ts.type == BT_DERIVED)
7057 : : /* See previous comment. For function actual argument,
7058 : : the write out is not needed so the intent is set as
7059 : : intent in. */
7060 : : {
7061 : 13 : e->must_finalize = 1;
7062 : 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7063 : 13 : INTENT_IN, fsym->attr.pointer);
7064 : : }
7065 : 35947 : else if (fsym && fsym->attr.contiguous
7066 : 1590 : && !gfc_is_simply_contiguous (e, false, true)
7067 : 39831 : && gfc_expr_is_variable (e))
7068 : : {
7069 : 297 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7070 : 297 : fsym->attr.intent,
7071 : 297 : fsym->attr.pointer);
7072 : : }
7073 : : else
7074 : : /* This is where we introduce a temporary to store the
7075 : : result of a non-lvalue array expression. */
7076 : 39225 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
7077 : : sym->name, NULL);
7078 : :
7079 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7080 : : allocated on entry, it must be deallocated.
7081 : : CFI descriptors are handled elsewhere. */
7082 : 42121 : if (fsym && fsym->attr.allocatable
7083 : 1230 : && fsym->attr.intent == INTENT_OUT
7084 : 45451 : && !is_CFI_desc (fsym, NULL))
7085 : : {
7086 : 131 : if (fsym->ts.type == BT_DERIVED
7087 : 44 : && fsym->ts.u.derived->attr.alloc_comp)
7088 : : {
7089 : : // deallocate the components first
7090 : 8 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
7091 : : parmse.expr, e->rank);
7092 : : /* But check whether dummy argument is optional. */
7093 : 8 : if (tmp != NULL_TREE
7094 : 8 : && fsym->attr.optional
7095 : 6 : && e->expr_type == EXPR_VARIABLE
7096 : 6 : && e->symtree->n.sym->attr.optional)
7097 : : {
7098 : 6 : tree present;
7099 : 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
7100 : 6 : tmp = build3_v (COND_EXPR, present, tmp,
7101 : : build_empty_stmt (input_location));
7102 : : }
7103 : 8 : if (tmp != NULL_TREE)
7104 : 8 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7105 : : }
7106 : :
7107 : 131 : tmp = parmse.expr;
7108 : : /* With bind(C), the actual argument is replaced by a bind-C
7109 : : descriptor; in this case, the data component arrives here,
7110 : : which shall not be dereferenced, but still freed and
7111 : : nullified. */
7112 : 131 : if (TREE_TYPE(tmp) != pvoid_type_node)
7113 : 131 : tmp = build_fold_indirect_ref_loc (input_location,
7114 : : parmse.expr);
7115 : 131 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7116 : 131 : tmp = gfc_conv_descriptor_data_get (tmp);
7117 : 131 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7118 : : NULL_TREE, NULL_TREE, true,
7119 : : e,
7120 : : GFC_CAF_COARRAY_NOCOARRAY);
7121 : 131 : if (fsym->attr.optional
7122 : 36 : && e->expr_type == EXPR_VARIABLE
7123 : 36 : && e->symtree->n.sym->attr.optional)
7124 : 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7125 : : void_type_node,
7126 : 18 : gfc_conv_expr_present (e->symtree->n.sym),
7127 : : tmp, build_empty_stmt (input_location));
7128 : 131 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7129 : : }
7130 : : }
7131 : : }
7132 : : /* Special case for an assumed-rank dummy argument. */
7133 : 232091 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
7134 : 41901 : && (fsym->ts.type == BT_CLASS
7135 : 41901 : ? (CLASS_DATA (fsym)->as
7136 : 3673 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7137 : 38228 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
7138 : : {
7139 : 8799 : if (fsym->ts.type == BT_CLASS
7140 : 8799 : ? (CLASS_DATA (fsym)->attr.class_pointer
7141 : 999 : || CLASS_DATA (fsym)->attr.allocatable)
7142 : 7800 : : (fsym->attr.pointer || fsym->attr.allocatable))
7143 : : {
7144 : : /* Unallocated allocatable arrays and unassociated pointer
7145 : : arrays need their dtype setting if they are argument
7146 : : associated with assumed rank dummies to set the rank. */
7147 : 711 : set_dtype_for_unallocated (&parmse, e);
7148 : : }
7149 : 8088 : else if (e->expr_type == EXPR_VARIABLE
7150 : 7641 : && e->symtree->n.sym->attr.dummy
7151 : 560 : && (e->ts.type == BT_CLASS
7152 : 740 : ? (e->ref && e->ref->next
7153 : 180 : && e->ref->next->type == REF_ARRAY
|
