1 /* Expression translation
2 Copyright (C) 2002-2021 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.c-- 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
45
46 /* Calculate the number of characters in a string. */
47
48 static tree
gfc_get_character_len(tree type)49 gfc_get_character_len (tree type)
50 {
51 tree len;
52
53 gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
54 && TYPE_STRING_FLAG (type));
55
56 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
57 len = (len) ? (len) : (integer_zero_node);
58 return fold_convert (gfc_charlen_type_node, len);
59 }
60
61
62
63 /* Calculate the number of bytes in a string. */
64
65 tree
gfc_get_character_len_in_bytes(tree type)66 gfc_get_character_len_in_bytes (tree type)
67 {
68 tree tmp, len;
69
70 gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
71 && TYPE_STRING_FLAG (type));
72
73 tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
74 tmp = (tmp && !integer_zerop (tmp))
75 ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
76 len = gfc_get_character_len (type);
77 if (tmp && len && !integer_zerop (len))
78 len = fold_build2_loc (input_location, MULT_EXPR,
79 gfc_charlen_type_node, len, tmp);
80 return len;
81 }
82
83
84 /* Convert a scalar to an array descriptor. To be used for assumed-rank
85 arrays. */
86
87 static tree
get_scalar_to_descriptor_type(tree scalar,symbol_attribute attr)88 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
89 {
90 enum gfc_array_kind akind;
91
92 if (attr.pointer)
93 akind = GFC_ARRAY_POINTER_CONT;
94 else if (attr.allocatable)
95 akind = GFC_ARRAY_ALLOCATABLE;
96 else
97 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
98
99 if (POINTER_TYPE_P (TREE_TYPE (scalar)))
100 scalar = TREE_TYPE (scalar);
101 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
102 akind, !(attr.pointer || attr.target));
103 }
104
105 tree
gfc_conv_scalar_to_descriptor(gfc_se * se,tree scalar,symbol_attribute attr)106 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
107 {
108 tree desc, type, etype;
109
110 type = get_scalar_to_descriptor_type (scalar, attr);
111 etype = TREE_TYPE (scalar);
112 desc = gfc_create_var (type, "desc");
113 DECL_ARTIFICIAL (desc) = 1;
114
115 if (CONSTANT_CLASS_P (scalar))
116 {
117 tree tmp;
118 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
119 gfc_add_modify (&se->pre, tmp, scalar);
120 scalar = tmp;
121 }
122 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
123 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
124 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
125 etype = TREE_TYPE (etype);
126 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
127 gfc_get_dtype_rank_type (0, etype));
128 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
129 gfc_conv_descriptor_span_set (&se->pre, desc,
130 gfc_conv_descriptor_elem_len (desc));
131
132 /* Copy pointer address back - but only if it could have changed and
133 if the actual argument is a pointer and not, e.g., NULL(). */
134 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
135 gfc_add_modify (&se->post, scalar,
136 fold_convert (TREE_TYPE (scalar),
137 gfc_conv_descriptor_data_get (desc)));
138 return desc;
139 }
140
141
142 /* Get the coarray token from the ultimate array or component ref.
143 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
144
145 tree
gfc_get_ultimate_alloc_ptr_comps_caf_token(gfc_se * outerse,gfc_expr * expr)146 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
147 {
148 gfc_symbol *sym = expr->symtree->n.sym;
149 bool is_coarray = sym->attr.codimension;
150 gfc_expr *caf_expr = gfc_copy_expr (expr);
151 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
152
153 while (ref)
154 {
155 if (ref->type == REF_COMPONENT
156 && (ref->u.c.component->attr.allocatable
157 || ref->u.c.component->attr.pointer)
158 && (is_coarray || ref->u.c.component->attr.codimension))
159 last_caf_ref = ref;
160 ref = ref->next;
161 }
162
163 if (last_caf_ref == NULL)
164 return NULL_TREE;
165
166 tree comp = last_caf_ref->u.c.component->caf_token, caf;
167 gfc_se se;
168 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
169 if (comp == NULL_TREE && comp_ref)
170 return NULL_TREE;
171 gfc_init_se (&se, outerse);
172 gfc_free_ref_list (last_caf_ref->next);
173 last_caf_ref->next = NULL;
174 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
175 se.want_pointer = comp_ref;
176 gfc_conv_expr (&se, caf_expr);
177 gfc_add_block_to_block (&outerse->pre, &se.pre);
178
179 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
180 se.expr = TREE_OPERAND (se.expr, 0);
181 gfc_free_expr (caf_expr);
182
183 if (comp_ref)
184 caf = fold_build3_loc (input_location, COMPONENT_REF,
185 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
186 else
187 caf = gfc_conv_descriptor_token (se.expr);
188 return gfc_build_addr_expr (NULL_TREE, caf);
189 }
190
191
192 /* This is the seed for an eventual trans-class.c
193
194 The following parameters should not be used directly since they might
195 in future implementations. Use the corresponding APIs. */
196 #define CLASS_DATA_FIELD 0
197 #define CLASS_VPTR_FIELD 1
198 #define CLASS_LEN_FIELD 2
199 #define VTABLE_HASH_FIELD 0
200 #define VTABLE_SIZE_FIELD 1
201 #define VTABLE_EXTENDS_FIELD 2
202 #define VTABLE_DEF_INIT_FIELD 3
203 #define VTABLE_COPY_FIELD 4
204 #define VTABLE_FINAL_FIELD 5
205 #define VTABLE_DEALLOCATE_FIELD 6
206
207
208 tree
gfc_class_set_static_fields(tree decl,tree vptr,tree data)209 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
210 {
211 tree tmp;
212 tree field;
213 vec<constructor_elt, va_gc> *init = NULL;
214
215 field = TYPE_FIELDS (TREE_TYPE (decl));
216 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
217 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
218
219 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
220 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
221
222 return build_constructor (TREE_TYPE (decl), init);
223 }
224
225
226 tree
gfc_class_data_get(tree decl)227 gfc_class_data_get (tree decl)
228 {
229 tree data;
230 if (POINTER_TYPE_P (TREE_TYPE (decl)))
231 decl = build_fold_indirect_ref_loc (input_location, decl);
232 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
233 CLASS_DATA_FIELD);
234 return fold_build3_loc (input_location, COMPONENT_REF,
235 TREE_TYPE (data), decl, data,
236 NULL_TREE);
237 }
238
239
240 tree
gfc_class_vptr_get(tree decl)241 gfc_class_vptr_get (tree decl)
242 {
243 tree vptr;
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl))
248 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
249 if (POINTER_TYPE_P (TREE_TYPE (decl)))
250 decl = build_fold_indirect_ref_loc (input_location, decl);
251 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
252 CLASS_VPTR_FIELD);
253 return fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (vptr), decl, vptr,
255 NULL_TREE);
256 }
257
258
259 tree
gfc_class_len_get(tree decl)260 gfc_class_len_get (tree decl)
261 {
262 tree len;
263 /* For class arrays decl may be a temporary descriptor handle, the len is
264 then available through the saved descriptor. */
265 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
266 && GFC_DECL_SAVED_DESCRIPTOR (decl))
267 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
268 if (POINTER_TYPE_P (TREE_TYPE (decl)))
269 decl = build_fold_indirect_ref_loc (input_location, decl);
270 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
271 CLASS_LEN_FIELD);
272 return fold_build3_loc (input_location, COMPONENT_REF,
273 TREE_TYPE (len), decl, len,
274 NULL_TREE);
275 }
276
277
278 /* Try to get the _len component of a class. When the class is not unlimited
279 poly, i.e. no _len field exists, then return a zero node. */
280
281 static tree
gfc_class_len_or_zero_get(tree decl)282 gfc_class_len_or_zero_get (tree decl)
283 {
284 tree len;
285 /* For class arrays decl may be a temporary descriptor handle, the vptr is
286 then available through the saved descriptor. */
287 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
288 && GFC_DECL_SAVED_DESCRIPTOR (decl))
289 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
290 if (POINTER_TYPE_P (TREE_TYPE (decl)))
291 decl = build_fold_indirect_ref_loc (input_location, decl);
292 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
293 CLASS_LEN_FIELD);
294 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
295 TREE_TYPE (len), decl, len,
296 NULL_TREE)
297 : build_zero_cst (gfc_charlen_type_node);
298 }
299
300
301 tree
gfc_resize_class_size_with_len(stmtblock_t * block,tree class_expr,tree size)302 gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
303 {
304 tree tmp;
305 tree tmp2;
306 tree type;
307
308 tmp = gfc_class_len_or_zero_get (class_expr);
309
310 /* Include the len value in the element size if present. */
311 if (!integer_zerop (tmp))
312 {
313 type = TREE_TYPE (size);
314 if (block)
315 {
316 size = gfc_evaluate_now (size, block);
317 tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
318 }
319 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
320 type, size, tmp);
321 tmp = fold_build2_loc (input_location, GT_EXPR,
322 logical_type_node, tmp,
323 build_zero_cst (type));
324 size = fold_build3_loc (input_location, COND_EXPR,
325 type, tmp, tmp2, size);
326 }
327 else
328 return size;
329
330 if (block)
331 size = gfc_evaluate_now (size, block);
332
333 return size;
334 }
335
336
337 /* Get the specified FIELD from the VPTR. */
338
339 static tree
vptr_field_get(tree vptr,int fieldno)340 vptr_field_get (tree vptr, int fieldno)
341 {
342 tree field;
343 vptr = build_fold_indirect_ref_loc (input_location, vptr);
344 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
345 fieldno);
346 field = fold_build3_loc (input_location, COMPONENT_REF,
347 TREE_TYPE (field), vptr, field,
348 NULL_TREE);
349 gcc_assert (field);
350 return field;
351 }
352
353
354 /* Get the field from the class' vptr. */
355
356 static tree
class_vtab_field_get(tree decl,int fieldno)357 class_vtab_field_get (tree decl, int fieldno)
358 {
359 tree vptr;
360 vptr = gfc_class_vptr_get (decl);
361 return vptr_field_get (vptr, fieldno);
362 }
363
364
365 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
366 unison. */
367 #define VTAB_GET_FIELD_GEN(name, field) tree \
368 gfc_class_vtab_## name ##_get (tree cl) \
369 { \
370 return class_vtab_field_get (cl, field); \
371 } \
372 \
373 tree \
374 gfc_vptr_## name ##_get (tree vptr) \
375 { \
376 return vptr_field_get (vptr, field); \
377 }
378
VTAB_GET_FIELD_GEN(hash,VTABLE_HASH_FIELD)379 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
380 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
381 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
382 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
383 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
384 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
385 #undef VTAB_GET_FIELD_GEN
386
387 /* The size field is returned as an array index type. Therefore treat
388 it and only it specially. */
389
390 tree
391 gfc_class_vtab_size_get (tree cl)
392 {
393 tree size;
394 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
395 /* Always return size as an array index type. */
396 size = fold_convert (gfc_array_index_type, size);
397 gcc_assert (size);
398 return size;
399 }
400
401 tree
gfc_vptr_size_get(tree vptr)402 gfc_vptr_size_get (tree vptr)
403 {
404 tree size;
405 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
406 /* Always return size as an array index type. */
407 size = fold_convert (gfc_array_index_type, size);
408 gcc_assert (size);
409 return size;
410 }
411
412
413 #undef CLASS_DATA_FIELD
414 #undef CLASS_VPTR_FIELD
415 #undef CLASS_LEN_FIELD
416 #undef VTABLE_HASH_FIELD
417 #undef VTABLE_SIZE_FIELD
418 #undef VTABLE_EXTENDS_FIELD
419 #undef VTABLE_DEF_INIT_FIELD
420 #undef VTABLE_COPY_FIELD
421 #undef VTABLE_FINAL_FIELD
422
423
424 /* IF ts is null (default), search for the last _class ref in the chain
425 of references of the expression and cut the chain there. Although
426 this routine is similiar to class.c:gfc_add_component_ref (), there
427 is a significant difference: gfc_add_component_ref () concentrates
428 on an array ref that is the last ref in the chain and is oblivious
429 to the kind of refs following.
430 ELSE IF ts is non-null the cut is at the class entity or component
431 that is followed by an array reference, which is not an element.
432 These calls come from trans-array.c:build_class_array_ref, which
433 handles scalarized class array references.*/
434
435 gfc_expr *
gfc_find_and_cut_at_last_class_ref(gfc_expr * e,bool is_mold,gfc_typespec ** ts)436 gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
437 gfc_typespec **ts)
438 {
439 gfc_expr *base_expr;
440 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
441
442 /* Find the last class reference. */
443 class_ref = NULL;
444 array_ref = NULL;
445
446 if (ts)
447 {
448 if (e->symtree
449 && e->symtree->n.sym->ts.type == BT_CLASS)
450 *ts = &e->symtree->n.sym->ts;
451 else
452 *ts = NULL;
453 }
454
455 for (ref = e->ref; ref; ref = ref->next)
456 {
457 if (ts)
458 {
459 if (ref->type == REF_COMPONENT
460 && ref->u.c.component->ts.type == BT_CLASS
461 && ref->next && ref->next->type == REF_COMPONENT
462 && !strcmp (ref->next->u.c.component->name, "_data")
463 && ref->next->next
464 && ref->next->next->type == REF_ARRAY
465 && ref->next->next->u.ar.type != AR_ELEMENT)
466 {
467 *ts = &ref->u.c.component->ts;
468 class_ref = ref;
469 break;
470 }
471
472 if (ref->next == NULL)
473 break;
474 }
475 else
476 {
477 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
478 array_ref = ref;
479
480 if (ref->type == REF_COMPONENT
481 && ref->u.c.component->ts.type == BT_CLASS)
482 {
483 /* Component to the right of a part reference with nonzero
484 rank must not have the ALLOCATABLE attribute. If attempts
485 are made to reference such a component reference, an error
486 results followed by an ICE. */
487 if (array_ref
488 && CLASS_DATA (ref->u.c.component)->attr.allocatable)
489 return NULL;
490 class_ref = ref;
491 }
492 }
493 }
494
495 if (ts && *ts == NULL)
496 return NULL;
497
498 /* Remove and store all subsequent references after the
499 CLASS reference. */
500 if (class_ref)
501 {
502 tail = class_ref->next;
503 class_ref->next = NULL;
504 }
505 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
506 {
507 tail = e->ref;
508 e->ref = NULL;
509 }
510
511 if (is_mold)
512 base_expr = gfc_expr_to_initialize (e);
513 else
514 base_expr = gfc_copy_expr (e);
515
516 /* Restore the original tail expression. */
517 if (class_ref)
518 {
519 gfc_free_ref_list (class_ref->next);
520 class_ref->next = tail;
521 }
522 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
523 {
524 gfc_free_ref_list (e->ref);
525 e->ref = tail;
526 }
527 return base_expr;
528 }
529
530
531 /* Reset the vptr to the declared type, e.g. after deallocation. */
532
533 void
gfc_reset_vptr(stmtblock_t * block,gfc_expr * e)534 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
535 {
536 gfc_symbol *vtab;
537 tree vptr;
538 tree vtable;
539 gfc_se se;
540
541 /* Evaluate the expression and obtain the vptr from it. */
542 gfc_init_se (&se, NULL);
543 if (e->rank)
544 gfc_conv_expr_descriptor (&se, e);
545 else
546 gfc_conv_expr (&se, e);
547 gfc_add_block_to_block (block, &se.pre);
548 vptr = gfc_get_vptr_from_expr (se.expr);
549
550 /* If a vptr is not found, we can do nothing more. */
551 if (vptr == NULL_TREE)
552 return;
553
554 if (UNLIMITED_POLY (e))
555 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
556 else
557 {
558 /* Return the vptr to the address of the declared type. */
559 vtab = gfc_find_derived_vtab (e->ts.u.derived);
560 vtable = vtab->backend_decl;
561 if (vtable == NULL_TREE)
562 vtable = gfc_get_symbol_decl (vtab);
563 vtable = gfc_build_addr_expr (NULL, vtable);
564 vtable = fold_convert (TREE_TYPE (vptr), vtable);
565 gfc_add_modify (block, vptr, vtable);
566 }
567 }
568
569
570 /* Reset the len for unlimited polymorphic objects. */
571
572 void
gfc_reset_len(stmtblock_t * block,gfc_expr * expr)573 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
574 {
575 gfc_expr *e;
576 gfc_se se_len;
577 e = gfc_find_and_cut_at_last_class_ref (expr);
578 if (e == NULL)
579 return;
580 gfc_add_len_component (e);
581 gfc_init_se (&se_len, NULL);
582 gfc_conv_expr (&se_len, e);
583 gfc_add_modify (block, se_len.expr,
584 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
585 gfc_free_expr (e);
586 }
587
588
589 /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
590 reference is found. Note that it is up to the caller to avoid using this
591 for expressions other than variables. */
592
593 tree
gfc_get_class_from_gfc_expr(gfc_expr * e)594 gfc_get_class_from_gfc_expr (gfc_expr *e)
595 {
596 gfc_expr *class_expr;
597 gfc_se cse;
598 class_expr = gfc_find_and_cut_at_last_class_ref (e);
599 if (class_expr == NULL)
600 return NULL_TREE;
601 gfc_init_se (&cse, NULL);
602 gfc_conv_expr (&cse, class_expr);
603 gfc_free_expr (class_expr);
604 return cse.expr;
605 }
606
607
608 /* Obtain the last class reference in an expression.
609 Return NULL_TREE if no class reference is found. */
610
611 tree
gfc_get_class_from_expr(tree expr)612 gfc_get_class_from_expr (tree expr)
613 {
614 tree tmp;
615 tree type;
616
617 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
618 {
619 if (CONSTANT_CLASS_P (tmp))
620 return NULL_TREE;
621
622 type = TREE_TYPE (tmp);
623 while (type)
624 {
625 if (GFC_CLASS_TYPE_P (type))
626 return tmp;
627 if (type != TYPE_CANONICAL (type))
628 type = TYPE_CANONICAL (type);
629 else
630 type = NULL_TREE;
631 }
632 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
633 break;
634 }
635
636 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
637 tmp = build_fold_indirect_ref_loc (input_location, tmp);
638
639 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
640 return tmp;
641
642 return NULL_TREE;
643 }
644
645
646 /* Obtain the vptr of the last class reference in an expression.
647 Return NULL_TREE if no class reference is found. */
648
649 tree
gfc_get_vptr_from_expr(tree expr)650 gfc_get_vptr_from_expr (tree expr)
651 {
652 tree tmp;
653
654 tmp = gfc_get_class_from_expr (expr);
655
656 if (tmp != NULL_TREE)
657 return gfc_class_vptr_get (tmp);
658
659 return NULL_TREE;
660 }
661
662
663 static void
class_array_data_assign(stmtblock_t * block,tree lhs_desc,tree rhs_desc,bool lhs_type)664 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
665 bool lhs_type)
666 {
667 tree tmp, tmp2, type;
668
669 gfc_conv_descriptor_data_set (block, lhs_desc,
670 gfc_conv_descriptor_data_get (rhs_desc));
671 gfc_conv_descriptor_offset_set (block, lhs_desc,
672 gfc_conv_descriptor_offset_get (rhs_desc));
673
674 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
675 gfc_conv_descriptor_dtype (rhs_desc));
676
677 /* Assign the dimension as range-ref. */
678 tmp = gfc_get_descriptor_dimension (lhs_desc);
679 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
680
681 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
682 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
683 gfc_index_zero_node, NULL_TREE, NULL_TREE);
684 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
685 gfc_index_zero_node, NULL_TREE, NULL_TREE);
686 gfc_add_modify (block, tmp, tmp2);
687 }
688
689
690 /* Takes a derived type expression and returns the address of a temporary
691 class object of the 'declared' type. If vptr is not NULL, this is
692 used for the temporary class object.
693 optional_alloc_ptr is false when the dummy is neither allocatable
694 nor a pointer; that's only relevant for the optional handling.
695 The optional argument 'derived_array' is used to preserve the parmse
696 expression for deallocation of allocatable components. Assumed rank
697 formal arguments made this necessary. */
698 void
gfc_conv_derived_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,tree vptr,bool optional,bool optional_alloc_ptr,tree * derived_array)699 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
700 gfc_typespec class_ts, tree vptr, bool optional,
701 bool optional_alloc_ptr,
702 tree *derived_array)
703 {
704 gfc_symbol *vtab;
705 tree cond_optional = NULL_TREE;
706 gfc_ss *ss;
707 tree ctree;
708 tree var;
709 tree tmp;
710 int dim;
711
712 /* The derived type needs to be converted to a temporary
713 CLASS object. */
714 tmp = gfc_typenode_for_spec (&class_ts);
715 var = gfc_create_var (tmp, "class");
716
717 /* Set the vptr. */
718 ctree = gfc_class_vptr_get (var);
719
720 if (vptr != NULL_TREE)
721 {
722 /* Use the dynamic vptr. */
723 tmp = vptr;
724 }
725 else
726 {
727 /* In this case the vtab corresponds to the derived type and the
728 vptr must point to it. */
729 vtab = gfc_find_derived_vtab (e->ts.u.derived);
730 gcc_assert (vtab);
731 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
732 }
733 gfc_add_modify (&parmse->pre, ctree,
734 fold_convert (TREE_TYPE (ctree), tmp));
735
736 /* Now set the data field. */
737 ctree = gfc_class_data_get (var);
738
739 if (optional)
740 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
741
742 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
743 {
744 /* If there is a ready made pointer to a derived type, use it
745 rather than evaluating the expression again. */
746 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
747 gfc_add_modify (&parmse->pre, ctree, tmp);
748 }
749 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
750 {
751 /* For an array reference in an elemental procedure call we need
752 to retain the ss to provide the scalarized array reference. */
753 gfc_conv_expr_reference (parmse, e);
754 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
755 if (optional)
756 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
757 cond_optional, tmp,
758 fold_convert (TREE_TYPE (tmp), null_pointer_node));
759 gfc_add_modify (&parmse->pre, ctree, tmp);
760 }
761 else
762 {
763 ss = gfc_walk_expr (e);
764 if (ss == gfc_ss_terminator)
765 {
766 parmse->ss = NULL;
767 gfc_conv_expr_reference (parmse, e);
768
769 /* Scalar to an assumed-rank array. */
770 if (class_ts.u.derived->components->as)
771 {
772 tree type;
773 type = get_scalar_to_descriptor_type (parmse->expr,
774 gfc_expr_attr (e));
775 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
776 gfc_get_dtype (type));
777 if (optional)
778 parmse->expr = build3_loc (input_location, COND_EXPR,
779 TREE_TYPE (parmse->expr),
780 cond_optional, parmse->expr,
781 fold_convert (TREE_TYPE (parmse->expr),
782 null_pointer_node));
783 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
784 }
785 else
786 {
787 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
788 if (optional)
789 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
790 cond_optional, tmp,
791 fold_convert (TREE_TYPE (tmp),
792 null_pointer_node));
793 gfc_add_modify (&parmse->pre, ctree, tmp);
794 }
795 }
796 else
797 {
798 stmtblock_t block;
799 gfc_init_block (&block);
800 gfc_ref *ref;
801
802 parmse->ss = ss;
803 parmse->use_offset = 1;
804 gfc_conv_expr_descriptor (parmse, e);
805
806 /* Detect any array references with vector subscripts. */
807 for (ref = e->ref; ref; ref = ref->next)
808 if (ref->type == REF_ARRAY
809 && ref->u.ar.type != AR_ELEMENT
810 && ref->u.ar.type != AR_FULL)
811 {
812 for (dim = 0; dim < ref->u.ar.dimen; dim++)
813 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
814 break;
815 if (dim < ref->u.ar.dimen)
816 break;
817 }
818
819 /* Array references with vector subscripts and non-variable expressions
820 need be converted to a one-based descriptor. */
821 if (ref || e->expr_type != EXPR_VARIABLE)
822 {
823 for (dim = 0; dim < e->rank; ++dim)
824 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
825 gfc_index_one_node);
826 }
827
828 if (e->rank != class_ts.u.derived->components->as->rank)
829 {
830 gcc_assert (class_ts.u.derived->components->as->type
831 == AS_ASSUMED_RANK);
832 if (derived_array
833 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
834 {
835 *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
836 "array");
837 gfc_add_modify (&block, *derived_array , parmse->expr);
838 }
839 class_array_data_assign (&block, ctree, parmse->expr, false);
840 }
841 else
842 {
843 if (gfc_expr_attr (e).codimension)
844 parmse->expr = fold_build1_loc (input_location,
845 VIEW_CONVERT_EXPR,
846 TREE_TYPE (ctree),
847 parmse->expr);
848 gfc_add_modify (&block, ctree, parmse->expr);
849 }
850
851 if (optional)
852 {
853 tmp = gfc_finish_block (&block);
854
855 gfc_init_block (&block);
856 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
857 if (derived_array && *derived_array != NULL_TREE)
858 gfc_conv_descriptor_data_set (&block, *derived_array,
859 null_pointer_node);
860
861 tmp = build3_v (COND_EXPR, cond_optional, tmp,
862 gfc_finish_block (&block));
863 gfc_add_expr_to_block (&parmse->pre, tmp);
864 }
865 else
866 gfc_add_block_to_block (&parmse->pre, &block);
867 }
868 }
869
870 if (class_ts.u.derived->components->ts.type == BT_DERIVED
871 && class_ts.u.derived->components->ts.u.derived
872 ->attr.unlimited_polymorphic)
873 {
874 /* Take care about initializing the _len component correctly. */
875 ctree = gfc_class_len_get (var);
876 if (UNLIMITED_POLY (e))
877 {
878 gfc_expr *len;
879 gfc_se se;
880
881 len = gfc_find_and_cut_at_last_class_ref (e);
882 gfc_add_len_component (len);
883 gfc_init_se (&se, NULL);
884 gfc_conv_expr (&se, len);
885 if (optional)
886 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
887 cond_optional, se.expr,
888 fold_convert (TREE_TYPE (se.expr),
889 integer_zero_node));
890 else
891 tmp = se.expr;
892 gfc_free_expr (len);
893 }
894 else
895 tmp = integer_zero_node;
896 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
897 tmp));
898 }
899 /* Pass the address of the class object. */
900 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
901
902 if (optional && optional_alloc_ptr)
903 parmse->expr = build3_loc (input_location, COND_EXPR,
904 TREE_TYPE (parmse->expr),
905 cond_optional, parmse->expr,
906 fold_convert (TREE_TYPE (parmse->expr),
907 null_pointer_node));
908 }
909
910
911 /* Create a new class container, which is required as scalar coarrays
912 have an array descriptor while normal scalars haven't. Optionally,
913 NULL pointer checks are added if the argument is OPTIONAL. */
914
915 static void
class_scalar_coarray_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,bool optional)916 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
917 gfc_typespec class_ts, bool optional)
918 {
919 tree var, ctree, tmp;
920 stmtblock_t block;
921 gfc_ref *ref;
922 gfc_ref *class_ref;
923
924 gfc_init_block (&block);
925
926 class_ref = NULL;
927 for (ref = e->ref; ref; ref = ref->next)
928 {
929 if (ref->type == REF_COMPONENT
930 && ref->u.c.component->ts.type == BT_CLASS)
931 class_ref = ref;
932 }
933
934 if (class_ref == NULL
935 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
936 tmp = e->symtree->n.sym->backend_decl;
937 else
938 {
939 /* Remove everything after the last class reference, convert the
940 expression and then recover its tailend once more. */
941 gfc_se tmpse;
942 ref = class_ref->next;
943 class_ref->next = NULL;
944 gfc_init_se (&tmpse, NULL);
945 gfc_conv_expr (&tmpse, e);
946 class_ref->next = ref;
947 tmp = tmpse.expr;
948 }
949
950 var = gfc_typenode_for_spec (&class_ts);
951 var = gfc_create_var (var, "class");
952
953 ctree = gfc_class_vptr_get (var);
954 gfc_add_modify (&block, ctree,
955 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
956
957 ctree = gfc_class_data_get (var);
958 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
959 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
960
961 /* Pass the address of the class object. */
962 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
963
964 if (optional)
965 {
966 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
967 tree tmp2;
968
969 tmp = gfc_finish_block (&block);
970
971 gfc_init_block (&block);
972 tmp2 = gfc_class_data_get (var);
973 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
974 null_pointer_node));
975 tmp2 = gfc_finish_block (&block);
976
977 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
978 cond, tmp, tmp2);
979 gfc_add_expr_to_block (&parmse->pre, tmp);
980 }
981 else
982 gfc_add_block_to_block (&parmse->pre, &block);
983 }
984
985
986 /* Takes an intrinsic type expression and returns the address of a temporary
987 class object of the 'declared' type. */
988 void
gfc_conv_intrinsic_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts)989 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
990 gfc_typespec class_ts)
991 {
992 gfc_symbol *vtab;
993 gfc_ss *ss;
994 tree ctree;
995 tree var;
996 tree tmp;
997 int dim;
998
999 /* The intrinsic type needs to be converted to a temporary
1000 CLASS object. */
1001 tmp = gfc_typenode_for_spec (&class_ts);
1002 var = gfc_create_var (tmp, "class");
1003
1004 /* Set the vptr. */
1005 ctree = gfc_class_vptr_get (var);
1006
1007 vtab = gfc_find_vtab (&e->ts);
1008 gcc_assert (vtab);
1009 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1010 gfc_add_modify (&parmse->pre, ctree,
1011 fold_convert (TREE_TYPE (ctree), tmp));
1012
1013 /* Now set the data field. */
1014 ctree = gfc_class_data_get (var);
1015 if (parmse->ss && parmse->ss->info->useflags)
1016 {
1017 /* For an array reference in an elemental procedure call we need
1018 to retain the ss to provide the scalarized array reference. */
1019 gfc_conv_expr_reference (parmse, e);
1020 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1021 gfc_add_modify (&parmse->pre, ctree, tmp);
1022 }
1023 else
1024 {
1025 ss = gfc_walk_expr (e);
1026 if (ss == gfc_ss_terminator)
1027 {
1028 parmse->ss = NULL;
1029 gfc_conv_expr_reference (parmse, e);
1030 if (class_ts.u.derived->components->as
1031 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1032 {
1033 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1034 gfc_expr_attr (e));
1035 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1036 TREE_TYPE (ctree), tmp);
1037 }
1038 else
1039 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1040 gfc_add_modify (&parmse->pre, ctree, tmp);
1041 }
1042 else
1043 {
1044 parmse->ss = ss;
1045 parmse->use_offset = 1;
1046 gfc_conv_expr_descriptor (parmse, e);
1047
1048 /* Array references with vector subscripts and non-variable expressions
1049 need be converted to a one-based descriptor. */
1050 if (e->expr_type != EXPR_VARIABLE)
1051 {
1052 for (dim = 0; dim < e->rank; ++dim)
1053 gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1054 dim, gfc_index_one_node);
1055 }
1056
1057 if (class_ts.u.derived->components->as->rank != e->rank)
1058 {
1059 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1060 TREE_TYPE (ctree), parmse->expr);
1061 gfc_add_modify (&parmse->pre, ctree, tmp);
1062 }
1063 else
1064 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1065 }
1066 }
1067
1068 gcc_assert (class_ts.type == BT_CLASS);
1069 if (class_ts.u.derived->components->ts.type == BT_DERIVED
1070 && class_ts.u.derived->components->ts.u.derived
1071 ->attr.unlimited_polymorphic)
1072 {
1073 ctree = gfc_class_len_get (var);
1074 /* When the actual arg is a char array, then set the _len component of the
1075 unlimited polymorphic entity to the length of the string. */
1076 if (e->ts.type == BT_CHARACTER)
1077 {
1078 /* Start with parmse->string_length because this seems to be set to a
1079 correct value more often. */
1080 if (parmse->string_length)
1081 tmp = parmse->string_length;
1082 /* When the string_length is not yet set, then try the backend_decl of
1083 the cl. */
1084 else if (e->ts.u.cl->backend_decl)
1085 tmp = e->ts.u.cl->backend_decl;
1086 /* If both of the above approaches fail, then try to generate an
1087 expression from the input, which is only feasible currently, when the
1088 expression can be evaluated to a constant one. */
1089 else
1090 {
1091 /* Try to simplify the expression. */
1092 gfc_simplify_expr (e, 0);
1093 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1094 {
1095 /* Amazingly all data is present to compute the length of a
1096 constant string, but the expression is not yet there. */
1097 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1098 gfc_charlen_int_kind,
1099 &e->where);
1100 mpz_set_ui (e->ts.u.cl->length->value.integer,
1101 e->value.character.length);
1102 gfc_conv_const_charlen (e->ts.u.cl);
1103 e->ts.u.cl->resolved = 1;
1104 tmp = e->ts.u.cl->backend_decl;
1105 }
1106 else
1107 {
1108 gfc_error ("Cannot compute the length of the char array "
1109 "at %L.", &e->where);
1110 }
1111 }
1112 }
1113 else
1114 tmp = integer_zero_node;
1115
1116 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1117 }
1118 else if (class_ts.type == BT_CLASS
1119 && class_ts.u.derived->components
1120 && class_ts.u.derived->components->ts.u
1121 .derived->attr.unlimited_polymorphic)
1122 {
1123 ctree = gfc_class_len_get (var);
1124 gfc_add_modify (&parmse->pre, ctree,
1125 fold_convert (TREE_TYPE (ctree),
1126 integer_zero_node));
1127 }
1128 /* Pass the address of the class object. */
1129 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1130 }
1131
1132
1133 /* Takes a scalarized class array expression and returns the
1134 address of a temporary scalar class object of the 'declared'
1135 type.
1136 OOP-TODO: This could be improved by adding code that branched on
1137 the dynamic type being the same as the declared type. In this case
1138 the original class expression can be passed directly.
1139 optional_alloc_ptr is false when the dummy is neither allocatable
1140 nor a pointer; that's relevant for the optional handling.
1141 Set copyback to true if class container's _data and _vtab pointers
1142 might get modified. */
1143
1144 void
gfc_conv_class_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,bool elemental,bool copyback,bool optional,bool optional_alloc_ptr)1145 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1146 bool elemental, bool copyback, bool optional,
1147 bool optional_alloc_ptr)
1148 {
1149 tree ctree;
1150 tree var;
1151 tree tmp;
1152 tree vptr;
1153 tree cond = NULL_TREE;
1154 tree slen = NULL_TREE;
1155 gfc_ref *ref;
1156 gfc_ref *class_ref;
1157 stmtblock_t block;
1158 bool full_array = false;
1159
1160 gfc_init_block (&block);
1161
1162 class_ref = NULL;
1163 for (ref = e->ref; ref; ref = ref->next)
1164 {
1165 if (ref->type == REF_COMPONENT
1166 && ref->u.c.component->ts.type == BT_CLASS)
1167 class_ref = ref;
1168
1169 if (ref->next == NULL)
1170 break;
1171 }
1172
1173 if ((ref == NULL || class_ref == ref)
1174 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1175 && (!class_ts.u.derived->components->as
1176 || class_ts.u.derived->components->as->rank != -1))
1177 return;
1178
1179 /* Test for FULL_ARRAY. */
1180 if (e->rank == 0 && gfc_expr_attr (e).codimension
1181 && gfc_expr_attr (e).dimension)
1182 full_array = true;
1183 else
1184 gfc_is_class_array_ref (e, &full_array);
1185
1186 /* The derived type needs to be converted to a temporary
1187 CLASS object. */
1188 tmp = gfc_typenode_for_spec (&class_ts);
1189 var = gfc_create_var (tmp, "class");
1190
1191 /* Set the data. */
1192 ctree = gfc_class_data_get (var);
1193 if (class_ts.u.derived->components->as
1194 && e->rank != class_ts.u.derived->components->as->rank)
1195 {
1196 if (e->rank == 0)
1197 {
1198 tree type = get_scalar_to_descriptor_type (parmse->expr,
1199 gfc_expr_attr (e));
1200 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1201 gfc_get_dtype (type));
1202
1203 tmp = gfc_class_data_get (parmse->expr);
1204 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1205 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1206
1207 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1208 }
1209 else
1210 class_array_data_assign (&block, ctree, parmse->expr, false);
1211 }
1212 else
1213 {
1214 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1215 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1216 TREE_TYPE (ctree), parmse->expr);
1217 gfc_add_modify (&block, ctree, parmse->expr);
1218 }
1219
1220 /* Return the data component, except in the case of scalarized array
1221 references, where nullification of the cannot occur and so there
1222 is no need. */
1223 if (!elemental && full_array && copyback)
1224 {
1225 if (class_ts.u.derived->components->as
1226 && e->rank != class_ts.u.derived->components->as->rank)
1227 {
1228 if (e->rank == 0)
1229 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1230 gfc_conv_descriptor_data_get (ctree));
1231 else
1232 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1233 }
1234 else
1235 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1236 }
1237
1238 /* Set the vptr. */
1239 ctree = gfc_class_vptr_get (var);
1240
1241 /* The vptr is the second field of the actual argument.
1242 First we have to find the corresponding class reference. */
1243
1244 tmp = NULL_TREE;
1245 if (gfc_is_class_array_function (e)
1246 && parmse->class_vptr != NULL_TREE)
1247 tmp = parmse->class_vptr;
1248 else if (class_ref == NULL
1249 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1250 {
1251 tmp = e->symtree->n.sym->backend_decl;
1252
1253 if (TREE_CODE (tmp) == FUNCTION_DECL)
1254 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1255
1256 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1257 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1258
1259 slen = build_zero_cst (size_type_node);
1260 }
1261 else
1262 {
1263 /* Remove everything after the last class reference, convert the
1264 expression and then recover its tailend once more. */
1265 gfc_se tmpse;
1266 ref = class_ref->next;
1267 class_ref->next = NULL;
1268 gfc_init_se (&tmpse, NULL);
1269 gfc_conv_expr (&tmpse, e);
1270 class_ref->next = ref;
1271 tmp = tmpse.expr;
1272 slen = tmpse.string_length;
1273 }
1274
1275 gcc_assert (tmp != NULL_TREE);
1276
1277 /* Dereference if needs be. */
1278 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1279 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1280
1281 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1282 vptr = gfc_class_vptr_get (tmp);
1283 else
1284 vptr = tmp;
1285
1286 gfc_add_modify (&block, ctree,
1287 fold_convert (TREE_TYPE (ctree), vptr));
1288
1289 /* Return the vptr component, except in the case of scalarized array
1290 references, where the dynamic type cannot change. */
1291 if (!elemental && full_array && copyback)
1292 gfc_add_modify (&parmse->post, vptr,
1293 fold_convert (TREE_TYPE (vptr), ctree));
1294
1295 /* For unlimited polymorphic objects also set the _len component. */
1296 if (class_ts.type == BT_CLASS
1297 && class_ts.u.derived->components
1298 && class_ts.u.derived->components->ts.u
1299 .derived->attr.unlimited_polymorphic)
1300 {
1301 ctree = gfc_class_len_get (var);
1302 if (UNLIMITED_POLY (e))
1303 tmp = gfc_class_len_get (tmp);
1304 else if (e->ts.type == BT_CHARACTER)
1305 {
1306 gcc_assert (slen != NULL_TREE);
1307 tmp = slen;
1308 }
1309 else
1310 tmp = build_zero_cst (size_type_node);
1311 gfc_add_modify (&parmse->pre, ctree,
1312 fold_convert (TREE_TYPE (ctree), tmp));
1313
1314 /* Return the len component, except in the case of scalarized array
1315 references, where the dynamic type cannot change. */
1316 if (!elemental && full_array && copyback
1317 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1318 gfc_add_modify (&parmse->post, tmp,
1319 fold_convert (TREE_TYPE (tmp), ctree));
1320 }
1321
1322 if (optional)
1323 {
1324 tree tmp2;
1325
1326 cond = gfc_conv_expr_present (e->symtree->n.sym);
1327 /* parmse->pre may contain some preparatory instructions for the
1328 temporary array descriptor. Those may only be executed when the
1329 optional argument is set, therefore add parmse->pre's instructions
1330 to block, which is later guarded by an if (optional_arg_given). */
1331 gfc_add_block_to_block (&parmse->pre, &block);
1332 block.head = parmse->pre.head;
1333 parmse->pre.head = NULL_TREE;
1334 tmp = gfc_finish_block (&block);
1335
1336 if (optional_alloc_ptr)
1337 tmp2 = build_empty_stmt (input_location);
1338 else
1339 {
1340 gfc_init_block (&block);
1341
1342 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1343 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1344 null_pointer_node));
1345 tmp2 = gfc_finish_block (&block);
1346 }
1347
1348 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1349 cond, tmp, tmp2);
1350 gfc_add_expr_to_block (&parmse->pre, tmp);
1351 }
1352 else
1353 gfc_add_block_to_block (&parmse->pre, &block);
1354
1355 /* Pass the address of the class object. */
1356 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1357
1358 if (optional && optional_alloc_ptr)
1359 parmse->expr = build3_loc (input_location, COND_EXPR,
1360 TREE_TYPE (parmse->expr),
1361 cond, parmse->expr,
1362 fold_convert (TREE_TYPE (parmse->expr),
1363 null_pointer_node));
1364 }
1365
1366
1367 /* Given a class array declaration and an index, returns the address
1368 of the referenced element. */
1369
1370 static tree
gfc_get_class_array_ref(tree index,tree class_decl,tree data_comp,bool unlimited)1371 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1372 bool unlimited)
1373 {
1374 tree data, size, tmp, ctmp, offset, ptr;
1375
1376 data = data_comp != NULL_TREE ? data_comp :
1377 gfc_class_data_get (class_decl);
1378 size = gfc_class_vtab_size_get (class_decl);
1379
1380 if (unlimited)
1381 {
1382 tmp = fold_convert (gfc_array_index_type,
1383 gfc_class_len_get (class_decl));
1384 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1385 gfc_array_index_type, size, tmp);
1386 tmp = fold_build2_loc (input_location, GT_EXPR,
1387 logical_type_node, tmp,
1388 build_zero_cst (TREE_TYPE (tmp)));
1389 size = fold_build3_loc (input_location, COND_EXPR,
1390 gfc_array_index_type, tmp, ctmp, size);
1391 }
1392
1393 offset = fold_build2_loc (input_location, MULT_EXPR,
1394 gfc_array_index_type,
1395 index, size);
1396
1397 data = gfc_conv_descriptor_data_get (data);
1398 ptr = fold_convert (pvoid_type_node, data);
1399 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1400 return fold_convert (TREE_TYPE (data), ptr);
1401 }
1402
1403
1404 /* Copies one class expression to another, assuming that if either
1405 'to' or 'from' are arrays they are packed. Should 'from' be
1406 NULL_TREE, the initialization expression for 'to' is used, assuming
1407 that the _vptr is set. */
1408
1409 tree
gfc_copy_class_to_class(tree from,tree to,tree nelems,bool unlimited)1410 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1411 {
1412 tree fcn;
1413 tree fcn_type;
1414 tree from_data;
1415 tree from_len;
1416 tree to_data;
1417 tree to_len;
1418 tree to_ref;
1419 tree from_ref;
1420 vec<tree, va_gc> *args;
1421 tree tmp;
1422 tree stdcopy;
1423 tree extcopy;
1424 tree index;
1425 bool is_from_desc = false, is_to_class = false;
1426
1427 args = NULL;
1428 /* To prevent warnings on uninitialized variables. */
1429 from_len = to_len = NULL_TREE;
1430
1431 if (from != NULL_TREE)
1432 fcn = gfc_class_vtab_copy_get (from);
1433 else
1434 fcn = gfc_class_vtab_copy_get (to);
1435
1436 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1437
1438 if (from != NULL_TREE)
1439 {
1440 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1441 if (is_from_desc)
1442 {
1443 from_data = from;
1444 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1445 }
1446 else
1447 {
1448 /* Check that from is a class. When the class is part of a coarray,
1449 then from is a common pointer and is to be used as is. */
1450 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1451 ? build_fold_indirect_ref (from) : from;
1452 from_data =
1453 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1454 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1455 ? gfc_class_data_get (from) : from;
1456 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1457 }
1458 }
1459 else
1460 from_data = gfc_class_vtab_def_init_get (to);
1461
1462 if (unlimited)
1463 {
1464 if (from != NULL_TREE && unlimited)
1465 from_len = gfc_class_len_or_zero_get (from);
1466 else
1467 from_len = build_zero_cst (size_type_node);
1468 }
1469
1470 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1471 {
1472 is_to_class = true;
1473 to_data = gfc_class_data_get (to);
1474 if (unlimited)
1475 to_len = gfc_class_len_get (to);
1476 }
1477 else
1478 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1479 to_data = to;
1480
1481 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1482 {
1483 stmtblock_t loopbody;
1484 stmtblock_t body;
1485 stmtblock_t ifbody;
1486 gfc_loopinfo loop;
1487 tree orig_nelems = nelems; /* Needed for bounds check. */
1488
1489 gfc_init_block (&body);
1490 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1491 gfc_array_index_type, nelems,
1492 gfc_index_one_node);
1493 nelems = gfc_evaluate_now (tmp, &body);
1494 index = gfc_create_var (gfc_array_index_type, "S");
1495
1496 if (is_from_desc)
1497 {
1498 from_ref = gfc_get_class_array_ref (index, from, from_data,
1499 unlimited);
1500 vec_safe_push (args, from_ref);
1501 }
1502 else
1503 vec_safe_push (args, from_data);
1504
1505 if (is_to_class)
1506 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1507 else
1508 {
1509 tmp = gfc_conv_array_data (to);
1510 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1511 to_ref = gfc_build_addr_expr (NULL_TREE,
1512 gfc_build_array_ref (tmp, index, to));
1513 }
1514 vec_safe_push (args, to_ref);
1515
1516 /* Add bounds check. */
1517 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1518 {
1519 char *msg;
1520 const char *name = "<<unknown>>";
1521 tree from_len;
1522
1523 if (DECL_P (to))
1524 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1525
1526 from_len = gfc_conv_descriptor_size (from_data, 1);
1527 tmp = fold_build2_loc (input_location, NE_EXPR,
1528 logical_type_node, from_len, orig_nelems);
1529 msg = xasprintf ("Array bound mismatch for dimension %d "
1530 "of array '%s' (%%ld/%%ld)",
1531 1, name);
1532
1533 gfc_trans_runtime_check (true, false, tmp, &body,
1534 &gfc_current_locus, msg,
1535 fold_convert (long_integer_type_node, orig_nelems),
1536 fold_convert (long_integer_type_node, from_len));
1537
1538 free (msg);
1539 }
1540
1541 tmp = build_call_vec (fcn_type, fcn, args);
1542
1543 /* Build the body of the loop. */
1544 gfc_init_block (&loopbody);
1545 gfc_add_expr_to_block (&loopbody, tmp);
1546
1547 /* Build the loop and return. */
1548 gfc_init_loopinfo (&loop);
1549 loop.dimen = 1;
1550 loop.from[0] = gfc_index_zero_node;
1551 loop.loopvar[0] = index;
1552 loop.to[0] = nelems;
1553 gfc_trans_scalarizing_loops (&loop, &loopbody);
1554 gfc_init_block (&ifbody);
1555 gfc_add_block_to_block (&ifbody, &loop.pre);
1556 stdcopy = gfc_finish_block (&ifbody);
1557 /* In initialization mode from_len is a constant zero. */
1558 if (unlimited && !integer_zerop (from_len))
1559 {
1560 vec_safe_push (args, from_len);
1561 vec_safe_push (args, to_len);
1562 tmp = build_call_vec (fcn_type, fcn, args);
1563 /* Build the body of the loop. */
1564 gfc_init_block (&loopbody);
1565 gfc_add_expr_to_block (&loopbody, tmp);
1566
1567 /* Build the loop and return. */
1568 gfc_init_loopinfo (&loop);
1569 loop.dimen = 1;
1570 loop.from[0] = gfc_index_zero_node;
1571 loop.loopvar[0] = index;
1572 loop.to[0] = nelems;
1573 gfc_trans_scalarizing_loops (&loop, &loopbody);
1574 gfc_init_block (&ifbody);
1575 gfc_add_block_to_block (&ifbody, &loop.pre);
1576 extcopy = gfc_finish_block (&ifbody);
1577
1578 tmp = fold_build2_loc (input_location, GT_EXPR,
1579 logical_type_node, from_len,
1580 build_zero_cst (TREE_TYPE (from_len)));
1581 tmp = fold_build3_loc (input_location, COND_EXPR,
1582 void_type_node, tmp, extcopy, stdcopy);
1583 gfc_add_expr_to_block (&body, tmp);
1584 tmp = gfc_finish_block (&body);
1585 }
1586 else
1587 {
1588 gfc_add_expr_to_block (&body, stdcopy);
1589 tmp = gfc_finish_block (&body);
1590 }
1591 gfc_cleanup_loop (&loop);
1592 }
1593 else
1594 {
1595 gcc_assert (!is_from_desc);
1596 vec_safe_push (args, from_data);
1597 vec_safe_push (args, to_data);
1598 stdcopy = build_call_vec (fcn_type, fcn, args);
1599
1600 /* In initialization mode from_len is a constant zero. */
1601 if (unlimited && !integer_zerop (from_len))
1602 {
1603 vec_safe_push (args, from_len);
1604 vec_safe_push (args, to_len);
1605 extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1606 tmp = fold_build2_loc (input_location, GT_EXPR,
1607 logical_type_node, from_len,
1608 build_zero_cst (TREE_TYPE (from_len)));
1609 tmp = fold_build3_loc (input_location, COND_EXPR,
1610 void_type_node, tmp, extcopy, stdcopy);
1611 }
1612 else
1613 tmp = stdcopy;
1614 }
1615
1616 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1617 if (from == NULL_TREE)
1618 {
1619 tree cond;
1620 cond = fold_build2_loc (input_location, NE_EXPR,
1621 logical_type_node,
1622 from_data, null_pointer_node);
1623 tmp = fold_build3_loc (input_location, COND_EXPR,
1624 void_type_node, cond,
1625 tmp, build_empty_stmt (input_location));
1626 }
1627
1628 return tmp;
1629 }
1630
1631
1632 static tree
gfc_trans_class_array_init_assign(gfc_expr * rhs,gfc_expr * lhs,gfc_expr * obj)1633 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1634 {
1635 gfc_actual_arglist *actual;
1636 gfc_expr *ppc;
1637 gfc_code *ppc_code;
1638 tree res;
1639
1640 actual = gfc_get_actual_arglist ();
1641 actual->expr = gfc_copy_expr (rhs);
1642 actual->next = gfc_get_actual_arglist ();
1643 actual->next->expr = gfc_copy_expr (lhs);
1644 ppc = gfc_copy_expr (obj);
1645 gfc_add_vptr_component (ppc);
1646 gfc_add_component_ref (ppc, "_copy");
1647 ppc_code = gfc_get_code (EXEC_CALL);
1648 ppc_code->resolved_sym = ppc->symtree->n.sym;
1649 /* Although '_copy' is set to be elemental in class.c, it is
1650 not staying that way. Find out why, sometime.... */
1651 ppc_code->resolved_sym->attr.elemental = 1;
1652 ppc_code->ext.actual = actual;
1653 ppc_code->expr1 = ppc;
1654 /* Since '_copy' is elemental, the scalarizer will take care
1655 of arrays in gfc_trans_call. */
1656 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1657 gfc_free_statements (ppc_code);
1658
1659 if (UNLIMITED_POLY(obj))
1660 {
1661 /* Check if rhs is non-NULL. */
1662 gfc_se src;
1663 gfc_init_se (&src, NULL);
1664 gfc_conv_expr (&src, rhs);
1665 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1666 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1667 src.expr, fold_convert (TREE_TYPE (src.expr),
1668 null_pointer_node));
1669 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1670 build_empty_stmt (input_location));
1671 }
1672
1673 return res;
1674 }
1675
1676 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1677 A MEMCPY is needed to copy the full data from the default initializer
1678 of the dynamic type. */
1679
1680 tree
gfc_trans_class_init_assign(gfc_code * code)1681 gfc_trans_class_init_assign (gfc_code *code)
1682 {
1683 stmtblock_t block;
1684 tree tmp;
1685 gfc_se dst,src,memsz;
1686 gfc_expr *lhs, *rhs, *sz;
1687
1688 gfc_start_block (&block);
1689
1690 lhs = gfc_copy_expr (code->expr1);
1691
1692 rhs = gfc_copy_expr (code->expr1);
1693 gfc_add_vptr_component (rhs);
1694
1695 /* Make sure that the component backend_decls have been built, which
1696 will not have happened if the derived types concerned have not
1697 been referenced. */
1698 gfc_get_derived_type (rhs->ts.u.derived);
1699 gfc_add_def_init_component (rhs);
1700 /* The _def_init is always scalar. */
1701 rhs->rank = 0;
1702
1703 if (code->expr1->ts.type == BT_CLASS
1704 && CLASS_DATA (code->expr1)->attr.dimension)
1705 {
1706 gfc_array_spec *tmparr = gfc_get_array_spec ();
1707 *tmparr = *CLASS_DATA (code->expr1)->as;
1708 /* Adding the array ref to the class expression results in correct
1709 indexing to the dynamic type. */
1710 gfc_add_full_array_ref (lhs, tmparr);
1711 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1712 }
1713 else
1714 {
1715 /* Scalar initialization needs the _data component. */
1716 gfc_add_data_component (lhs);
1717 sz = gfc_copy_expr (code->expr1);
1718 gfc_add_vptr_component (sz);
1719 gfc_add_size_component (sz);
1720
1721 gfc_init_se (&dst, NULL);
1722 gfc_init_se (&src, NULL);
1723 gfc_init_se (&memsz, NULL);
1724 gfc_conv_expr (&dst, lhs);
1725 gfc_conv_expr (&src, rhs);
1726 gfc_conv_expr (&memsz, sz);
1727 gfc_add_block_to_block (&block, &src.pre);
1728 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1729
1730 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1731
1732 if (UNLIMITED_POLY(code->expr1))
1733 {
1734 /* Check if _def_init is non-NULL. */
1735 tree cond = fold_build2_loc (input_location, NE_EXPR,
1736 logical_type_node, src.expr,
1737 fold_convert (TREE_TYPE (src.expr),
1738 null_pointer_node));
1739 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1740 tmp, build_empty_stmt (input_location));
1741 }
1742 }
1743
1744 if (code->expr1->symtree->n.sym->attr.dummy
1745 && (code->expr1->symtree->n.sym->attr.optional
1746 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1747 {
1748 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1749 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1750 present, tmp,
1751 build_empty_stmt (input_location));
1752 }
1753
1754 gfc_add_expr_to_block (&block, tmp);
1755
1756 return gfc_finish_block (&block);
1757 }
1758
1759
1760 /* Class valued elemental function calls or class array elements arriving
1761 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1762 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1763
1764 static bool
trans_scalar_class_assign(stmtblock_t * block,gfc_se * lse,gfc_se * rse)1765 trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1766 {
1767 tree fcn;
1768 tree rse_expr;
1769 tree class_data;
1770 tree tmp;
1771 tree zero;
1772 tree cond;
1773 tree final_cond;
1774 stmtblock_t inner_block;
1775 bool is_descriptor;
1776 bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1777 bool not_lhs_array_type;
1778
1779 /* Temporaries arising from depencies in assignment get cast as a
1780 character type of the dynamic size of the rhs. Use the vptr copy
1781 for this case. */
1782 tmp = TREE_TYPE (lse->expr);
1783 not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1784 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1785
1786 /* Use ordinary assignment if the rhs is not a call expression or
1787 the lhs is not a class entity or an array(ie. character) type. */
1788 if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
1789 && not_lhs_array_type)
1790 return false;
1791
1792 /* Ordinary assignment can be used if both sides are class expressions
1793 since the dynamic type is preserved by copying the vptr. This
1794 should only occur, where temporaries are involved. */
1795 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1796 && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1797 return false;
1798
1799 /* Fix the class expression and the class data of the rhs. */
1800 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1801 || not_call_expr)
1802 {
1803 tmp = gfc_get_class_from_expr (rse->expr);
1804 if (tmp == NULL_TREE)
1805 return false;
1806 rse_expr = gfc_evaluate_now (tmp, block);
1807 }
1808 else
1809 rse_expr = gfc_evaluate_now (rse->expr, block);
1810
1811 class_data = gfc_class_data_get (rse_expr);
1812
1813 /* Check that the rhs data is not null. */
1814 is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1815 if (is_descriptor)
1816 class_data = gfc_conv_descriptor_data_get (class_data);
1817 class_data = gfc_evaluate_now (class_data, block);
1818
1819 zero = build_int_cst (TREE_TYPE (class_data), 0);
1820 cond = fold_build2_loc (input_location, NE_EXPR,
1821 logical_type_node,
1822 class_data, zero);
1823
1824 /* Copy the rhs to the lhs. */
1825 fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
1826 fcn = build_fold_indirect_ref_loc (input_location, fcn);
1827 tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
1828 tmp = is_descriptor ? tmp : class_data;
1829 tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1830 gfc_build_addr_expr (NULL, lse->expr));
1831 gfc_add_expr_to_block (block, tmp);
1832
1833 /* Only elemental function results need to be finalised and freed. */
1834 if (not_call_expr)
1835 return true;
1836
1837 /* Finalize the class data if needed. */
1838 gfc_init_block (&inner_block);
1839 fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
1840 zero = build_int_cst (TREE_TYPE (fcn), 0);
1841 final_cond = fold_build2_loc (input_location, NE_EXPR,
1842 logical_type_node, fcn, zero);
1843 fcn = build_fold_indirect_ref_loc (input_location, fcn);
1844 tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
1845 tmp = build3_v (COND_EXPR, final_cond,
1846 tmp, build_empty_stmt (input_location));
1847 gfc_add_expr_to_block (&inner_block, tmp);
1848
1849 /* Free the class data. */
1850 tmp = gfc_call_free (class_data);
1851 tmp = build3_v (COND_EXPR, cond, tmp,
1852 build_empty_stmt (input_location));
1853 gfc_add_expr_to_block (&inner_block, tmp);
1854
1855 /* Finish the inner block and subject it to the condition on the
1856 class data being non-zero. */
1857 tmp = gfc_finish_block (&inner_block);
1858 tmp = build3_v (COND_EXPR, cond, tmp,
1859 build_empty_stmt (input_location));
1860 gfc_add_expr_to_block (block, tmp);
1861
1862 return true;
1863 }
1864
1865 /* End of prototype trans-class.c */
1866
1867
1868 static void
realloc_lhs_warning(bt type,bool array,locus * where)1869 realloc_lhs_warning (bt type, bool array, locus *where)
1870 {
1871 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1872 gfc_warning (OPT_Wrealloc_lhs,
1873 "Code for reallocating the allocatable array at %L will "
1874 "be added", where);
1875 else if (warn_realloc_lhs_all)
1876 gfc_warning (OPT_Wrealloc_lhs_all,
1877 "Code for reallocating the allocatable variable at %L "
1878 "will be added", where);
1879 }
1880
1881
1882 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1883 gfc_expr *);
1884
1885 /* Copy the scalarization loop variables. */
1886
1887 static void
gfc_copy_se_loopvars(gfc_se * dest,gfc_se * src)1888 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1889 {
1890 dest->ss = src->ss;
1891 dest->loop = src->loop;
1892 }
1893
1894
1895 /* Initialize a simple expression holder.
1896
1897 Care must be taken when multiple se are created with the same parent.
1898 The child se must be kept in sync. The easiest way is to delay creation
1899 of a child se until after the previous se has been translated. */
1900
1901 void
gfc_init_se(gfc_se * se,gfc_se * parent)1902 gfc_init_se (gfc_se * se, gfc_se * parent)
1903 {
1904 memset (se, 0, sizeof (gfc_se));
1905 gfc_init_block (&se->pre);
1906 gfc_init_block (&se->post);
1907
1908 se->parent = parent;
1909
1910 if (parent)
1911 gfc_copy_se_loopvars (se, parent);
1912 }
1913
1914
1915 /* Advances to the next SS in the chain. Use this rather than setting
1916 se->ss = se->ss->next because all the parents needs to be kept in sync.
1917 See gfc_init_se. */
1918
1919 void
gfc_advance_se_ss_chain(gfc_se * se)1920 gfc_advance_se_ss_chain (gfc_se * se)
1921 {
1922 gfc_se *p;
1923 gfc_ss *ss;
1924
1925 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1926
1927 p = se;
1928 /* Walk down the parent chain. */
1929 while (p != NULL)
1930 {
1931 /* Simple consistency check. */
1932 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1933 || p->parent->ss->nested_ss == p->ss);
1934
1935 /* If we were in a nested loop, the next scalarized expression can be
1936 on the parent ss' next pointer. Thus we should not take the next
1937 pointer blindly, but rather go up one nest level as long as next
1938 is the end of chain. */
1939 ss = p->ss;
1940 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1941 ss = ss->parent;
1942
1943 p->ss = ss->next;
1944
1945 p = p->parent;
1946 }
1947 }
1948
1949
1950 /* Ensures the result of the expression as either a temporary variable
1951 or a constant so that it can be used repeatedly. */
1952
1953 void
gfc_make_safe_expr(gfc_se * se)1954 gfc_make_safe_expr (gfc_se * se)
1955 {
1956 tree var;
1957
1958 if (CONSTANT_CLASS_P (se->expr))
1959 return;
1960
1961 /* We need a temporary for this result. */
1962 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1963 gfc_add_modify (&se->pre, var, se->expr);
1964 se->expr = var;
1965 }
1966
1967
1968 /* Return an expression which determines if a dummy parameter is present.
1969 Also used for arguments to procedures with multiple entry points. */
1970
1971 tree
gfc_conv_expr_present(gfc_symbol * sym,bool use_saved_desc)1972 gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
1973 {
1974 tree decl, orig_decl, cond;
1975
1976 gcc_assert (sym->attr.dummy);
1977 orig_decl = decl = gfc_get_symbol_decl (sym);
1978
1979 /* Intrinsic scalars with VALUE attribute which are passed by value
1980 use a hidden argument to denote the present status. */
1981 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1982 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1983 && !sym->attr.dimension)
1984 {
1985 char name[GFC_MAX_SYMBOL_LEN + 2];
1986 tree tree_name;
1987
1988 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1989 name[0] = '_';
1990 strcpy (&name[1], sym->name);
1991 tree_name = get_identifier (name);
1992
1993 /* Walk function argument list to find hidden arg. */
1994 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1995 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1996 if (DECL_NAME (cond) == tree_name
1997 && DECL_ARTIFICIAL (cond))
1998 break;
1999
2000 gcc_assert (cond);
2001 return cond;
2002 }
2003
2004 /* Assumed-shape arrays use a local variable for the array data;
2005 the actual PARAM_DECL is in a saved decl. As the local variable
2006 is NULL, it can be checked instead, unless use_saved_desc is
2007 requested. */
2008
2009 if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2010 {
2011 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2012 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2013 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2014 }
2015
2016 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2017 fold_convert (TREE_TYPE (decl), null_pointer_node));
2018
2019 /* Fortran 2008 allows to pass null pointers and non-associated pointers
2020 as actual argument to denote absent dummies. For array descriptors,
2021 we thus also need to check the array descriptor. For BT_CLASS, it
2022 can also occur for scalars and F2003 due to type->class wrapping and
2023 class->class wrapping. Note further that BT_CLASS always uses an
2024 array descriptor for arrays, also for explicit-shape/assumed-size.
2025 For assumed-rank arrays, no local variable is generated, hence,
2026 the following also applies with !use_saved_desc. */
2027
2028 if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2029 && !sym->attr.allocatable
2030 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2031 || (sym->ts.type == BT_CLASS
2032 && !CLASS_DATA (sym)->attr.allocatable
2033 && !CLASS_DATA (sym)->attr.class_pointer))
2034 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2035 || sym->ts.type == BT_CLASS))
2036 {
2037 tree tmp;
2038
2039 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2040 || sym->as->type == AS_ASSUMED_RANK
2041 || sym->attr.codimension))
2042 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2043 {
2044 tmp = build_fold_indirect_ref_loc (input_location, decl);
2045 if (sym->ts.type == BT_CLASS)
2046 tmp = gfc_class_data_get (tmp);
2047 tmp = gfc_conv_array_data (tmp);
2048 }
2049 else if (sym->ts.type == BT_CLASS)
2050 tmp = gfc_class_data_get (decl);
2051 else
2052 tmp = NULL_TREE;
2053
2054 if (tmp != NULL_TREE)
2055 {
2056 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2057 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2058 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2059 logical_type_node, cond, tmp);
2060 }
2061 }
2062
2063 return cond;
2064 }
2065
2066
2067 /* Converts a missing, dummy argument into a null or zero. */
2068
2069 void
gfc_conv_missing_dummy(gfc_se * se,gfc_expr * arg,gfc_typespec ts,int kind)2070 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2071 {
2072 tree present;
2073 tree tmp;
2074
2075 present = gfc_conv_expr_present (arg->symtree->n.sym);
2076
2077 if (kind > 0)
2078 {
2079 /* Create a temporary and convert it to the correct type. */
2080 tmp = gfc_get_int_type (kind);
2081 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2082 se->expr));
2083
2084 /* Test for a NULL value. */
2085 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2086 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2087 tmp = gfc_evaluate_now (tmp, &se->pre);
2088 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2089 }
2090 else
2091 {
2092 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2093 present, se->expr,
2094 build_zero_cst (TREE_TYPE (se->expr)));
2095 tmp = gfc_evaluate_now (tmp, &se->pre);
2096 se->expr = tmp;
2097 }
2098
2099 if (ts.type == BT_CHARACTER)
2100 {
2101 tmp = build_int_cst (gfc_charlen_type_node, 0);
2102 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
2103 present, se->string_length, tmp);
2104 tmp = gfc_evaluate_now (tmp, &se->pre);
2105 se->string_length = tmp;
2106 }
2107 return;
2108 }
2109
2110
2111 /* Get the character length of an expression, looking through gfc_refs
2112 if necessary. */
2113
2114 tree
gfc_get_expr_charlen(gfc_expr * e)2115 gfc_get_expr_charlen (gfc_expr *e)
2116 {
2117 gfc_ref *r;
2118 tree length;
2119 gfc_se se;
2120
2121 gcc_assert (e->expr_type == EXPR_VARIABLE
2122 && e->ts.type == BT_CHARACTER);
2123
2124 length = NULL; /* To silence compiler warning. */
2125
2126 if (is_subref_array (e) && e->ts.u.cl->length)
2127 {
2128 gfc_se tmpse;
2129 gfc_init_se (&tmpse, NULL);
2130 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2131 e->ts.u.cl->backend_decl = tmpse.expr;
2132 return tmpse.expr;
2133 }
2134
2135 /* First candidate: if the variable is of type CHARACTER, the
2136 expression's length could be the length of the character
2137 variable. */
2138 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2139 length = e->symtree->n.sym->ts.u.cl->backend_decl;
2140
2141 /* Look through the reference chain for component references. */
2142 for (r = e->ref; r; r = r->next)
2143 {
2144 switch (r->type)
2145 {
2146 case REF_COMPONENT:
2147 if (r->u.c.component->ts.type == BT_CHARACTER)
2148 length = r->u.c.component->ts.u.cl->backend_decl;
2149 break;
2150
2151 case REF_ARRAY:
2152 /* Do nothing. */
2153 break;
2154
2155 case REF_SUBSTRING:
2156 gfc_init_se (&se, NULL);
2157 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2158 length = se.expr;
2159 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2160 length = fold_build2_loc (input_location, MINUS_EXPR,
2161 gfc_charlen_type_node,
2162 se.expr, length);
2163 length = fold_build2_loc (input_location, PLUS_EXPR,
2164 gfc_charlen_type_node, length,
2165 gfc_index_one_node);
2166 break;
2167
2168 default:
2169 gcc_unreachable ();
2170 break;
2171 }
2172 }
2173
2174 gcc_assert (length != NULL);
2175 return length;
2176 }
2177
2178
2179 /* Return for an expression the backend decl of the coarray. */
2180
2181 tree
gfc_get_tree_for_caf_expr(gfc_expr * expr)2182 gfc_get_tree_for_caf_expr (gfc_expr *expr)
2183 {
2184 tree caf_decl;
2185 bool found = false;
2186 gfc_ref *ref;
2187
2188 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2189
2190 /* Not-implemented diagnostic. */
2191 if (expr->symtree->n.sym->ts.type == BT_CLASS
2192 && UNLIMITED_POLY (expr->symtree->n.sym)
2193 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2194 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2195 "%L is not supported", &expr->where);
2196
2197 for (ref = expr->ref; ref; ref = ref->next)
2198 if (ref->type == REF_COMPONENT)
2199 {
2200 if (ref->u.c.component->ts.type == BT_CLASS
2201 && UNLIMITED_POLY (ref->u.c.component)
2202 && CLASS_DATA (ref->u.c.component)->attr.codimension)
2203 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2204 "component at %L is not supported", &expr->where);
2205 }
2206
2207 /* Make sure the backend_decl is present before accessing it. */
2208 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2209 ? gfc_get_symbol_decl (expr->symtree->n.sym)
2210 : expr->symtree->n.sym->backend_decl;
2211
2212 if (expr->symtree->n.sym->ts.type == BT_CLASS)
2213 {
2214 if (expr->ref && expr->ref->type == REF_ARRAY)
2215 {
2216 caf_decl = gfc_class_data_get (caf_decl);
2217 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2218 return caf_decl;
2219 }
2220 for (ref = expr->ref; ref; ref = ref->next)
2221 {
2222 if (ref->type == REF_COMPONENT
2223 && strcmp (ref->u.c.component->name, "_data") != 0)
2224 {
2225 caf_decl = gfc_class_data_get (caf_decl);
2226 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2227 return caf_decl;
2228 break;
2229 }
2230 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2231 break;
2232 }
2233 }
2234 if (expr->symtree->n.sym->attr.codimension)
2235 return caf_decl;
2236
2237 /* The following code assumes that the coarray is a component reachable via
2238 only scalar components/variables; the Fortran standard guarantees this. */
2239
2240 for (ref = expr->ref; ref; ref = ref->next)
2241 if (ref->type == REF_COMPONENT)
2242 {
2243 gfc_component *comp = ref->u.c.component;
2244
2245 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2246 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2247 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2248 TREE_TYPE (comp->backend_decl), caf_decl,
2249 comp->backend_decl, NULL_TREE);
2250 if (comp->ts.type == BT_CLASS)
2251 {
2252 caf_decl = gfc_class_data_get (caf_decl);
2253 if (CLASS_DATA (comp)->attr.codimension)
2254 {
2255 found = true;
2256 break;
2257 }
2258 }
2259 if (comp->attr.codimension)
2260 {
2261 found = true;
2262 break;
2263 }
2264 }
2265 gcc_assert (found && caf_decl);
2266 return caf_decl;
2267 }
2268
2269
2270 /* Obtain the Coarray token - and optionally also the offset. */
2271
2272 void
gfc_get_caf_token_offset(gfc_se * se,tree * token,tree * offset,tree caf_decl,tree se_expr,gfc_expr * expr)2273 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2274 tree se_expr, gfc_expr *expr)
2275 {
2276 tree tmp;
2277
2278 /* Coarray token. */
2279 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2280 {
2281 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
2282 == GFC_ARRAY_ALLOCATABLE
2283 || expr->symtree->n.sym->attr.select_type_temporary);
2284 *token = gfc_conv_descriptor_token (caf_decl);
2285 }
2286 else if (DECL_LANG_SPECIFIC (caf_decl)
2287 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2288 *token = GFC_DECL_TOKEN (caf_decl);
2289 else
2290 {
2291 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2292 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2293 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2294 }
2295
2296 if (offset == NULL)
2297 return;
2298
2299 /* Offset between the coarray base address and the address wanted. */
2300 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2301 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2302 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2303 *offset = build_int_cst (gfc_array_index_type, 0);
2304 else if (DECL_LANG_SPECIFIC (caf_decl)
2305 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2306 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2307 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2308 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2309 else
2310 *offset = build_int_cst (gfc_array_index_type, 0);
2311
2312 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2313 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2314 {
2315 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2316 tmp = gfc_conv_descriptor_data_get (tmp);
2317 }
2318 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2319 tmp = gfc_conv_descriptor_data_get (se_expr);
2320 else
2321 {
2322 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2323 tmp = se_expr;
2324 }
2325
2326 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2327 *offset, fold_convert (gfc_array_index_type, tmp));
2328
2329 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2330 && expr->symtree->n.sym->attr.codimension
2331 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2332 {
2333 gfc_expr *base_expr = gfc_copy_expr (expr);
2334 gfc_ref *ref = base_expr->ref;
2335 gfc_se base_se;
2336
2337 // Iterate through the refs until the last one.
2338 while (ref->next)
2339 ref = ref->next;
2340
2341 if (ref->type == REF_ARRAY
2342 && ref->u.ar.type != AR_FULL)
2343 {
2344 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2345 int i;
2346 for (i = 0; i < ranksum; ++i)
2347 {
2348 ref->u.ar.start[i] = NULL;
2349 ref->u.ar.end[i] = NULL;
2350 }
2351 ref->u.ar.type = AR_FULL;
2352 }
2353 gfc_init_se (&base_se, NULL);
2354 if (gfc_caf_attr (base_expr).dimension)
2355 {
2356 gfc_conv_expr_descriptor (&base_se, base_expr);
2357 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2358 }
2359 else
2360 {
2361 gfc_conv_expr (&base_se, base_expr);
2362 tmp = base_se.expr;
2363 }
2364
2365 gfc_free_expr (base_expr);
2366 gfc_add_block_to_block (&se->pre, &base_se.pre);
2367 gfc_add_block_to_block (&se->post, &base_se.post);
2368 }
2369 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2370 tmp = gfc_conv_descriptor_data_get (caf_decl);
2371 else
2372 {
2373 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2374 tmp = caf_decl;
2375 }
2376
2377 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2378 fold_convert (gfc_array_index_type, *offset),
2379 fold_convert (gfc_array_index_type, tmp));
2380 }
2381
2382
2383 /* Convert the coindex of a coarray into an image index; the result is
2384 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2385 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2386
2387 tree
gfc_caf_get_image_index(stmtblock_t * block,gfc_expr * e,tree desc)2388 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2389 {
2390 gfc_ref *ref;
2391 tree lbound, ubound, extent, tmp, img_idx;
2392 gfc_se se;
2393 int i;
2394
2395 for (ref = e->ref; ref; ref = ref->next)
2396 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2397 break;
2398 gcc_assert (ref != NULL);
2399
2400 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2401 {
2402 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2403 integer_zero_node);
2404 }
2405
2406 img_idx = build_zero_cst (gfc_array_index_type);
2407 extent = build_one_cst (gfc_array_index_type);
2408 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2409 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2410 {
2411 gfc_init_se (&se, NULL);
2412 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2413 gfc_add_block_to_block (block, &se.pre);
2414 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2415 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2416 TREE_TYPE (lbound), se.expr, lbound);
2417 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2418 extent, tmp);
2419 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2420 TREE_TYPE (tmp), img_idx, tmp);
2421 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2422 {
2423 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2424 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2425 extent = fold_build2_loc (input_location, MULT_EXPR,
2426 TREE_TYPE (tmp), extent, tmp);
2427 }
2428 }
2429 else
2430 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2431 {
2432 gfc_init_se (&se, NULL);
2433 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2434 gfc_add_block_to_block (block, &se.pre);
2435 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2436 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2437 TREE_TYPE (lbound), se.expr, lbound);
2438 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2439 extent, tmp);
2440 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2441 img_idx, tmp);
2442 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2443 {
2444 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2445 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2446 TREE_TYPE (ubound), ubound, lbound);
2447 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2448 tmp, build_one_cst (TREE_TYPE (tmp)));
2449 extent = fold_build2_loc (input_location, MULT_EXPR,
2450 TREE_TYPE (tmp), extent, tmp);
2451 }
2452 }
2453 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2454 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2455 return fold_convert (integer_type_node, img_idx);
2456 }
2457
2458
2459 /* For each character array constructor subexpression without a ts.u.cl->length,
2460 replace it by its first element (if there aren't any elements, the length
2461 should already be set to zero). */
2462
2463 static void
flatten_array_ctors_without_strlen(gfc_expr * e)2464 flatten_array_ctors_without_strlen (gfc_expr* e)
2465 {
2466 gfc_actual_arglist* arg;
2467 gfc_constructor* c;
2468
2469 if (!e)
2470 return;
2471
2472 switch (e->expr_type)
2473 {
2474
2475 case EXPR_OP:
2476 flatten_array_ctors_without_strlen (e->value.op.op1);
2477 flatten_array_ctors_without_strlen (e->value.op.op2);
2478 break;
2479
2480 case EXPR_COMPCALL:
2481 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2482 gcc_unreachable ();
2483
2484 case EXPR_FUNCTION:
2485 for (arg = e->value.function.actual; arg; arg = arg->next)
2486 flatten_array_ctors_without_strlen (arg->expr);
2487 break;
2488
2489 case EXPR_ARRAY:
2490
2491 /* We've found what we're looking for. */
2492 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2493 {
2494 gfc_constructor *c;
2495 gfc_expr* new_expr;
2496
2497 gcc_assert (e->value.constructor);
2498
2499 c = gfc_constructor_first (e->value.constructor);
2500 new_expr = c->expr;
2501 c->expr = NULL;
2502
2503 flatten_array_ctors_without_strlen (new_expr);
2504 gfc_replace_expr (e, new_expr);
2505 break;
2506 }
2507
2508 /* Otherwise, fall through to handle constructor elements. */
2509 gcc_fallthrough ();
2510 case EXPR_STRUCTURE:
2511 for (c = gfc_constructor_first (e->value.constructor);
2512 c; c = gfc_constructor_next (c))
2513 flatten_array_ctors_without_strlen (c->expr);
2514 break;
2515
2516 default:
2517 break;
2518
2519 }
2520 }
2521
2522
2523 /* Generate code to initialize a string length variable. Returns the
2524 value. For array constructors, cl->length might be NULL and in this case,
2525 the first element of the constructor is needed. expr is the original
2526 expression so we can access it but can be NULL if this is not needed. */
2527
2528 void
gfc_conv_string_length(gfc_charlen * cl,gfc_expr * expr,stmtblock_t * pblock)2529 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2530 {
2531 gfc_se se;
2532
2533 gfc_init_se (&se, NULL);
2534
2535 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2536 return;
2537
2538 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2539 "flatten" array constructors by taking their first element; all elements
2540 should be the same length or a cl->length should be present. */
2541 if (!cl->length)
2542 {
2543 gfc_expr* expr_flat;
2544 if (!expr)
2545 return;
2546 expr_flat = gfc_copy_expr (expr);
2547 flatten_array_ctors_without_strlen (expr_flat);
2548 gfc_resolve_expr (expr_flat);
2549
2550 gfc_conv_expr (&se, expr_flat);
2551 gfc_add_block_to_block (pblock, &se.pre);
2552 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2553
2554 gfc_free_expr (expr_flat);
2555 return;
2556 }
2557
2558 /* Convert cl->length. */
2559
2560 gcc_assert (cl->length);
2561
2562 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2563 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2564 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2565 gfc_add_block_to_block (pblock, &se.pre);
2566
2567 if (cl->backend_decl && VAR_P (cl->backend_decl))
2568 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2569 else
2570 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2571 }
2572
2573
2574 static void
gfc_conv_substring(gfc_se * se,gfc_ref * ref,int kind,const char * name,locus * where)2575 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2576 const char *name, locus *where)
2577 {
2578 tree tmp;
2579 tree type;
2580 tree fault;
2581 gfc_se start;
2582 gfc_se end;
2583 char *msg;
2584 mpz_t length;
2585
2586 type = gfc_get_character_type (kind, ref->u.ss.length);
2587 type = build_pointer_type (type);
2588
2589 gfc_init_se (&start, se);
2590 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2591 gfc_add_block_to_block (&se->pre, &start.pre);
2592
2593 if (integer_onep (start.expr))
2594 gfc_conv_string_parameter (se);
2595 else
2596 {
2597 tmp = start.expr;
2598 STRIP_NOPS (tmp);
2599 /* Avoid multiple evaluation of substring start. */
2600 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2601 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2602
2603 /* Change the start of the string. */
2604 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2605 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2606 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2607 tmp = se->expr;
2608 else
2609 tmp = build_fold_indirect_ref_loc (input_location,
2610 se->expr);
2611 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2612 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2613 {
2614 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2615 se->expr = gfc_build_addr_expr (type, tmp);
2616 }
2617 }
2618
2619 /* Length = end + 1 - start. */
2620 gfc_init_se (&end, se);
2621 if (ref->u.ss.end == NULL)
2622 end.expr = se->string_length;
2623 else
2624 {
2625 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2626 gfc_add_block_to_block (&se->pre, &end.pre);
2627 }
2628 tmp = end.expr;
2629 STRIP_NOPS (tmp);
2630 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2631 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2632
2633 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2634 && (ref->u.ss.start->symtree
2635 && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
2636 {
2637 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2638 logical_type_node, start.expr,
2639 end.expr);
2640
2641 /* Check lower bound. */
2642 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2643 start.expr,
2644 build_one_cst (TREE_TYPE (start.expr)));
2645 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2646 logical_type_node, nonempty, fault);
2647 if (name)
2648 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2649 "is less than one", name);
2650 else
2651 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2652 "is less than one");
2653 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2654 fold_convert (long_integer_type_node,
2655 start.expr));
2656 free (msg);
2657
2658 /* Check upper bound. */
2659 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2660 end.expr, se->string_length);
2661 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2662 logical_type_node, nonempty, fault);
2663 if (name)
2664 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2665 "exceeds string length (%%ld)", name);
2666 else
2667 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2668 "exceeds string length (%%ld)");
2669 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2670 fold_convert (long_integer_type_node, end.expr),
2671 fold_convert (long_integer_type_node,
2672 se->string_length));
2673 free (msg);
2674 }
2675
2676 /* Try to calculate the length from the start and end expressions. */
2677 if (ref->u.ss.end
2678 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2679 {
2680 HOST_WIDE_INT i_len;
2681
2682 i_len = gfc_mpz_get_hwi (length) + 1;
2683 if (i_len < 0)
2684 i_len = 0;
2685
2686 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2687 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2688 }
2689 else
2690 {
2691 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2692 fold_convert (gfc_charlen_type_node, end.expr),
2693 fold_convert (gfc_charlen_type_node, start.expr));
2694 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2695 build_int_cst (gfc_charlen_type_node, 1), tmp);
2696 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2697 tmp, build_int_cst (gfc_charlen_type_node, 0));
2698 }
2699
2700 se->string_length = tmp;
2701 }
2702
2703
2704 /* Convert a derived type component reference. */
2705
2706 void
gfc_conv_component_ref(gfc_se * se,gfc_ref * ref)2707 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2708 {
2709 gfc_component *c;
2710 tree tmp;
2711 tree decl;
2712 tree field;
2713 tree context;
2714
2715 c = ref->u.c.component;
2716
2717 if (c->backend_decl == NULL_TREE
2718 && ref->u.c.sym != NULL)
2719 gfc_get_derived_type (ref->u.c.sym);
2720
2721 field = c->backend_decl;
2722 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2723 decl = se->expr;
2724 context = DECL_FIELD_CONTEXT (field);
2725
2726 /* Components can correspond to fields of different containing
2727 types, as components are created without context, whereas
2728 a concrete use of a component has the type of decl as context.
2729 So, if the type doesn't match, we search the corresponding
2730 FIELD_DECL in the parent type. To not waste too much time
2731 we cache this result in norestrict_decl.
2732 On the other hand, if the context is a UNION or a MAP (a
2733 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2734
2735 if (context != TREE_TYPE (decl)
2736 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2737 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2738 {
2739 tree f2 = c->norestrict_decl;
2740 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2741 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2742 if (TREE_CODE (f2) == FIELD_DECL
2743 && DECL_NAME (f2) == DECL_NAME (field))
2744 break;
2745 gcc_assert (f2);
2746 c->norestrict_decl = f2;
2747 field = f2;
2748 }
2749
2750 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2751 && strcmp ("_data", c->name) == 0)
2752 {
2753 /* Found a ref to the _data component. Store the associated ref to
2754 the vptr in se->class_vptr. */
2755 se->class_vptr = gfc_class_vptr_get (decl);
2756 }
2757 else
2758 se->class_vptr = NULL_TREE;
2759
2760 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2761 decl, field, NULL_TREE);
2762
2763 se->expr = tmp;
2764
2765 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2766 strlen () conditional below. */
2767 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2768 && !c->ts.deferred
2769 && !c->attr.pdt_string)
2770 {
2771 tmp = c->ts.u.cl->backend_decl;
2772 /* Components must always be constant length. */
2773 gcc_assert (tmp && INTEGER_CST_P (tmp));
2774 se->string_length = tmp;
2775 }
2776
2777 if (gfc_deferred_strlen (c, &field))
2778 {
2779 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2780 TREE_TYPE (field),
2781 decl, field, NULL_TREE);
2782 se->string_length = tmp;
2783 }
2784
2785 if (((c->attr.pointer || c->attr.allocatable)
2786 && (!c->attr.dimension && !c->attr.codimension)
2787 && c->ts.type != BT_CHARACTER)
2788 || c->attr.proc_pointer)
2789 se->expr = build_fold_indirect_ref_loc (input_location,
2790 se->expr);
2791 }
2792
2793
2794 /* This function deals with component references to components of the
2795 parent type for derived type extensions. */
2796 void
conv_parent_component_references(gfc_se * se,gfc_ref * ref)2797 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2798 {
2799 gfc_component *c;
2800 gfc_component *cmp;
2801 gfc_symbol *dt;
2802 gfc_ref parent;
2803
2804 dt = ref->u.c.sym;
2805 c = ref->u.c.component;
2806
2807 /* Return if the component is in the parent type. */
2808 for (cmp = dt->components; cmp; cmp = cmp->next)
2809 if (strcmp (c->name, cmp->name) == 0)
2810 return;
2811
2812 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2813 parent.type = REF_COMPONENT;
2814 parent.next = NULL;
2815 parent.u.c.sym = dt;
2816 parent.u.c.component = dt->components;
2817
2818 if (dt->backend_decl == NULL)
2819 gfc_get_derived_type (dt);
2820
2821 /* Build the reference and call self. */
2822 gfc_conv_component_ref (se, &parent);
2823 parent.u.c.sym = dt->components->ts.u.derived;
2824 parent.u.c.component = c;
2825 conv_parent_component_references (se, &parent);
2826 }
2827
2828
2829 static void
conv_inquiry(gfc_se * se,gfc_ref * ref,gfc_expr * expr,gfc_typespec * ts)2830 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2831 {
2832 tree res = se->expr;
2833
2834 switch (ref->u.i)
2835 {
2836 case INQUIRY_RE:
2837 res = fold_build1_loc (input_location, REALPART_EXPR,
2838 TREE_TYPE (TREE_TYPE (res)), res);
2839 break;
2840
2841 case INQUIRY_IM:
2842 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2843 TREE_TYPE (TREE_TYPE (res)), res);
2844 break;
2845
2846 case INQUIRY_KIND:
2847 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2848 ts->kind);
2849 break;
2850
2851 case INQUIRY_LEN:
2852 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2853 se->string_length);
2854 break;
2855
2856 default:
2857 gcc_unreachable ();
2858 }
2859 se->expr = res;
2860 }
2861
2862 /* Dereference VAR where needed if it is a pointer, reference, etc.
2863 according to Fortran semantics. */
2864
2865 tree
gfc_maybe_dereference_var(gfc_symbol * sym,tree var,bool descriptor_only_p,bool is_classarray)2866 gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
2867 bool is_classarray)
2868 {
2869 if (is_CFI_desc (sym, NULL))
2870 return build_fold_indirect_ref_loc (input_location, var);
2871
2872 /* Characters are entirely different from other types, they are treated
2873 separately. */
2874 if (sym->ts.type == BT_CHARACTER)
2875 {
2876 /* Dereference character pointer dummy arguments
2877 or results. */
2878 if ((sym->attr.pointer || sym->attr.allocatable
2879 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2880 && (sym->attr.dummy
2881 || sym->attr.function
2882 || sym->attr.result))
2883 var = build_fold_indirect_ref_loc (input_location, var);
2884 }
2885 else if (!sym->attr.value)
2886 {
2887 /* Dereference temporaries for class array dummy arguments. */
2888 if (sym->attr.dummy && is_classarray
2889 && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
2890 {
2891 if (!descriptor_only_p)
2892 var = GFC_DECL_SAVED_DESCRIPTOR (var);
2893
2894 var = build_fold_indirect_ref_loc (input_location, var);
2895 }
2896
2897 /* Dereference non-character scalar dummy arguments. */
2898 if (sym->attr.dummy && !sym->attr.dimension
2899 && !(sym->attr.codimension && sym->attr.allocatable)
2900 && (sym->ts.type != BT_CLASS
2901 || (!CLASS_DATA (sym)->attr.dimension
2902 && !(CLASS_DATA (sym)->attr.codimension
2903 && CLASS_DATA (sym)->attr.allocatable))))
2904 var = build_fold_indirect_ref_loc (input_location, var);
2905
2906 /* Dereference scalar hidden result. */
2907 if (flag_f2c && sym->ts.type == BT_COMPLEX
2908 && (sym->attr.function || sym->attr.result)
2909 && !sym->attr.dimension && !sym->attr.pointer
2910 && !sym->attr.always_explicit)
2911 var = build_fold_indirect_ref_loc (input_location, var);
2912
2913 /* Dereference non-character, non-class pointer variables.
2914 These must be dummies, results, or scalars. */
2915 if (!is_classarray
2916 && (sym->attr.pointer || sym->attr.allocatable
2917 || gfc_is_associate_pointer (sym)
2918 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2919 && (sym->attr.dummy
2920 || sym->attr.function
2921 || sym->attr.result
2922 || (!sym->attr.dimension
2923 && (!sym->attr.codimension || !sym->attr.allocatable))))
2924 var = build_fold_indirect_ref_loc (input_location, var);
2925 /* Now treat the class array pointer variables accordingly. */
2926 else if (sym->ts.type == BT_CLASS
2927 && sym->attr.dummy
2928 && (CLASS_DATA (sym)->attr.dimension
2929 || CLASS_DATA (sym)->attr.codimension)
2930 && ((CLASS_DATA (sym)->as
2931 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2932 || CLASS_DATA (sym)->attr.allocatable
2933 || CLASS_DATA (sym)->attr.class_pointer))
2934 var = build_fold_indirect_ref_loc (input_location, var);
2935 /* And the case where a non-dummy, non-result, non-function,
2936 non-allotable and non-pointer classarray is present. This case was
2937 previously covered by the first if, but with introducing the
2938 condition !is_classarray there, that case has to be covered
2939 explicitly. */
2940 else if (sym->ts.type == BT_CLASS
2941 && !sym->attr.dummy
2942 && !sym->attr.function
2943 && !sym->attr.result
2944 && (CLASS_DATA (sym)->attr.dimension
2945 || CLASS_DATA (sym)->attr.codimension)
2946 && (sym->assoc
2947 || !CLASS_DATA (sym)->attr.allocatable)
2948 && !CLASS_DATA (sym)->attr.class_pointer)
2949 var = build_fold_indirect_ref_loc (input_location, var);
2950 }
2951
2952 return var;
2953 }
2954
2955 /* Return the contents of a variable. Also handles reference/pointer
2956 variables (all Fortran pointer references are implicit). */
2957
2958 static void
gfc_conv_variable(gfc_se * se,gfc_expr * expr)2959 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2960 {
2961 gfc_ss *ss;
2962 gfc_ref *ref;
2963 gfc_symbol *sym;
2964 tree parent_decl = NULL_TREE;
2965 int parent_flag;
2966 bool return_value;
2967 bool alternate_entry;
2968 bool entry_master;
2969 bool is_classarray;
2970 bool first_time = true;
2971
2972 sym = expr->symtree->n.sym;
2973 is_classarray = IS_CLASS_ARRAY (sym);
2974 ss = se->ss;
2975 if (ss != NULL)
2976 {
2977 gfc_ss_info *ss_info = ss->info;
2978
2979 /* Check that something hasn't gone horribly wrong. */
2980 gcc_assert (ss != gfc_ss_terminator);
2981 gcc_assert (ss_info->expr == expr);
2982
2983 /* A scalarized term. We already know the descriptor. */
2984 se->expr = ss_info->data.array.descriptor;
2985 se->string_length = ss_info->string_length;
2986 ref = ss_info->data.array.ref;
2987 if (ref)
2988 gcc_assert (ref->type == REF_ARRAY
2989 && ref->u.ar.type != AR_ELEMENT);
2990 else
2991 gfc_conv_tmp_array_ref (se);
2992 }
2993 else
2994 {
2995 tree se_expr = NULL_TREE;
2996
2997 se->expr = gfc_get_symbol_decl (sym);
2998
2999 /* Deal with references to a parent results or entries by storing
3000 the current_function_decl and moving to the parent_decl. */
3001 return_value = sym->attr.function && sym->result == sym;
3002 alternate_entry = sym->attr.function && sym->attr.entry
3003 && sym->result == sym;
3004 entry_master = sym->attr.result
3005 && sym->ns->proc_name->attr.entry_master
3006 && !gfc_return_by_reference (sym->ns->proc_name);
3007 if (current_function_decl)
3008 parent_decl = DECL_CONTEXT (current_function_decl);
3009
3010 if ((se->expr == parent_decl && return_value)
3011 || (sym->ns && sym->ns->proc_name
3012 && parent_decl
3013 && sym->ns->proc_name->backend_decl == parent_decl
3014 && (alternate_entry || entry_master)))
3015 parent_flag = 1;
3016 else
3017 parent_flag = 0;
3018
3019 /* Special case for assigning the return value of a function.
3020 Self recursive functions must have an explicit return value. */
3021 if (return_value && (se->expr == current_function_decl || parent_flag))
3022 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3023
3024 /* Similarly for alternate entry points. */
3025 else if (alternate_entry
3026 && (sym->ns->proc_name->backend_decl == current_function_decl
3027 || parent_flag))
3028 {
3029 gfc_entry_list *el = NULL;
3030
3031 for (el = sym->ns->entries; el; el = el->next)
3032 if (sym == el->sym)
3033 {
3034 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3035 break;
3036 }
3037 }
3038
3039 else if (entry_master
3040 && (sym->ns->proc_name->backend_decl == current_function_decl
3041 || parent_flag))
3042 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3043
3044 if (se_expr)
3045 se->expr = se_expr;
3046
3047 /* Procedure actual arguments. Look out for temporary variables
3048 with the same attributes as function values. */
3049 else if (!sym->attr.temporary
3050 && sym->attr.flavor == FL_PROCEDURE
3051 && se->expr != current_function_decl)
3052 {
3053 if (!sym->attr.dummy && !sym->attr.proc_pointer)
3054 {
3055 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3056 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3057 }
3058 return;
3059 }
3060
3061 /* Dereference the expression, where needed. */
3062 se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3063 is_classarray);
3064
3065 ref = expr->ref;
3066 }
3067
3068 /* For character variables, also get the length. */
3069 if (sym->ts.type == BT_CHARACTER)
3070 {
3071 /* If the character length of an entry isn't set, get the length from
3072 the master function instead. */
3073 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3074 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3075 else
3076 se->string_length = sym->ts.u.cl->backend_decl;
3077 gcc_assert (se->string_length);
3078 }
3079
3080 gfc_typespec *ts = &sym->ts;
3081 while (ref)
3082 {
3083 switch (ref->type)
3084 {
3085 case REF_ARRAY:
3086 /* Return the descriptor if that's what we want and this is an array
3087 section reference. */
3088 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3089 return;
3090 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3091 /* Return the descriptor for array pointers and allocations. */
3092 if (se->want_pointer
3093 && ref->next == NULL && (se->descriptor_only))
3094 return;
3095
3096 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3097 /* Return a pointer to an element. */
3098 break;
3099
3100 case REF_COMPONENT:
3101 ts = &ref->u.c.component->ts;
3102 if (first_time && is_classarray && sym->attr.dummy
3103 && se->descriptor_only
3104 && !CLASS_DATA (sym)->attr.allocatable
3105 && !CLASS_DATA (sym)->attr.class_pointer
3106 && CLASS_DATA (sym)->as
3107 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3108 && strcmp ("_data", ref->u.c.component->name) == 0)
3109 /* Skip the first ref of a _data component, because for class
3110 arrays that one is already done by introducing a temporary
3111 array descriptor. */
3112 break;
3113
3114 if (ref->u.c.sym->attr.extension)
3115 conv_parent_component_references (se, ref);
3116
3117 gfc_conv_component_ref (se, ref);
3118 if (!ref->next && ref->u.c.sym->attr.codimension
3119 && se->want_pointer && se->descriptor_only)
3120 return;
3121
3122 break;
3123
3124 case REF_SUBSTRING:
3125 gfc_conv_substring (se, ref, expr->ts.kind,
3126 expr->symtree->name, &expr->where);
3127 break;
3128
3129 case REF_INQUIRY:
3130 conv_inquiry (se, ref, expr, ts);
3131 break;
3132
3133 default:
3134 gcc_unreachable ();
3135 break;
3136 }
3137 first_time = false;
3138 ref = ref->next;
3139 }
3140 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3141 separately. */
3142 if (se->want_pointer)
3143 {
3144 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3145 gfc_conv_string_parameter (se);
3146 else
3147 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3148 }
3149 }
3150
3151
3152 /* Unary ops are easy... Or they would be if ! was a valid op. */
3153
3154 static void
gfc_conv_unary_op(enum tree_code code,gfc_se * se,gfc_expr * expr)3155 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3156 {
3157 gfc_se operand;
3158 tree type;
3159
3160 gcc_assert (expr->ts.type != BT_CHARACTER);
3161 /* Initialize the operand. */
3162 gfc_init_se (&operand, se);
3163 gfc_conv_expr_val (&operand, expr->value.op.op1);
3164 gfc_add_block_to_block (&se->pre, &operand.pre);
3165
3166 type = gfc_typenode_for_spec (&expr->ts);
3167
3168 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3169 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3170 All other unary operators have an equivalent GIMPLE unary operator. */
3171 if (code == TRUTH_NOT_EXPR)
3172 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3173 build_int_cst (type, 0));
3174 else
3175 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3176
3177 }
3178
3179 /* Expand power operator to optimal multiplications when a value is raised
3180 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3181 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3182 Programming", 3rd Edition, 1998. */
3183
3184 /* This code is mostly duplicated from expand_powi in the backend.
3185 We establish the "optimal power tree" lookup table with the defined size.
3186 The items in the table are the exponents used to calculate the index
3187 exponents. Any integer n less than the value can get an "addition chain",
3188 with the first node being one. */
3189 #define POWI_TABLE_SIZE 256
3190
3191 /* The table is from builtins.c. */
3192 static const unsigned char powi_table[POWI_TABLE_SIZE] =
3193 {
3194 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3195 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3196 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3197 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3198 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3199 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3200 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3201 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3202 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3203 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3204 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3205 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3206 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3207 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3208 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3209 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3210 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3211 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3212 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3213 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3214 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3215 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3216 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3217 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3218 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3219 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3220 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3221 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3222 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3223 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3224 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3225 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3226 };
3227
3228 /* If n is larger than lookup table's max index, we use the "window
3229 method". */
3230 #define POWI_WINDOW_SIZE 3
3231
3232 /* Recursive function to expand the power operator. The temporary
3233 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3234 static tree
gfc_conv_powi(gfc_se * se,unsigned HOST_WIDE_INT n,tree * tmpvar)3235 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3236 {
3237 tree op0;
3238 tree op1;
3239 tree tmp;
3240 int digit;
3241
3242 if (n < POWI_TABLE_SIZE)
3243 {
3244 if (tmpvar[n])
3245 return tmpvar[n];
3246
3247 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3248 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3249 }
3250 else if (n & 1)
3251 {
3252 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3253 op0 = gfc_conv_powi (se, n - digit, tmpvar);
3254 op1 = gfc_conv_powi (se, digit, tmpvar);
3255 }
3256 else
3257 {
3258 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3259 op1 = op0;
3260 }
3261
3262 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3263 tmp = gfc_evaluate_now (tmp, &se->pre);
3264
3265 if (n < POWI_TABLE_SIZE)
3266 tmpvar[n] = tmp;
3267
3268 return tmp;
3269 }
3270
3271
3272 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3273 return 1. Else return 0 and a call to runtime library functions
3274 will have to be built. */
3275 static int
gfc_conv_cst_int_power(gfc_se * se,tree lhs,tree rhs)3276 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3277 {
3278 tree cond;
3279 tree tmp;
3280 tree type;
3281 tree vartmp[POWI_TABLE_SIZE];
3282 HOST_WIDE_INT m;
3283 unsigned HOST_WIDE_INT n;
3284 int sgn;
3285 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3286
3287 /* If exponent is too large, we won't expand it anyway, so don't bother
3288 with large integer values. */
3289 if (!wi::fits_shwi_p (wrhs))
3290 return 0;
3291
3292 m = wrhs.to_shwi ();
3293 /* Use the wide_int's routine to reliably get the absolute value on all
3294 platforms. Then convert it to a HOST_WIDE_INT like above. */
3295 n = wi::abs (wrhs).to_shwi ();
3296
3297 type = TREE_TYPE (lhs);
3298 sgn = tree_int_cst_sgn (rhs);
3299
3300 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3301 || optimize_size) && (m > 2 || m < -1))
3302 return 0;
3303
3304 /* rhs == 0 */
3305 if (sgn == 0)
3306 {
3307 se->expr = gfc_build_const (type, integer_one_node);
3308 return 1;
3309 }
3310
3311 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3312 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3313 {
3314 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3315 lhs, build_int_cst (TREE_TYPE (lhs), -1));
3316 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3317 lhs, build_int_cst (TREE_TYPE (lhs), 1));
3318
3319 /* If rhs is even,
3320 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3321 if ((n & 1) == 0)
3322 {
3323 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3324 logical_type_node, tmp, cond);
3325 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3326 tmp, build_int_cst (type, 1),
3327 build_int_cst (type, 0));
3328 return 1;
3329 }
3330 /* If rhs is odd,
3331 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3332 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3333 build_int_cst (type, -1),
3334 build_int_cst (type, 0));
3335 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3336 cond, build_int_cst (type, 1), tmp);
3337 return 1;
3338 }
3339
3340 memset (vartmp, 0, sizeof (vartmp));
3341 vartmp[1] = lhs;
3342 if (sgn == -1)
3343 {
3344 tmp = gfc_build_const (type, integer_one_node);
3345 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3346 vartmp[1]);
3347 }
3348
3349 se->expr = gfc_conv_powi (se, n, vartmp);
3350
3351 return 1;
3352 }
3353
3354
3355 /* Power op (**). Constant integer exponent has special handling. */
3356
3357 static void
gfc_conv_power_op(gfc_se * se,gfc_expr * expr)3358 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3359 {
3360 tree gfc_int4_type_node;
3361 int kind;
3362 int ikind;
3363 int res_ikind_1, res_ikind_2;
3364 gfc_se lse;
3365 gfc_se rse;
3366 tree fndecl = NULL;
3367
3368 gfc_init_se (&lse, se);
3369 gfc_conv_expr_val (&lse, expr->value.op.op1);
3370 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3371 gfc_add_block_to_block (&se->pre, &lse.pre);
3372
3373 gfc_init_se (&rse, se);
3374 gfc_conv_expr_val (&rse, expr->value.op.op2);
3375 gfc_add_block_to_block (&se->pre, &rse.pre);
3376
3377 if (expr->value.op.op2->ts.type == BT_INTEGER
3378 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3379 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3380 return;
3381
3382 if (INTEGER_CST_P (lse.expr)
3383 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3384 {
3385 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3386 HOST_WIDE_INT v, w;
3387 int kind, ikind, bit_size;
3388
3389 v = wlhs.to_shwi ();
3390 w = abs (v);
3391
3392 kind = expr->value.op.op1->ts.kind;
3393 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3394 bit_size = gfc_integer_kinds[ikind].bit_size;
3395
3396 if (v == 1)
3397 {
3398 /* 1**something is always 1. */
3399 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3400 return;
3401 }
3402 else if (v == -1)
3403 {
3404 /* (-1)**n is 1 - ((n & 1) << 1) */
3405 tree type;
3406 tree tmp;
3407
3408 type = TREE_TYPE (lse.expr);
3409 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3410 rse.expr, build_int_cst (type, 1));
3411 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3412 tmp, build_int_cst (type, 1));
3413 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3414 build_int_cst (type, 1), tmp);
3415 se->expr = tmp;
3416 return;
3417 }
3418 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3419 {
3420 /* Here v is +/- 2**e. The further simplification uses
3421 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3422 1<<(4*n), etc., but we have to make sure to return zero
3423 if the number of bits is too large. */
3424 tree lshift;
3425 tree type;
3426 tree shift;
3427 tree ge;
3428 tree cond;
3429 tree num_bits;
3430 tree cond2;
3431 tree tmp1;
3432
3433 type = TREE_TYPE (lse.expr);
3434
3435 if (w == 2)
3436 shift = rse.expr;
3437 else if (w == 4)
3438 shift = fold_build2_loc (input_location, PLUS_EXPR,
3439 TREE_TYPE (rse.expr),
3440 rse.expr, rse.expr);
3441 else
3442 {
3443 /* use popcount for fast log2(w) */
3444 int e = wi::popcount (w-1);
3445 shift = fold_build2_loc (input_location, MULT_EXPR,
3446 TREE_TYPE (rse.expr),
3447 build_int_cst (TREE_TYPE (rse.expr), e),
3448 rse.expr);
3449 }
3450
3451 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3452 build_int_cst (type, 1), shift);
3453 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3454 rse.expr, build_int_cst (type, 0));
3455 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3456 build_int_cst (type, 0));
3457 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3458 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3459 rse.expr, num_bits);
3460 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3461 build_int_cst (type, 0), cond);
3462 if (v > 0)
3463 {
3464 se->expr = tmp1;
3465 }
3466 else
3467 {
3468 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3469 tree tmp2;
3470 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3471 rse.expr, build_int_cst (type, 1));
3472 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3473 tmp2, build_int_cst (type, 1));
3474 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3475 build_int_cst (type, 1), tmp2);
3476 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3477 tmp1, tmp2);
3478 }
3479 return;
3480 }
3481 }
3482
3483 gfc_int4_type_node = gfc_get_int_type (4);
3484
3485 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3486 library routine. But in the end, we have to convert the result back
3487 if this case applies -- with res_ikind_K, we keep track whether operand K
3488 falls into this case. */
3489 res_ikind_1 = -1;
3490 res_ikind_2 = -1;
3491
3492 kind = expr->value.op.op1->ts.kind;
3493 switch (expr->value.op.op2->ts.type)
3494 {
3495 case BT_INTEGER:
3496 ikind = expr->value.op.op2->ts.kind;
3497 switch (ikind)
3498 {
3499 case 1:
3500 case 2:
3501 rse.expr = convert (gfc_int4_type_node, rse.expr);
3502 res_ikind_2 = ikind;
3503 /* Fall through. */
3504
3505 case 4:
3506 ikind = 0;
3507 break;
3508
3509 case 8:
3510 ikind = 1;
3511 break;
3512
3513 case 16:
3514 ikind = 2;
3515 break;
3516
3517 default:
3518 gcc_unreachable ();
3519 }
3520 switch (kind)
3521 {
3522 case 1:
3523 case 2:
3524 if (expr->value.op.op1->ts.type == BT_INTEGER)
3525 {
3526 lse.expr = convert (gfc_int4_type_node, lse.expr);
3527 res_ikind_1 = kind;
3528 }
3529 else
3530 gcc_unreachable ();
3531 /* Fall through. */
3532
3533 case 4:
3534 kind = 0;
3535 break;
3536
3537 case 8:
3538 kind = 1;
3539 break;
3540
3541 case 10:
3542 kind = 2;
3543 break;
3544
3545 case 16:
3546 kind = 3;
3547 break;
3548
3549 default:
3550 gcc_unreachable ();
3551 }
3552
3553 switch (expr->value.op.op1->ts.type)
3554 {
3555 case BT_INTEGER:
3556 if (kind == 3) /* Case 16 was not handled properly above. */
3557 kind = 2;
3558 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3559 break;
3560
3561 case BT_REAL:
3562 /* Use builtins for real ** int4. */
3563 if (ikind == 0)
3564 {
3565 switch (kind)
3566 {
3567 case 0:
3568 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3569 break;
3570
3571 case 1:
3572 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3573 break;
3574
3575 case 2:
3576 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3577 break;
3578
3579 case 3:
3580 /* Use the __builtin_powil() only if real(kind=16) is
3581 actually the C long double type. */
3582 if (!gfc_real16_is_float128)
3583 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3584 break;
3585
3586 default:
3587 gcc_unreachable ();
3588 }
3589 }
3590
3591 /* If we don't have a good builtin for this, go for the
3592 library function. */
3593 if (!fndecl)
3594 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3595 break;
3596
3597 case BT_COMPLEX:
3598 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3599 break;
3600
3601 default:
3602 gcc_unreachable ();
3603 }
3604 break;
3605
3606 case BT_REAL:
3607 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3608 break;
3609
3610 case BT_COMPLEX:
3611 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3612 break;
3613
3614 default:
3615 gcc_unreachable ();
3616 break;
3617 }
3618
3619 se->expr = build_call_expr_loc (input_location,
3620 fndecl, 2, lse.expr, rse.expr);
3621
3622 /* Convert the result back if it is of wrong integer kind. */
3623 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3624 {
3625 /* We want the maximum of both operand kinds as result. */
3626 if (res_ikind_1 < res_ikind_2)
3627 res_ikind_1 = res_ikind_2;
3628 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3629 }
3630 }
3631
3632
3633 /* Generate code to allocate a string temporary. */
3634
3635 tree
gfc_conv_string_tmp(gfc_se * se,tree type,tree len)3636 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3637 {
3638 tree var;
3639 tree tmp;
3640
3641 if (gfc_can_put_var_on_stack (len))
3642 {
3643 /* Create a temporary variable to hold the result. */
3644 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3645 TREE_TYPE (len), len,
3646 build_int_cst (TREE_TYPE (len), 1));
3647 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3648
3649 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3650 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3651 else
3652 tmp = build_array_type (TREE_TYPE (type), tmp);
3653
3654 var = gfc_create_var (tmp, "str");
3655 var = gfc_build_addr_expr (type, var);
3656 }
3657 else
3658 {
3659 /* Allocate a temporary to hold the result. */
3660 var = gfc_create_var (type, "pstr");
3661 gcc_assert (POINTER_TYPE_P (type));
3662 tmp = TREE_TYPE (type);
3663 if (TREE_CODE (tmp) == ARRAY_TYPE)
3664 tmp = TREE_TYPE (tmp);
3665 tmp = TYPE_SIZE_UNIT (tmp);
3666 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3667 fold_convert (size_type_node, len),
3668 fold_convert (size_type_node, tmp));
3669 tmp = gfc_call_malloc (&se->pre, type, tmp);
3670 gfc_add_modify (&se->pre, var, tmp);
3671
3672 /* Free the temporary afterwards. */
3673 tmp = gfc_call_free (var);
3674 gfc_add_expr_to_block (&se->post, tmp);
3675 }
3676
3677 return var;
3678 }
3679
3680
3681 /* Handle a string concatenation operation. A temporary will be allocated to
3682 hold the result. */
3683
3684 static void
gfc_conv_concat_op(gfc_se * se,gfc_expr * expr)3685 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3686 {
3687 gfc_se lse, rse;
3688 tree len, type, var, tmp, fndecl;
3689
3690 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3691 && expr->value.op.op2->ts.type == BT_CHARACTER);
3692 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3693
3694 gfc_init_se (&lse, se);
3695 gfc_conv_expr (&lse, expr->value.op.op1);
3696 gfc_conv_string_parameter (&lse);
3697 gfc_init_se (&rse, se);
3698 gfc_conv_expr (&rse, expr->value.op.op2);
3699 gfc_conv_string_parameter (&rse);
3700
3701 gfc_add_block_to_block (&se->pre, &lse.pre);
3702 gfc_add_block_to_block (&se->pre, &rse.pre);
3703
3704 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3705 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3706 if (len == NULL_TREE)
3707 {
3708 len = fold_build2_loc (input_location, PLUS_EXPR,
3709 gfc_charlen_type_node,
3710 fold_convert (gfc_charlen_type_node,
3711 lse.string_length),
3712 fold_convert (gfc_charlen_type_node,
3713 rse.string_length));
3714 }
3715
3716 type = build_pointer_type (type);
3717
3718 var = gfc_conv_string_tmp (se, type, len);
3719
3720 /* Do the actual concatenation. */
3721 if (expr->ts.kind == 1)
3722 fndecl = gfor_fndecl_concat_string;
3723 else if (expr->ts.kind == 4)
3724 fndecl = gfor_fndecl_concat_string_char4;
3725 else
3726 gcc_unreachable ();
3727
3728 tmp = build_call_expr_loc (input_location,
3729 fndecl, 6, len, var, lse.string_length, lse.expr,
3730 rse.string_length, rse.expr);
3731 gfc_add_expr_to_block (&se->pre, tmp);
3732
3733 /* Add the cleanup for the operands. */
3734 gfc_add_block_to_block (&se->pre, &rse.post);
3735 gfc_add_block_to_block (&se->pre, &lse.post);
3736
3737 se->expr = var;
3738 se->string_length = len;
3739 }
3740
3741 /* Translates an op expression. Common (binary) cases are handled by this
3742 function, others are passed on. Recursion is used in either case.
3743 We use the fact that (op1.ts == op2.ts) (except for the power
3744 operator **).
3745 Operators need no special handling for scalarized expressions as long as
3746 they call gfc_conv_simple_val to get their operands.
3747 Character strings get special handling. */
3748
3749 static void
gfc_conv_expr_op(gfc_se * se,gfc_expr * expr)3750 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3751 {
3752 enum tree_code code;
3753 gfc_se lse;
3754 gfc_se rse;
3755 tree tmp, type;
3756 int lop;
3757 int checkstring;
3758
3759 checkstring = 0;
3760 lop = 0;
3761 switch (expr->value.op.op)
3762 {
3763 case INTRINSIC_PARENTHESES:
3764 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3765 && flag_protect_parens)
3766 {
3767 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3768 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3769 return;
3770 }
3771
3772 /* Fallthrough. */
3773 case INTRINSIC_UPLUS:
3774 gfc_conv_expr (se, expr->value.op.op1);
3775 return;
3776
3777 case INTRINSIC_UMINUS:
3778 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3779 return;
3780
3781 case INTRINSIC_NOT:
3782 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3783 return;
3784
3785 case INTRINSIC_PLUS:
3786 code = PLUS_EXPR;
3787 break;
3788
3789 case INTRINSIC_MINUS:
3790 code = MINUS_EXPR;
3791 break;
3792
3793 case INTRINSIC_TIMES:
3794 code = MULT_EXPR;
3795 break;
3796
3797 case INTRINSIC_DIVIDE:
3798 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3799 an integer, we must round towards zero, so we use a
3800 TRUNC_DIV_EXPR. */
3801 if (expr->ts.type == BT_INTEGER)
3802 code = TRUNC_DIV_EXPR;
3803 else
3804 code = RDIV_EXPR;
3805 break;
3806
3807 case INTRINSIC_POWER:
3808 gfc_conv_power_op (se, expr);
3809 return;
3810
3811 case INTRINSIC_CONCAT:
3812 gfc_conv_concat_op (se, expr);
3813 return;
3814
3815 case INTRINSIC_AND:
3816 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3817 lop = 1;
3818 break;
3819
3820 case INTRINSIC_OR:
3821 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3822 lop = 1;
3823 break;
3824
3825 /* EQV and NEQV only work on logicals, but since we represent them
3826 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3827 case INTRINSIC_EQ:
3828 case INTRINSIC_EQ_OS:
3829 case INTRINSIC_EQV:
3830 code = EQ_EXPR;
3831 checkstring = 1;
3832 lop = 1;
3833 break;
3834
3835 case INTRINSIC_NE:
3836 case INTRINSIC_NE_OS:
3837 case INTRINSIC_NEQV:
3838 code = NE_EXPR;
3839 checkstring = 1;
3840 lop = 1;
3841 break;
3842
3843 case INTRINSIC_GT:
3844 case INTRINSIC_GT_OS:
3845 code = GT_EXPR;
3846 checkstring = 1;
3847 lop = 1;
3848 break;
3849
3850 case INTRINSIC_GE:
3851 case INTRINSIC_GE_OS:
3852 code = GE_EXPR;
3853 checkstring = 1;
3854 lop = 1;
3855 break;
3856
3857 case INTRINSIC_LT:
3858 case INTRINSIC_LT_OS:
3859 code = LT_EXPR;
3860 checkstring = 1;
3861 lop = 1;
3862 break;
3863
3864 case INTRINSIC_LE:
3865 case INTRINSIC_LE_OS:
3866 code = LE_EXPR;
3867 checkstring = 1;
3868 lop = 1;
3869 break;
3870
3871 case INTRINSIC_USER:
3872 case INTRINSIC_ASSIGN:
3873 /* These should be converted into function calls by the frontend. */
3874 gcc_unreachable ();
3875
3876 default:
3877 fatal_error (input_location, "Unknown intrinsic op");
3878 return;
3879 }
3880
3881 /* The only exception to this is **, which is handled separately anyway. */
3882 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3883
3884 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3885 checkstring = 0;
3886
3887 /* lhs */
3888 gfc_init_se (&lse, se);
3889 gfc_conv_expr (&lse, expr->value.op.op1);
3890 gfc_add_block_to_block (&se->pre, &lse.pre);
3891
3892 /* rhs */
3893 gfc_init_se (&rse, se);
3894 gfc_conv_expr (&rse, expr->value.op.op2);
3895 gfc_add_block_to_block (&se->pre, &rse.pre);
3896
3897 if (checkstring)
3898 {
3899 gfc_conv_string_parameter (&lse);
3900 gfc_conv_string_parameter (&rse);
3901
3902 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3903 rse.string_length, rse.expr,
3904 expr->value.op.op1->ts.kind,
3905 code);
3906 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3907 gfc_add_block_to_block (&lse.post, &rse.post);
3908 }
3909
3910 type = gfc_typenode_for_spec (&expr->ts);
3911
3912 if (lop)
3913 {
3914 /* The result of logical ops is always logical_type_node. */
3915 tmp = fold_build2_loc (input_location, code, logical_type_node,
3916 lse.expr, rse.expr);
3917 se->expr = convert (type, tmp);
3918 }
3919 else
3920 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3921
3922 /* Add the post blocks. */
3923 gfc_add_block_to_block (&se->post, &rse.post);
3924 gfc_add_block_to_block (&se->post, &lse.post);
3925 }
3926
3927 /* If a string's length is one, we convert it to a single character. */
3928
3929 tree
gfc_string_to_single_character(tree len,tree str,int kind)3930 gfc_string_to_single_character (tree len, tree str, int kind)
3931 {
3932
3933 if (len == NULL
3934 || !tree_fits_uhwi_p (len)
3935 || !POINTER_TYPE_P (TREE_TYPE (str)))
3936 return NULL_TREE;
3937
3938 if (TREE_INT_CST_LOW (len) == 1)
3939 {
3940 str = fold_convert (gfc_get_pchar_type (kind), str);
3941 return build_fold_indirect_ref_loc (input_location, str);
3942 }
3943
3944 if (kind == 1
3945 && TREE_CODE (str) == ADDR_EXPR
3946 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3947 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3948 && array_ref_low_bound (TREE_OPERAND (str, 0))
3949 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3950 && TREE_INT_CST_LOW (len) > 1
3951 && TREE_INT_CST_LOW (len)
3952 == (unsigned HOST_WIDE_INT)
3953 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3954 {
3955 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3956 ret = build_fold_indirect_ref_loc (input_location, ret);
3957 if (TREE_CODE (ret) == INTEGER_CST)
3958 {
3959 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3960 int i, length = TREE_STRING_LENGTH (string_cst);
3961 const char *ptr = TREE_STRING_POINTER (string_cst);
3962
3963 for (i = 1; i < length; i++)
3964 if (ptr[i] != ' ')
3965 return NULL_TREE;
3966
3967 return ret;
3968 }
3969 }
3970
3971 return NULL_TREE;
3972 }
3973
3974
3975 void
gfc_conv_scalar_char_value(gfc_symbol * sym,gfc_se * se,gfc_expr ** expr)3976 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3977 {
3978
3979 if (sym->backend_decl)
3980 {
3981 /* This becomes the nominal_type in
3982 function.c:assign_parm_find_data_types. */
3983 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3984 /* This becomes the passed_type in
3985 function.c:assign_parm_find_data_types. C promotes char to
3986 integer for argument passing. */
3987 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3988
3989 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3990 }
3991
3992 if (expr != NULL)
3993 {
3994 /* If we have a constant character expression, make it into an
3995 integer. */
3996 if ((*expr)->expr_type == EXPR_CONSTANT)
3997 {
3998 gfc_typespec ts;
3999 gfc_clear_ts (&ts);
4000
4001 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4002 (int)(*expr)->value.character.string[0]);
4003 if ((*expr)->ts.kind != gfc_c_int_kind)
4004 {
4005 /* The expr needs to be compatible with a C int. If the
4006 conversion fails, then the 2 causes an ICE. */
4007 ts.type = BT_INTEGER;
4008 ts.kind = gfc_c_int_kind;
4009 gfc_convert_type (*expr, &ts, 2);
4010 }
4011 }
4012 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4013 {
4014 if ((*expr)->ref == NULL)
4015 {
4016 se->expr = gfc_string_to_single_character
4017 (build_int_cst (integer_type_node, 1),
4018 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4019 gfc_get_symbol_decl
4020 ((*expr)->symtree->n.sym)),
4021 (*expr)->ts.kind);
4022 }
4023 else
4024 {
4025 gfc_conv_variable (se, *expr);
4026 se->expr = gfc_string_to_single_character
4027 (build_int_cst (integer_type_node, 1),
4028 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4029 se->expr),
4030 (*expr)->ts.kind);
4031 }
4032 }
4033 }
4034 }
4035
4036 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4037 if STR is a string literal, otherwise return -1. */
4038
4039 static int
gfc_optimize_len_trim(tree len,tree str,int kind)4040 gfc_optimize_len_trim (tree len, tree str, int kind)
4041 {
4042 if (kind == 1
4043 && TREE_CODE (str) == ADDR_EXPR
4044 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4045 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4046 && array_ref_low_bound (TREE_OPERAND (str, 0))
4047 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4048 && tree_fits_uhwi_p (len)
4049 && tree_to_uhwi (len) >= 1
4050 && tree_to_uhwi (len)
4051 == (unsigned HOST_WIDE_INT)
4052 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4053 {
4054 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4055 folded = build_fold_indirect_ref_loc (input_location, folded);
4056 if (TREE_CODE (folded) == INTEGER_CST)
4057 {
4058 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4059 int length = TREE_STRING_LENGTH (string_cst);
4060 const char *ptr = TREE_STRING_POINTER (string_cst);
4061
4062 for (; length > 0; length--)
4063 if (ptr[length - 1] != ' ')
4064 break;
4065
4066 return length;
4067 }
4068 }
4069 return -1;
4070 }
4071
4072 /* Helper to build a call to memcmp. */
4073
4074 static tree
build_memcmp_call(tree s1,tree s2,tree n)4075 build_memcmp_call (tree s1, tree s2, tree n)
4076 {
4077 tree tmp;
4078
4079 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4080 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4081 else
4082 s1 = fold_convert (pvoid_type_node, s1);
4083
4084 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4085 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4086 else
4087 s2 = fold_convert (pvoid_type_node, s2);
4088
4089 n = fold_convert (size_type_node, n);
4090
4091 tmp = build_call_expr_loc (input_location,
4092 builtin_decl_explicit (BUILT_IN_MEMCMP),
4093 3, s1, s2, n);
4094
4095 return fold_convert (integer_type_node, tmp);
4096 }
4097
4098 /* Compare two strings. If they are all single characters, the result is the
4099 subtraction of them. Otherwise, we build a library call. */
4100
4101 tree
gfc_build_compare_string(tree len1,tree str1,tree len2,tree str2,int kind,enum tree_code code)4102 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4103 enum tree_code code)
4104 {
4105 tree sc1;
4106 tree sc2;
4107 tree fndecl;
4108
4109 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4110 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4111
4112 sc1 = gfc_string_to_single_character (len1, str1, kind);
4113 sc2 = gfc_string_to_single_character (len2, str2, kind);
4114
4115 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4116 {
4117 /* Deal with single character specially. */
4118 sc1 = fold_convert (integer_type_node, sc1);
4119 sc2 = fold_convert (integer_type_node, sc2);
4120 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4121 sc1, sc2);
4122 }
4123
4124 if ((code == EQ_EXPR || code == NE_EXPR)
4125 && optimize
4126 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4127 {
4128 /* If one string is a string literal with LEN_TRIM longer
4129 than the length of the second string, the strings
4130 compare unequal. */
4131 int len = gfc_optimize_len_trim (len1, str1, kind);
4132 if (len > 0 && compare_tree_int (len2, len) < 0)
4133 return integer_one_node;
4134 len = gfc_optimize_len_trim (len2, str2, kind);
4135 if (len > 0 && compare_tree_int (len1, len) < 0)
4136 return integer_one_node;
4137 }
4138
4139 /* We can compare via memcpy if the strings are known to be equal
4140 in length and they are
4141 - kind=1
4142 - kind=4 and the comparison is for (in)equality. */
4143
4144 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4145 && tree_int_cst_equal (len1, len2)
4146 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4147 {
4148 tree tmp;
4149 tree chartype;
4150
4151 chartype = gfc_get_char_type (kind);
4152 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4153 fold_convert (TREE_TYPE(len1),
4154 TYPE_SIZE_UNIT(chartype)),
4155 len1);
4156 return build_memcmp_call (str1, str2, tmp);
4157 }
4158
4159 /* Build a call for the comparison. */
4160 if (kind == 1)
4161 fndecl = gfor_fndecl_compare_string;
4162 else if (kind == 4)
4163 fndecl = gfor_fndecl_compare_string_char4;
4164 else
4165 gcc_unreachable ();
4166
4167 return build_call_expr_loc (input_location, fndecl, 4,
4168 len1, str1, len2, str2);
4169 }
4170
4171
4172 /* Return the backend_decl for a procedure pointer component. */
4173
4174 static tree
get_proc_ptr_comp(gfc_expr * e)4175 get_proc_ptr_comp (gfc_expr *e)
4176 {
4177 gfc_se comp_se;
4178 gfc_expr *e2;
4179 expr_t old_type;
4180
4181 gfc_init_se (&comp_se, NULL);
4182 e2 = gfc_copy_expr (e);
4183 /* We have to restore the expr type later so that gfc_free_expr frees
4184 the exact same thing that was allocated.
4185 TODO: This is ugly. */
4186 old_type = e2->expr_type;
4187 e2->expr_type = EXPR_VARIABLE;
4188 gfc_conv_expr (&comp_se, e2);
4189 e2->expr_type = old_type;
4190 gfc_free_expr (e2);
4191 return build_fold_addr_expr_loc (input_location, comp_se.expr);
4192 }
4193
4194
4195 /* Convert a typebound function reference from a class object. */
4196 static void
conv_base_obj_fcn_val(gfc_se * se,tree base_object,gfc_expr * expr)4197 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4198 {
4199 gfc_ref *ref;
4200 tree var;
4201
4202 if (!VAR_P (base_object))
4203 {
4204 var = gfc_create_var (TREE_TYPE (base_object), NULL);
4205 gfc_add_modify (&se->pre, var, base_object);
4206 }
4207 se->expr = gfc_class_vptr_get (base_object);
4208 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4209 ref = expr->ref;
4210 while (ref && ref->next)
4211 ref = ref->next;
4212 gcc_assert (ref && ref->type == REF_COMPONENT);
4213 if (ref->u.c.sym->attr.extension)
4214 conv_parent_component_references (se, ref);
4215 gfc_conv_component_ref (se, ref);
4216 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4217 }
4218
4219
4220 static void
conv_function_val(gfc_se * se,gfc_symbol * sym,gfc_expr * expr,gfc_actual_arglist * actual_args)4221 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
4222 gfc_actual_arglist *actual_args)
4223 {
4224 tree tmp;
4225
4226 if (gfc_is_proc_ptr_comp (expr))
4227 tmp = get_proc_ptr_comp (expr);
4228 else if (sym->attr.dummy)
4229 {
4230 tmp = gfc_get_symbol_decl (sym);
4231 if (sym->attr.proc_pointer)
4232 tmp = build_fold_indirect_ref_loc (input_location,
4233 tmp);
4234 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4235 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4236 }
4237 else
4238 {
4239 if (!sym->backend_decl)
4240 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4241
4242 TREE_USED (sym->backend_decl) = 1;
4243
4244 tmp = sym->backend_decl;
4245
4246 if (sym->attr.cray_pointee)
4247 {
4248 /* TODO - make the cray pointee a pointer to a procedure,
4249 assign the pointer to it and use it for the call. This
4250 will do for now! */
4251 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4252 gfc_get_symbol_decl (sym->cp_pointer));
4253 tmp = gfc_evaluate_now (tmp, &se->pre);
4254 }
4255
4256 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4257 {
4258 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4259 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4260 }
4261 }
4262 se->expr = tmp;
4263 }
4264
4265
4266 /* Initialize MAPPING. */
4267
4268 void
gfc_init_interface_mapping(gfc_interface_mapping * mapping)4269 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4270 {
4271 mapping->syms = NULL;
4272 mapping->charlens = NULL;
4273 }
4274
4275
4276 /* Free all memory held by MAPPING (but not MAPPING itself). */
4277
4278 void
gfc_free_interface_mapping(gfc_interface_mapping * mapping)4279 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4280 {
4281 gfc_interface_sym_mapping *sym;
4282 gfc_interface_sym_mapping *nextsym;
4283 gfc_charlen *cl;
4284 gfc_charlen *nextcl;
4285
4286 for (sym = mapping->syms; sym; sym = nextsym)
4287 {
4288 nextsym = sym->next;
4289 sym->new_sym->n.sym->formal = NULL;
4290 gfc_free_symbol (sym->new_sym->n.sym);
4291 gfc_free_expr (sym->expr);
4292 free (sym->new_sym);
4293 free (sym);
4294 }
4295 for (cl = mapping->charlens; cl; cl = nextcl)
4296 {
4297 nextcl = cl->next;
4298 gfc_free_expr (cl->length);
4299 free (cl);
4300 }
4301 }
4302
4303
4304 /* Return a copy of gfc_charlen CL. Add the returned structure to
4305 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4306
4307 static gfc_charlen *
gfc_get_interface_mapping_charlen(gfc_interface_mapping * mapping,gfc_charlen * cl)4308 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4309 gfc_charlen * cl)
4310 {
4311 gfc_charlen *new_charlen;
4312
4313 new_charlen = gfc_get_charlen ();
4314 new_charlen->next = mapping->charlens;
4315 new_charlen->length = gfc_copy_expr (cl->length);
4316
4317 mapping->charlens = new_charlen;
4318 return new_charlen;
4319 }
4320
4321
4322 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4323 array variable that can be used as the actual argument for dummy
4324 argument SYM. Add any initialization code to BLOCK. PACKED is as
4325 for gfc_get_nodesc_array_type and DATA points to the first element
4326 in the passed array. */
4327
4328 static tree
gfc_get_interface_mapping_array(stmtblock_t * block,gfc_symbol * sym,gfc_packed packed,tree data)4329 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4330 gfc_packed packed, tree data)
4331 {
4332 tree type;
4333 tree var;
4334
4335 type = gfc_typenode_for_spec (&sym->ts);
4336 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4337 !sym->attr.target && !sym->attr.pointer
4338 && !sym->attr.proc_pointer);
4339
4340 var = gfc_create_var (type, "ifm");
4341 gfc_add_modify (block, var, fold_convert (type, data));
4342
4343 return var;
4344 }
4345
4346
4347 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4348 and offset of descriptorless array type TYPE given that it has the same
4349 size as DESC. Add any set-up code to BLOCK. */
4350
4351 static void
gfc_set_interface_mapping_bounds(stmtblock_t * block,tree type,tree desc)4352 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4353 {
4354 int n;
4355 tree dim;
4356 tree offset;
4357 tree tmp;
4358
4359 offset = gfc_index_zero_node;
4360 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4361 {
4362 dim = gfc_rank_cst[n];
4363 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4364 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4365 {
4366 GFC_TYPE_ARRAY_LBOUND (type, n)
4367 = gfc_conv_descriptor_lbound_get (desc, dim);
4368 GFC_TYPE_ARRAY_UBOUND (type, n)
4369 = gfc_conv_descriptor_ubound_get (desc, dim);
4370 }
4371 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4372 {
4373 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4374 gfc_array_index_type,
4375 gfc_conv_descriptor_ubound_get (desc, dim),
4376 gfc_conv_descriptor_lbound_get (desc, dim));
4377 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4378 gfc_array_index_type,
4379 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4380 tmp = gfc_evaluate_now (tmp, block);
4381 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4382 }
4383 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4384 GFC_TYPE_ARRAY_LBOUND (type, n),
4385 GFC_TYPE_ARRAY_STRIDE (type, n));
4386 offset = fold_build2_loc (input_location, MINUS_EXPR,
4387 gfc_array_index_type, offset, tmp);
4388 }
4389 offset = gfc_evaluate_now (offset, block);
4390 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4391 }
4392
4393
4394 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4395 in SE. The caller may still use se->expr and se->string_length after
4396 calling this function. */
4397
4398 void
gfc_add_interface_mapping(gfc_interface_mapping * mapping,gfc_symbol * sym,gfc_se * se,gfc_expr * expr)4399 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4400 gfc_symbol * sym, gfc_se * se,
4401 gfc_expr *expr)
4402 {
4403 gfc_interface_sym_mapping *sm;
4404 tree desc;
4405 tree tmp;
4406 tree value;
4407 gfc_symbol *new_sym;
4408 gfc_symtree *root;
4409 gfc_symtree *new_symtree;
4410
4411 /* Create a new symbol to represent the actual argument. */
4412 new_sym = gfc_new_symbol (sym->name, NULL);
4413 new_sym->ts = sym->ts;
4414 new_sym->as = gfc_copy_array_spec (sym->as);
4415 new_sym->attr.referenced = 1;
4416 new_sym->attr.dimension = sym->attr.dimension;
4417 new_sym->attr.contiguous = sym->attr.contiguous;
4418 new_sym->attr.codimension = sym->attr.codimension;
4419 new_sym->attr.pointer = sym->attr.pointer;
4420 new_sym->attr.allocatable = sym->attr.allocatable;
4421 new_sym->attr.flavor = sym->attr.flavor;
4422 new_sym->attr.function = sym->attr.function;
4423
4424 /* Ensure that the interface is available and that
4425 descriptors are passed for array actual arguments. */
4426 if (sym->attr.flavor == FL_PROCEDURE)
4427 {
4428 new_sym->formal = expr->symtree->n.sym->formal;
4429 new_sym->attr.always_explicit
4430 = expr->symtree->n.sym->attr.always_explicit;
4431 }
4432
4433 /* Create a fake symtree for it. */
4434 root = NULL;
4435 new_symtree = gfc_new_symtree (&root, sym->name);
4436 new_symtree->n.sym = new_sym;
4437 gcc_assert (new_symtree == root);
4438
4439 /* Create a dummy->actual mapping. */
4440 sm = XCNEW (gfc_interface_sym_mapping);
4441 sm->next = mapping->syms;
4442 sm->old = sym;
4443 sm->new_sym = new_symtree;
4444 sm->expr = gfc_copy_expr (expr);
4445 mapping->syms = sm;
4446
4447 /* Stabilize the argument's value. */
4448 if (!sym->attr.function && se)
4449 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4450
4451 if (sym->ts.type == BT_CHARACTER)
4452 {
4453 /* Create a copy of the dummy argument's length. */
4454 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4455 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4456
4457 /* If the length is specified as "*", record the length that
4458 the caller is passing. We should use the callee's length
4459 in all other cases. */
4460 if (!new_sym->ts.u.cl->length && se)
4461 {
4462 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4463 new_sym->ts.u.cl->backend_decl = se->string_length;
4464 }
4465 }
4466
4467 if (!se)
4468 return;
4469
4470 /* Use the passed value as-is if the argument is a function. */
4471 if (sym->attr.flavor == FL_PROCEDURE)
4472 value = se->expr;
4473
4474 /* If the argument is a pass-by-value scalar, use the value as is. */
4475 else if (!sym->attr.dimension && sym->attr.value)
4476 value = se->expr;
4477
4478 /* If the argument is either a string or a pointer to a string,
4479 convert it to a boundless character type. */
4480 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4481 {
4482 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4483 tmp = build_pointer_type (tmp);
4484 if (sym->attr.pointer)
4485 value = build_fold_indirect_ref_loc (input_location,
4486 se->expr);
4487 else
4488 value = se->expr;
4489 value = fold_convert (tmp, value);
4490 }
4491
4492 /* If the argument is a scalar, a pointer to an array or an allocatable,
4493 dereference it. */
4494 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4495 value = build_fold_indirect_ref_loc (input_location,
4496 se->expr);
4497
4498 /* For character(*), use the actual argument's descriptor. */
4499 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4500 value = build_fold_indirect_ref_loc (input_location,
4501 se->expr);
4502
4503 /* If the argument is an array descriptor, use it to determine
4504 information about the actual argument's shape. */
4505 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4506 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4507 {
4508 /* Get the actual argument's descriptor. */
4509 desc = build_fold_indirect_ref_loc (input_location,
4510 se->expr);
4511
4512 /* Create the replacement variable. */
4513 tmp = gfc_conv_descriptor_data_get (desc);
4514 value = gfc_get_interface_mapping_array (&se->pre, sym,
4515 PACKED_NO, tmp);
4516
4517 /* Use DESC to work out the upper bounds, strides and offset. */
4518 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4519 }
4520 else
4521 /* Otherwise we have a packed array. */
4522 value = gfc_get_interface_mapping_array (&se->pre, sym,
4523 PACKED_FULL, se->expr);
4524
4525 new_sym->backend_decl = value;
4526 }
4527
4528
4529 /* Called once all dummy argument mappings have been added to MAPPING,
4530 but before the mapping is used to evaluate expressions. Pre-evaluate
4531 the length of each argument, adding any initialization code to PRE and
4532 any finalization code to POST. */
4533
4534 static void
gfc_finish_interface_mapping(gfc_interface_mapping * mapping,stmtblock_t * pre,stmtblock_t * post)4535 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4536 stmtblock_t * pre, stmtblock_t * post)
4537 {
4538 gfc_interface_sym_mapping *sym;
4539 gfc_expr *expr;
4540 gfc_se se;
4541
4542 for (sym = mapping->syms; sym; sym = sym->next)
4543 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4544 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4545 {
4546 expr = sym->new_sym->n.sym->ts.u.cl->length;
4547 gfc_apply_interface_mapping_to_expr (mapping, expr);
4548 gfc_init_se (&se, NULL);
4549 gfc_conv_expr (&se, expr);
4550 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4551 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4552 gfc_add_block_to_block (pre, &se.pre);
4553 gfc_add_block_to_block (post, &se.post);
4554
4555 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4556 }
4557 }
4558
4559
4560 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4561 constructor C. */
4562
4563 static void
gfc_apply_interface_mapping_to_cons(gfc_interface_mapping * mapping,gfc_constructor_base base)4564 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4565 gfc_constructor_base base)
4566 {
4567 gfc_constructor *c;
4568 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4569 {
4570 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4571 if (c->iterator)
4572 {
4573 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4574 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4575 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4576 }
4577 }
4578 }
4579
4580
4581 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4582 reference REF. */
4583
4584 static void
gfc_apply_interface_mapping_to_ref(gfc_interface_mapping * mapping,gfc_ref * ref)4585 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4586 gfc_ref * ref)
4587 {
4588 int n;
4589
4590 for (; ref; ref = ref->next)
4591 switch (ref->type)
4592 {
4593 case REF_ARRAY:
4594 for (n = 0; n < ref->u.ar.dimen; n++)
4595 {
4596 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4597 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4598 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4599 }
4600 break;
4601
4602 case REF_COMPONENT:
4603 case REF_INQUIRY:
4604 break;
4605
4606 case REF_SUBSTRING:
4607 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4608 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4609 break;
4610 }
4611 }
4612
4613
4614 /* Convert intrinsic function calls into result expressions. */
4615
4616 static bool
gfc_map_intrinsic_function(gfc_expr * expr,gfc_interface_mapping * mapping)4617 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4618 {
4619 gfc_symbol *sym;
4620 gfc_expr *new_expr;
4621 gfc_expr *arg1;
4622 gfc_expr *arg2;
4623 int d, dup;
4624
4625 arg1 = expr->value.function.actual->expr;
4626 if (expr->value.function.actual->next)
4627 arg2 = expr->value.function.actual->next->expr;
4628 else
4629 arg2 = NULL;
4630
4631 sym = arg1->symtree->n.sym;
4632
4633 if (sym->attr.dummy)
4634 return false;
4635
4636 new_expr = NULL;
4637
4638 switch (expr->value.function.isym->id)
4639 {
4640 case GFC_ISYM_LEN:
4641 /* TODO figure out why this condition is necessary. */
4642 if (sym->attr.function
4643 && (arg1->ts.u.cl->length == NULL
4644 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4645 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4646 return false;
4647
4648 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4649 break;
4650
4651 case GFC_ISYM_LEN_TRIM:
4652 new_expr = gfc_copy_expr (arg1);
4653 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4654
4655 if (!new_expr)
4656 return false;
4657
4658 gfc_replace_expr (arg1, new_expr);
4659 return true;
4660
4661 case GFC_ISYM_SIZE:
4662 if (!sym->as || sym->as->rank == 0)
4663 return false;
4664
4665 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4666 {
4667 dup = mpz_get_si (arg2->value.integer);
4668 d = dup - 1;
4669 }
4670 else
4671 {
4672 dup = sym->as->rank;
4673 d = 0;
4674 }
4675
4676 for (; d < dup; d++)
4677 {
4678 gfc_expr *tmp;
4679
4680 if (!sym->as->upper[d] || !sym->as->lower[d])
4681 {
4682 gfc_free_expr (new_expr);
4683 return false;
4684 }
4685
4686 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4687 gfc_get_int_expr (gfc_default_integer_kind,
4688 NULL, 1));
4689 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4690 if (new_expr)
4691 new_expr = gfc_multiply (new_expr, tmp);
4692 else
4693 new_expr = tmp;
4694 }
4695 break;
4696
4697 case GFC_ISYM_LBOUND:
4698 case GFC_ISYM_UBOUND:
4699 /* TODO These implementations of lbound and ubound do not limit if
4700 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4701
4702 if (!sym->as || sym->as->rank == 0)
4703 return false;
4704
4705 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4706 d = mpz_get_si (arg2->value.integer) - 1;
4707 else
4708 return false;
4709
4710 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4711 {
4712 if (sym->as->lower[d])
4713 new_expr = gfc_copy_expr (sym->as->lower[d]);
4714 }
4715 else
4716 {
4717 if (sym->as->upper[d])
4718 new_expr = gfc_copy_expr (sym->as->upper[d]);
4719 }
4720 break;
4721
4722 default:
4723 break;
4724 }
4725
4726 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4727 if (!new_expr)
4728 return false;
4729
4730 gfc_replace_expr (expr, new_expr);
4731 return true;
4732 }
4733
4734
4735 static void
gfc_map_fcn_formal_to_actual(gfc_expr * expr,gfc_expr * map_expr,gfc_interface_mapping * mapping)4736 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4737 gfc_interface_mapping * mapping)
4738 {
4739 gfc_formal_arglist *f;
4740 gfc_actual_arglist *actual;
4741
4742 actual = expr->value.function.actual;
4743 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4744
4745 for (; f && actual; f = f->next, actual = actual->next)
4746 {
4747 if (!actual->expr)
4748 continue;
4749
4750 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4751 }
4752
4753 if (map_expr->symtree->n.sym->attr.dimension)
4754 {
4755 int d;
4756 gfc_array_spec *as;
4757
4758 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4759
4760 for (d = 0; d < as->rank; d++)
4761 {
4762 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4763 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4764 }
4765
4766 expr->value.function.esym->as = as;
4767 }
4768
4769 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4770 {
4771 expr->value.function.esym->ts.u.cl->length
4772 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4773
4774 gfc_apply_interface_mapping_to_expr (mapping,
4775 expr->value.function.esym->ts.u.cl->length);
4776 }
4777 }
4778
4779
4780 /* EXPR is a copy of an expression that appeared in the interface
4781 associated with MAPPING. Walk it recursively looking for references to
4782 dummy arguments that MAPPING maps to actual arguments. Replace each such
4783 reference with a reference to the associated actual argument. */
4784
4785 static void
gfc_apply_interface_mapping_to_expr(gfc_interface_mapping * mapping,gfc_expr * expr)4786 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4787 gfc_expr * expr)
4788 {
4789 gfc_interface_sym_mapping *sym;
4790 gfc_actual_arglist *actual;
4791
4792 if (!expr)
4793 return;
4794
4795 /* Copying an expression does not copy its length, so do that here. */
4796 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4797 {
4798 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4799 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4800 }
4801
4802 /* Apply the mapping to any references. */
4803 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4804
4805 /* ...and to the expression's symbol, if it has one. */
4806 /* TODO Find out why the condition on expr->symtree had to be moved into
4807 the loop rather than being outside it, as originally. */
4808 for (sym = mapping->syms; sym; sym = sym->next)
4809 if (expr->symtree && sym->old == expr->symtree->n.sym)
4810 {
4811 if (sym->new_sym->n.sym->backend_decl)
4812 expr->symtree = sym->new_sym;
4813 else if (sym->expr)
4814 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4815 }
4816
4817 /* ...and to subexpressions in expr->value. */
4818 switch (expr->expr_type)
4819 {
4820 case EXPR_VARIABLE:
4821 case EXPR_CONSTANT:
4822 case EXPR_NULL:
4823 case EXPR_SUBSTRING:
4824 break;
4825
4826 case EXPR_OP:
4827 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4828 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4829 break;
4830
4831 case EXPR_FUNCTION:
4832 for (actual = expr->value.function.actual; actual; actual = actual->next)
4833 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4834
4835 if (expr->value.function.esym == NULL
4836 && expr->value.function.isym != NULL
4837 && expr->value.function.actual
4838 && expr->value.function.actual->expr
4839 && expr->value.function.actual->expr->symtree
4840 && gfc_map_intrinsic_function (expr, mapping))
4841 break;
4842
4843 for (sym = mapping->syms; sym; sym = sym->next)
4844 if (sym->old == expr->value.function.esym)
4845 {
4846 expr->value.function.esym = sym->new_sym->n.sym;
4847 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4848 expr->value.function.esym->result = sym->new_sym->n.sym;
4849 }
4850 break;
4851
4852 case EXPR_ARRAY:
4853 case EXPR_STRUCTURE:
4854 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4855 break;
4856
4857 case EXPR_COMPCALL:
4858 case EXPR_PPC:
4859 case EXPR_UNKNOWN:
4860 gcc_unreachable ();
4861 break;
4862 }
4863
4864 return;
4865 }
4866
4867
4868 /* Evaluate interface expression EXPR using MAPPING. Store the result
4869 in SE. */
4870
4871 void
gfc_apply_interface_mapping(gfc_interface_mapping * mapping,gfc_se * se,gfc_expr * expr)4872 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4873 gfc_se * se, gfc_expr * expr)
4874 {
4875 expr = gfc_copy_expr (expr);
4876 gfc_apply_interface_mapping_to_expr (mapping, expr);
4877 gfc_conv_expr (se, expr);
4878 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4879 gfc_free_expr (expr);
4880 }
4881
4882
4883 /* Returns a reference to a temporary array into which a component of
4884 an actual argument derived type array is copied and then returned
4885 after the function call. */
4886 void
gfc_conv_subref_array_arg(gfc_se * se,gfc_expr * expr,int g77,sym_intent intent,bool formal_ptr,const gfc_symbol * fsym,const char * proc_name,gfc_symbol * sym,bool check_contiguous)4887 gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4888 sym_intent intent, bool formal_ptr,
4889 const gfc_symbol *fsym, const char *proc_name,
4890 gfc_symbol *sym, bool check_contiguous)
4891 {
4892 gfc_se lse;
4893 gfc_se rse;
4894 gfc_ss *lss;
4895 gfc_ss *rss;
4896 gfc_loopinfo loop;
4897 gfc_loopinfo loop2;
4898 gfc_array_info *info;
4899 tree offset;
4900 tree tmp_index;
4901 tree tmp;
4902 tree base_type;
4903 tree size;
4904 stmtblock_t body;
4905 int n;
4906 int dimen;
4907 gfc_se work_se;
4908 gfc_se *parmse;
4909 bool pass_optional;
4910
4911 pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4912
4913 if (pass_optional || check_contiguous)
4914 {
4915 gfc_init_se (&work_se, NULL);
4916 parmse = &work_se;
4917 }
4918 else
4919 parmse = se;
4920
4921 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
4922 {
4923 /* We will create a temporary array, so let us warn. */
4924 char * msg;
4925
4926 if (fsym && proc_name)
4927 msg = xasprintf ("An array temporary was created for argument "
4928 "'%s' of procedure '%s'", fsym->name, proc_name);
4929 else
4930 msg = xasprintf ("An array temporary was created");
4931
4932 tmp = build_int_cst (logical_type_node, 1);
4933 gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4934 &expr->where, msg);
4935 free (msg);
4936 }
4937
4938 gfc_init_se (&lse, NULL);
4939 gfc_init_se (&rse, NULL);
4940
4941 /* Walk the argument expression. */
4942 rss = gfc_walk_expr (expr);
4943
4944 gcc_assert (rss != gfc_ss_terminator);
4945
4946 /* Initialize the scalarizer. */
4947 gfc_init_loopinfo (&loop);
4948 gfc_add_ss_to_loop (&loop, rss);
4949
4950 /* Calculate the bounds of the scalarization. */
4951 gfc_conv_ss_startstride (&loop);
4952
4953 /* Build an ss for the temporary. */
4954 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4955 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4956
4957 base_type = gfc_typenode_for_spec (&expr->ts);
4958 if (GFC_ARRAY_TYPE_P (base_type)
4959 || GFC_DESCRIPTOR_TYPE_P (base_type))
4960 base_type = gfc_get_element_type (base_type);
4961
4962 if (expr->ts.type == BT_CLASS)
4963 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4964
4965 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4966 ? expr->ts.u.cl->backend_decl
4967 : NULL),
4968 loop.dimen);
4969
4970 parmse->string_length = loop.temp_ss->info->string_length;
4971
4972 /* Associate the SS with the loop. */
4973 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4974
4975 /* Setup the scalarizing loops. */
4976 gfc_conv_loop_setup (&loop, &expr->where);
4977
4978 /* Pass the temporary descriptor back to the caller. */
4979 info = &loop.temp_ss->info->data.array;
4980 parmse->expr = info->descriptor;
4981
4982 /* Setup the gfc_se structures. */
4983 gfc_copy_loopinfo_to_se (&lse, &loop);
4984 gfc_copy_loopinfo_to_se (&rse, &loop);
4985
4986 rse.ss = rss;
4987 lse.ss = loop.temp_ss;
4988 gfc_mark_ss_chain_used (rss, 1);
4989 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4990
4991 /* Start the scalarized loop body. */
4992 gfc_start_scalarized_body (&loop, &body);
4993
4994 /* Translate the expression. */
4995 gfc_conv_expr (&rse, expr);
4996
4997 /* Reset the offset for the function call since the loop
4998 is zero based on the data pointer. Note that the temp
4999 comes first in the loop chain since it is added second. */
5000 if (gfc_is_class_array_function (expr))
5001 {
5002 tmp = loop.ss->loop_chain->info->data.array.descriptor;
5003 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
5004 gfc_index_zero_node);
5005 }
5006
5007 gfc_conv_tmp_array_ref (&lse);
5008
5009 if (intent != INTENT_OUT)
5010 {
5011 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5012 gfc_add_expr_to_block (&body, tmp);
5013 gcc_assert (rse.ss == gfc_ss_terminator);
5014 gfc_trans_scalarizing_loops (&loop, &body);
5015 }
5016 else
5017 {
5018 /* Make sure that the temporary declaration survives by merging
5019 all the loop declarations into the current context. */
5020 for (n = 0; n < loop.dimen; n++)
5021 {
5022 gfc_merge_block_scope (&body);
5023 body = loop.code[loop.order[n]];
5024 }
5025 gfc_merge_block_scope (&body);
5026 }
5027
5028 /* Add the post block after the second loop, so that any
5029 freeing of allocated memory is done at the right time. */
5030 gfc_add_block_to_block (&parmse->pre, &loop.pre);
5031
5032 /**********Copy the temporary back again.*********/
5033
5034 gfc_init_se (&lse, NULL);
5035 gfc_init_se (&rse, NULL);
5036
5037 /* Walk the argument expression. */
5038 lss = gfc_walk_expr (expr);
5039 rse.ss = loop.temp_ss;
5040 lse.ss = lss;
5041
5042 /* Initialize the scalarizer. */
5043 gfc_init_loopinfo (&loop2);
5044 gfc_add_ss_to_loop (&loop2, lss);
5045
5046 dimen = rse.ss->dimen;
5047
5048 /* Skip the write-out loop for this case. */
5049 if (gfc_is_class_array_function (expr))
5050 goto class_array_fcn;
5051
5052 /* Calculate the bounds of the scalarization. */
5053 gfc_conv_ss_startstride (&loop2);
5054
5055 /* Setup the scalarizing loops. */
5056 gfc_conv_loop_setup (&loop2, &expr->where);
5057
5058 gfc_copy_loopinfo_to_se (&lse, &loop2);
5059 gfc_copy_loopinfo_to_se (&rse, &loop2);
5060
5061 gfc_mark_ss_chain_used (lss, 1);
5062 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5063
5064 /* Declare the variable to hold the temporary offset and start the
5065 scalarized loop body. */
5066 offset = gfc_create_var (gfc_array_index_type, NULL);
5067 gfc_start_scalarized_body (&loop2, &body);
5068
5069 /* Build the offsets for the temporary from the loop variables. The
5070 temporary array has lbounds of zero and strides of one in all
5071 dimensions, so this is very simple. The offset is only computed
5072 outside the innermost loop, so the overall transfer could be
5073 optimized further. */
5074 info = &rse.ss->info->data.array;
5075
5076 tmp_index = gfc_index_zero_node;
5077 for (n = dimen - 1; n > 0; n--)
5078 {
5079 tree tmp_str;
5080 tmp = rse.loop->loopvar[n];
5081 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5082 tmp, rse.loop->from[n]);
5083 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5084 tmp, tmp_index);
5085
5086 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5087 gfc_array_index_type,
5088 rse.loop->to[n-1], rse.loop->from[n-1]);
5089 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5090 gfc_array_index_type,
5091 tmp_str, gfc_index_one_node);
5092
5093 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5094 gfc_array_index_type, tmp, tmp_str);
5095 }
5096
5097 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5098 gfc_array_index_type,
5099 tmp_index, rse.loop->from[0]);
5100 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5101
5102 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5103 gfc_array_index_type,
5104 rse.loop->loopvar[0], offset);
5105
5106 /* Now use the offset for the reference. */
5107 tmp = build_fold_indirect_ref_loc (input_location,
5108 info->data);
5109 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5110
5111 if (expr->ts.type == BT_CHARACTER)
5112 rse.string_length = expr->ts.u.cl->backend_decl;
5113
5114 gfc_conv_expr (&lse, expr);
5115
5116 gcc_assert (lse.ss == gfc_ss_terminator);
5117
5118 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5119 gfc_add_expr_to_block (&body, tmp);
5120
5121 /* Generate the copying loops. */
5122 gfc_trans_scalarizing_loops (&loop2, &body);
5123
5124 /* Wrap the whole thing up by adding the second loop to the post-block
5125 and following it by the post-block of the first loop. In this way,
5126 if the temporary needs freeing, it is done after use! */
5127 if (intent != INTENT_IN)
5128 {
5129 gfc_add_block_to_block (&parmse->post, &loop2.pre);
5130 gfc_add_block_to_block (&parmse->post, &loop2.post);
5131 }
5132
5133 class_array_fcn:
5134
5135 gfc_add_block_to_block (&parmse->post, &loop.post);
5136
5137 gfc_cleanup_loop (&loop);
5138 gfc_cleanup_loop (&loop2);
5139
5140 /* Pass the string length to the argument expression. */
5141 if (expr->ts.type == BT_CHARACTER)
5142 parmse->string_length = expr->ts.u.cl->backend_decl;
5143
5144 /* Determine the offset for pointer formal arguments and set the
5145 lbounds to one. */
5146 if (formal_ptr)
5147 {
5148 size = gfc_index_one_node;
5149 offset = gfc_index_zero_node;
5150 for (n = 0; n < dimen; n++)
5151 {
5152 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5153 gfc_rank_cst[n]);
5154 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5155 gfc_array_index_type, tmp,
5156 gfc_index_one_node);
5157 gfc_conv_descriptor_ubound_set (&parmse->pre,
5158 parmse->expr,
5159 gfc_rank_cst[n],
5160 tmp);
5161 gfc_conv_descriptor_lbound_set (&parmse->pre,
5162 parmse->expr,
5163 gfc_rank_cst[n],
5164 gfc_index_one_node);
5165 size = gfc_evaluate_now (size, &parmse->pre);
5166 offset = fold_build2_loc (input_location, MINUS_EXPR,
5167 gfc_array_index_type,
5168 offset, size);
5169 offset = gfc_evaluate_now (offset, &parmse->pre);
5170 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5171 gfc_array_index_type,
5172 rse.loop->to[n], rse.loop->from[n]);
5173 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5174 gfc_array_index_type,
5175 tmp, gfc_index_one_node);
5176 size = fold_build2_loc (input_location, MULT_EXPR,
5177 gfc_array_index_type, size, tmp);
5178 }
5179
5180 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5181 offset);
5182 }
5183
5184 /* We want either the address for the data or the address of the descriptor,
5185 depending on the mode of passing array arguments. */
5186 if (g77)
5187 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5188 else
5189 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5190
5191 /* Basically make this into
5192
5193 if (present)
5194 {
5195 if (contiguous)
5196 {
5197 pointer = a;
5198 }
5199 else
5200 {
5201 parmse->pre();
5202 pointer = parmse->expr;
5203 }
5204 }
5205 else
5206 pointer = NULL;
5207
5208 foo (pointer);
5209 if (present && !contiguous)
5210 se->post();
5211
5212 */
5213
5214 if (pass_optional || check_contiguous)
5215 {
5216 tree type;
5217 stmtblock_t else_block;
5218 tree pre_stmts, post_stmts;
5219 tree pointer;
5220 tree else_stmt;
5221 tree present_var = NULL_TREE;
5222 tree cont_var = NULL_TREE;
5223 tree post_cond;
5224
5225 type = TREE_TYPE (parmse->expr);
5226 if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5227 type = TREE_TYPE (type);
5228 pointer = gfc_create_var (type, "arg_ptr");
5229
5230 if (check_contiguous)
5231 {
5232 gfc_se cont_se, array_se;
5233 stmtblock_t if_block, else_block;
5234 tree if_stmt, else_stmt;
5235 mpz_t size;
5236 bool size_set;
5237
5238 cont_var = gfc_create_var (boolean_type_node, "contiguous");
5239
5240 /* If the size is known to be one at compile-time, set
5241 cont_var to true unconditionally. This may look
5242 inelegant, but we're only doing this during
5243 optimization, so the statements will be optimized away,
5244 and this saves complexity here. */
5245
5246 size_set = gfc_array_size (expr, &size);
5247 if (size_set && mpz_cmp_ui (size, 1) == 0)
5248 {
5249 gfc_add_modify (&se->pre, cont_var,
5250 build_one_cst (boolean_type_node));
5251 }
5252 else
5253 {
5254 /* cont_var = is_contiguous (expr); . */
5255 gfc_init_se (&cont_se, parmse);
5256 gfc_conv_is_contiguous_expr (&cont_se, expr);
5257 gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5258 gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5259 gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5260 }
5261
5262 if (size_set)
5263 mpz_clear (size);
5264
5265 /* arrayse->expr = descriptor of a. */
5266 gfc_init_se (&array_se, se);
5267 gfc_conv_expr_descriptor (&array_se, expr);
5268 gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5269 gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5270
5271 /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5272 gfc_init_block (&if_block);
5273 if (GFC_DESCRIPTOR_TYPE_P (type))
5274 gfc_add_modify (&if_block, pointer, array_se.expr);
5275 else
5276 {
5277 tmp = gfc_conv_array_data (array_se.expr);
5278 tmp = fold_convert (type, tmp);
5279 gfc_add_modify (&if_block, pointer, tmp);
5280 }
5281 if_stmt = gfc_finish_block (&if_block);
5282
5283 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5284 gfc_init_block (&else_block);
5285 gfc_add_block_to_block (&else_block, &parmse->pre);
5286 tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5287 ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5288 : parmse->expr);
5289 gfc_add_modify (&else_block, pointer, tmp);
5290 else_stmt = gfc_finish_block (&else_block);
5291
5292 /* And put the above into an if statement. */
5293 pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5294 gfc_likely (cont_var,
5295 PRED_FORTRAN_CONTIGUOUS),
5296 if_stmt, else_stmt);
5297 }
5298 else
5299 {
5300 /* pointer = pramse->expr; . */
5301 gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5302 pre_stmts = gfc_finish_block (&parmse->pre);
5303 }
5304
5305 if (pass_optional)
5306 {
5307 present_var = gfc_create_var (boolean_type_node, "present");
5308
5309 /* present_var = present(sym); . */
5310 tmp = gfc_conv_expr_present (sym);
5311 tmp = fold_convert (boolean_type_node, tmp);
5312 gfc_add_modify (&se->pre, present_var, tmp);
5313
5314 /* else_stmt = { pointer = NULL; } . */
5315 gfc_init_block (&else_block);
5316 if (GFC_DESCRIPTOR_TYPE_P (type))
5317 gfc_conv_descriptor_data_set (&else_block, pointer,
5318 null_pointer_node);
5319 else
5320 gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5321 else_stmt = gfc_finish_block (&else_block);
5322
5323 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5324 gfc_likely (present_var,
5325 PRED_FORTRAN_ABSENT_DUMMY),
5326 pre_stmts, else_stmt);
5327 gfc_add_expr_to_block (&se->pre, tmp);
5328 }
5329 else
5330 gfc_add_expr_to_block (&se->pre, pre_stmts);
5331
5332 post_stmts = gfc_finish_block (&parmse->post);
5333
5334 /* Put together the post stuff, plus the optional
5335 deallocation. */
5336 if (check_contiguous)
5337 {
5338 /* !cont_var. */
5339 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5340 cont_var,
5341 build_zero_cst (boolean_type_node));
5342 tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5343
5344 if (pass_optional)
5345 {
5346 tree present_likely = gfc_likely (present_var,
5347 PRED_FORTRAN_ABSENT_DUMMY);
5348 post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5349 boolean_type_node, present_likely,
5350 tmp);
5351 }
5352 else
5353 post_cond = tmp;
5354 }
5355 else
5356 {
5357 gcc_assert (pass_optional);
5358 post_cond = present_var;
5359 }
5360
5361 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5362 post_stmts, build_empty_stmt (input_location));
5363 gfc_add_expr_to_block (&se->post, tmp);
5364 if (GFC_DESCRIPTOR_TYPE_P (type))
5365 {
5366 type = TREE_TYPE (parmse->expr);
5367 if (POINTER_TYPE_P (type))
5368 {
5369 pointer = gfc_build_addr_expr (type, pointer);
5370 if (pass_optional)
5371 {
5372 tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5373 pointer = fold_build3_loc (input_location, COND_EXPR, type,
5374 tmp, pointer,
5375 fold_convert (type,
5376 null_pointer_node));
5377 }
5378 }
5379 else
5380 gcc_assert (!pass_optional);
5381 }
5382 se->expr = pointer;
5383 }
5384
5385 return;
5386 }
5387
5388
5389 /* Generate the code for argument list functions. */
5390
5391 static void
conv_arglist_function(gfc_se * se,gfc_expr * expr,const char * name)5392 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5393 {
5394 /* Pass by value for g77 %VAL(arg), pass the address
5395 indirectly for %LOC, else by reference. Thus %REF
5396 is a "do-nothing" and %LOC is the same as an F95
5397 pointer. */
5398 if (strcmp (name, "%VAL") == 0)
5399 gfc_conv_expr (se, expr);
5400 else if (strcmp (name, "%LOC") == 0)
5401 {
5402 gfc_conv_expr_reference (se, expr);
5403 se->expr = gfc_build_addr_expr (NULL, se->expr);
5404 }
5405 else if (strcmp (name, "%REF") == 0)
5406 gfc_conv_expr_reference (se, expr);
5407 else
5408 gfc_error ("Unknown argument list function at %L", &expr->where);
5409 }
5410
5411
5412 /* This function tells whether the middle-end representation of the expression
5413 E given as input may point to data otherwise accessible through a variable
5414 (sub-)reference.
5415 It is assumed that the only expressions that may alias are variables,
5416 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5417 may alias.
5418 This function is used to decide whether freeing an expression's allocatable
5419 components is safe or should be avoided.
5420
5421 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5422 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5423 is necessary because for array constructors, aliasing depends on how
5424 the array is used:
5425 - If E is an array constructor used as argument to an elemental procedure,
5426 the array, which is generated through shallow copy by the scalarizer,
5427 is used directly and can alias the expressions it was copied from.
5428 - If E is an array constructor used as argument to a non-elemental
5429 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5430 the array as in the previous case, but then that array is used
5431 to initialize a new descriptor through deep copy. There is no alias
5432 possible in that case.
5433 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5434 above. */
5435
5436 static bool
expr_may_alias_variables(gfc_expr * e,bool array_may_alias)5437 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5438 {
5439 gfc_constructor *c;
5440
5441 if (e->expr_type == EXPR_VARIABLE)
5442 return true;
5443 else if (e->expr_type == EXPR_FUNCTION)
5444 {
5445 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5446
5447 if (proc_ifc->result != NULL
5448 && ((proc_ifc->result->ts.type == BT_CLASS
5449 && proc_ifc->result->ts.u.derived->attr.is_class
5450 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5451 || proc_ifc->result->attr.pointer))
5452 return true;
5453 else
5454 return false;
5455 }
5456 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5457 return false;
5458
5459 for (c = gfc_constructor_first (e->value.constructor);
5460 c; c = gfc_constructor_next (c))
5461 if (c->expr
5462 && expr_may_alias_variables (c->expr, array_may_alias))
5463 return true;
5464
5465 return false;
5466 }
5467
5468
5469 /* A helper function to set the dtype for unallocated or unassociated
5470 entities. */
5471
5472 static void
set_dtype_for_unallocated(gfc_se * parmse,gfc_expr * e)5473 set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5474 {
5475 tree tmp;
5476 tree desc;
5477 tree cond;
5478 tree type;
5479 stmtblock_t block;
5480
5481 /* TODO Figure out how to handle optional dummies. */
5482 if (e && e->expr_type == EXPR_VARIABLE
5483 && e->symtree->n.sym->attr.optional)
5484 return;
5485
5486 desc = parmse->expr;
5487 if (desc == NULL_TREE)
5488 return;
5489
5490 if (POINTER_TYPE_P (TREE_TYPE (desc)))
5491 desc = build_fold_indirect_ref_loc (input_location, desc);
5492 if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
5493 desc = gfc_class_data_get (desc);
5494 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5495 return;
5496
5497 gfc_init_block (&block);
5498 tmp = gfc_conv_descriptor_data_get (desc);
5499 cond = fold_build2_loc (input_location, EQ_EXPR,
5500 logical_type_node, tmp,
5501 build_int_cst (TREE_TYPE (tmp), 0));
5502 tmp = gfc_conv_descriptor_dtype (desc);
5503 type = gfc_get_element_type (TREE_TYPE (desc));
5504 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5505 TREE_TYPE (tmp), tmp,
5506 gfc_get_dtype_rank_type (e->rank, type));
5507 gfc_add_expr_to_block (&block, tmp);
5508 cond = build3_v (COND_EXPR, cond,
5509 gfc_finish_block (&block),
5510 build_empty_stmt (input_location));
5511 gfc_add_expr_to_block (&parmse->pre, cond);
5512 }
5513
5514
5515
5516 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5517 ISO_Fortran_binding array descriptors. */
5518
5519 static void
gfc_conv_gfc_desc_to_cfi_desc(gfc_se * parmse,gfc_expr * e,gfc_symbol * fsym)5520 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5521 {
5522 stmtblock_t block, block2;
5523 tree cfi, gfc, tmp, tmp2;
5524 tree present = NULL;
5525 tree gfc_strlen = NULL;
5526 tree rank;
5527 gfc_se se;
5528
5529 if (fsym->attr.optional
5530 && e->expr_type == EXPR_VARIABLE
5531 && e->symtree->n.sym->attr.optional)
5532 present = gfc_conv_expr_present (e->symtree->n.sym);
5533
5534 gfc_init_block (&block);
5535
5536 /* Convert original argument to a tree. */
5537 gfc_init_se (&se, NULL);
5538 if (e->rank == 0)
5539 {
5540 se.want_pointer = 1;
5541 gfc_conv_expr (&se, e);
5542 gfc = se.expr;
5543 /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5544 if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
5545 gfc = gfc_build_addr_expr (NULL, gfc);
5546 }
5547 else
5548 {
5549 /* If the actual argument can be noncontiguous, copy-in/out is required,
5550 if the dummy has either the CONTIGUOUS attribute or is an assumed-
5551 length assumed-length/assumed-size CHARACTER array. */
5552 se.force_no_tmp = 1;
5553 if ((fsym->attr.contiguous
5554 || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
5555 && (fsym->as->type == AS_ASSUMED_SIZE
5556 || fsym->as->type == AS_EXPLICIT)))
5557 && !gfc_is_simply_contiguous (e, false, true))
5558 {
5559 bool optional = fsym->attr.optional;
5560 fsym->attr.optional = 0;
5561 gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
5562 fsym->attr.pointer, fsym,
5563 fsym->ns->proc_name->name, NULL,
5564 /* check_contiguous= */ true);
5565 fsym->attr.optional = optional;
5566 }
5567 else
5568 gfc_conv_expr_descriptor (&se, e);
5569 gfc = se.expr;
5570 /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5571 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5572 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5573 While sm is fine as it uses span*stride and not elem_len. */
5574 if (POINTER_TYPE_P (TREE_TYPE (gfc)))
5575 gfc = build_fold_indirect_ref_loc (input_location, gfc);
5576 else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
5577 gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
5578 }
5579 if (e->ts.type == BT_CHARACTER)
5580 {
5581 if (se.string_length)
5582 gfc_strlen = se.string_length;
5583 else if (e->ts.u.cl->backend_decl)
5584 gfc_strlen = e->ts.u.cl->backend_decl;
5585 else
5586 gcc_unreachable ();
5587 }
5588 gfc_add_block_to_block (&block, &se.pre);
5589
5590 /* Create array decriptor and set version, rank, attribute, type. */
5591 cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
5592 ? GFC_MAX_DIMENSIONS : e->rank,
5593 false), "cfi");
5594 /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5595 if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
5596 {
5597 tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
5598 tmp = build_pointer_type (tmp);
5599 parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
5600 cfi = build_fold_indirect_ref_loc (input_location, cfi);
5601 }
5602 else
5603 parmse->expr = gfc_build_addr_expr (NULL, cfi);
5604
5605 tmp = gfc_get_cfi_desc_version (cfi);
5606 gfc_add_modify (&block, tmp,
5607 build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
5608 if (e->rank < 0)
5609 rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
5610 else
5611 rank = build_int_cst (signed_char_type_node, e->rank);
5612 tmp = gfc_get_cfi_desc_rank (cfi);
5613 gfc_add_modify (&block, tmp, rank);
5614 int itype = CFI_type_other;
5615 if (e->ts.f90_type == BT_VOID)
5616 itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5617 ? CFI_type_cfunptr : CFI_type_cptr);
5618 else
5619 switch (e->ts.type)
5620 {
5621 case BT_INTEGER:
5622 case BT_LOGICAL:
5623 case BT_REAL:
5624 case BT_COMPLEX:
5625 itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
5626 break;
5627 case BT_CHARACTER:
5628 itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
5629 break;
5630 case BT_DERIVED:
5631 itype = CFI_type_struct;
5632 break;
5633 case BT_VOID:
5634 itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5635 ? CFI_type_cfunptr : CFI_type_cptr);
5636 break;
5637 case BT_ASSUMED:
5638 itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5639 break;
5640 case BT_CLASS:
5641 case BT_PROCEDURE:
5642 case BT_HOLLERITH:
5643 case BT_UNION:
5644 case BT_BOZ:
5645 case BT_UNKNOWN:
5646 // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5647 gcc_unreachable ();
5648 }
5649
5650 tmp = gfc_get_cfi_desc_type (cfi);
5651 gfc_add_modify (&block, tmp,
5652 build_int_cst (TREE_TYPE (tmp), itype));
5653
5654 int attr = CFI_attribute_other;
5655 if (fsym->attr.pointer)
5656 attr = CFI_attribute_pointer;
5657 else if (fsym->attr.allocatable)
5658 attr = CFI_attribute_allocatable;
5659 tmp = gfc_get_cfi_desc_attribute (cfi);
5660 gfc_add_modify (&block, tmp,
5661 build_int_cst (TREE_TYPE (tmp), attr));
5662
5663 if (e->rank == 0)
5664 {
5665 tmp = gfc_get_cfi_desc_base_addr (cfi);
5666 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
5667 }
5668 else
5669 {
5670 tmp = gfc_get_cfi_desc_base_addr (cfi);
5671 tmp2 = gfc_conv_descriptor_data_get (gfc);
5672 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
5673 }
5674
5675 /* Set elem_len if known - must be before the next if block.
5676 Note that allocatable implies 'len=:'. */
5677 if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
5678 {
5679 /* Length is known at compile time; use use 'block' for it. */
5680 tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
5681 tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5682 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5683 }
5684
5685 /* When allocatable + intent out, free the cfi descriptor. */
5686 if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
5687 {
5688 tmp = gfc_get_cfi_desc_base_addr (cfi);
5689 tree call = builtin_decl_explicit (BUILT_IN_FREE);
5690 call = build_call_expr_loc (input_location, call, 1, tmp);
5691 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
5692 gfc_add_modify (&block, tmp,
5693 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5694 goto done;
5695 }
5696
5697 /* If not unallocated/unassociated. */
5698 gfc_init_block (&block2);
5699
5700 /* Set elem_len, which may be only known at run time. */
5701 if (e->ts.type == BT_CHARACTER)
5702 {
5703 gcc_assert (gfc_strlen);
5704 tmp = gfc_strlen;
5705 if (e->ts.kind != 1)
5706 tmp = fold_build2_loc (input_location, MULT_EXPR,
5707 gfc_charlen_type_node, tmp,
5708 build_int_cst (gfc_charlen_type_node,
5709 e->ts.kind));
5710 tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5711 gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5712 }
5713 else if (e->ts.type == BT_ASSUMED)
5714 {
5715 tmp = gfc_conv_descriptor_elem_len (gfc);
5716 tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5717 gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5718 }
5719
5720 if (e->ts.type == BT_ASSUMED)
5721 {
5722 /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
5723 an CFI descriptor. Use the type in the descritor as it provide
5724 mode information. (Quality of implementation feature.) */
5725 tree cond;
5726 tree ctype = gfc_get_cfi_desc_type (cfi);
5727 tree type = fold_convert (TREE_TYPE (ctype),
5728 gfc_conv_descriptor_type (gfc));
5729 tree kind = fold_convert (TREE_TYPE (ctype),
5730 gfc_conv_descriptor_elem_len (gfc));
5731 kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
5732 kind, build_int_cst (TREE_TYPE (type),
5733 CFI_type_kind_shift));
5734
5735 /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
5736 /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
5737 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5738 build_int_cst (TREE_TYPE (type), BT_VOID));
5739 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5740 build_int_cst (TREE_TYPE (type), CFI_type_cptr));
5741 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5742 ctype,
5743 build_int_cst (TREE_TYPE (type), CFI_type_other));
5744 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5745 tmp, tmp2);
5746 /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
5747 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5748 build_int_cst (TREE_TYPE (type), BT_DERIVED));
5749 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5750 build_int_cst (TREE_TYPE (type), CFI_type_struct));
5751 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5752 tmp, tmp2);
5753 /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
5754 /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
5755 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5756 build_int_cst (TREE_TYPE (type), BT_CHARACTER));
5757 tmp = build_int_cst (TREE_TYPE (type),
5758 CFI_type_from_type_kind (CFI_type_Character, 1));
5759 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5760 ctype, tmp);
5761 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5762 tmp, tmp2);
5763 /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
5764 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5765 build_int_cst (TREE_TYPE (type), BT_COMPLEX));
5766 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
5767 kind, build_int_cst (TREE_TYPE (type), 2));
5768 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
5769 build_int_cst (TREE_TYPE (type),
5770 CFI_type_Complex));
5771 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5772 ctype, tmp);
5773 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5774 tmp, tmp2);
5775 /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
5776 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5777 build_int_cst (TREE_TYPE (type), BT_INTEGER));
5778 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5779 build_int_cst (TREE_TYPE (type), BT_LOGICAL));
5780 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5781 cond, tmp);
5782 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5783 build_int_cst (TREE_TYPE (type), BT_REAL));
5784 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5785 cond, tmp);
5786 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
5787 type, kind);
5788 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5789 ctype, tmp);
5790 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5791 tmp, tmp2);
5792 gfc_add_expr_to_block (&block2, tmp2);
5793 }
5794
5795 if (e->rank != 0)
5796 {
5797 /* Loop: for (i = 0; i < rank; ++i). */
5798 tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5799 /* Loop body. */
5800 stmtblock_t loop_body;
5801 gfc_init_block (&loop_body);
5802 /* cfi->dim[i].lower_bound = (allocatable/pointer)
5803 ? gfc->dim[i].lbound : 0 */
5804 if (fsym->attr.pointer || fsym->attr.allocatable)
5805 tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
5806 else
5807 tmp = gfc_index_zero_node;
5808 gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
5809 /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
5810 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5811 gfc_conv_descriptor_ubound_get (gfc, idx),
5812 gfc_conv_descriptor_lbound_get (gfc, idx));
5813 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5814 tmp, gfc_index_one_node);
5815 gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
5816 /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
5817 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5818 gfc_conv_descriptor_stride_get (gfc, idx),
5819 gfc_conv_descriptor_span_get (gfc));
5820 gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
5821
5822 /* Generate loop. */
5823 gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
5824 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
5825 gfc_finish_block (&loop_body));
5826
5827 if (e->expr_type == EXPR_VARIABLE
5828 && e->ref
5829 && e->ref->u.ar.type == AR_FULL
5830 && e->symtree->n.sym->attr.dummy
5831 && e->symtree->n.sym->as
5832 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
5833 {
5834 tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
5835 gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
5836 }
5837 }
5838
5839 if (fsym->attr.allocatable || fsym->attr.pointer)
5840 {
5841 tmp = gfc_get_cfi_desc_base_addr (cfi),
5842 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5843 tmp, null_pointer_node);
5844 tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
5845 build_empty_stmt (input_location));
5846 gfc_add_expr_to_block (&block, tmp);
5847 }
5848 else
5849 gfc_add_block_to_block (&block, &block2);
5850
5851
5852 done:
5853 if (present)
5854 {
5855 parmse->expr = build3_loc (input_location, COND_EXPR,
5856 TREE_TYPE (parmse->expr),
5857 present, parmse->expr, null_pointer_node);
5858 tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
5859 build_empty_stmt (input_location));
5860 gfc_add_expr_to_block (&parmse->pre, tmp);
5861 }
5862 else
5863 gfc_add_block_to_block (&parmse->pre, &block);
5864
5865 gfc_init_block (&block);
5866
5867 if ((!fsym->attr.allocatable && !fsym->attr.pointer)
5868 || fsym->attr.intent == INTENT_IN)
5869 goto post_call;
5870
5871 gfc_init_block (&block2);
5872 if (e->rank == 0)
5873 {
5874 tmp = gfc_get_cfi_desc_base_addr (cfi);
5875 gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
5876 }
5877 else
5878 {
5879 tmp = gfc_get_cfi_desc_base_addr (cfi);
5880 gfc_conv_descriptor_data_set (&block, gfc, tmp);
5881
5882 if (fsym->attr.allocatable)
5883 {
5884 /* gfc->span = cfi->elem_len. */
5885 tmp = fold_convert (gfc_array_index_type,
5886 gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
5887 }
5888 else
5889 {
5890 /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
5891 ? cfi->dim[0].sm : cfi->elem_len). */
5892 tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
5893 tmp2 = fold_convert (gfc_array_index_type,
5894 gfc_get_cfi_desc_elem_len (cfi));
5895 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
5896 gfc_array_index_type, tmp, tmp2);
5897 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5898 tmp, gfc_index_zero_node);
5899 tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
5900 gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
5901 }
5902 gfc_conv_descriptor_span_set (&block2, gfc, tmp);
5903
5904 /* Calculate offset + set lbound, ubound and stride. */
5905 gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
5906 /* Loop: for (i = 0; i < rank; ++i). */
5907 tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5908 /* Loop body. */
5909 stmtblock_t loop_body;
5910 gfc_init_block (&loop_body);
5911 /* gfc->dim[i].lbound = ... */
5912 tmp = gfc_get_cfi_dim_lbound (cfi, idx);
5913 gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
5914
5915 /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
5916 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5917 gfc_conv_descriptor_lbound_get (gfc, idx),
5918 gfc_index_one_node);
5919 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5920 gfc_get_cfi_dim_extent (cfi, idx), tmp);
5921 gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
5922
5923 /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
5924 tmp = gfc_get_cfi_dim_sm (cfi, idx);
5925 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5926 gfc_array_index_type, tmp,
5927 fold_convert (gfc_array_index_type,
5928 gfc_get_cfi_desc_elem_len (cfi)));
5929 gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
5930
5931 /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
5932 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5933 gfc_conv_descriptor_stride_get (gfc, idx),
5934 gfc_conv_descriptor_lbound_get (gfc, idx));
5935 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5936 gfc_conv_descriptor_offset_get (gfc), tmp);
5937 gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
5938 /* Generate loop. */
5939 gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
5940 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
5941 gfc_finish_block (&loop_body));
5942 }
5943
5944 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
5945 {
5946 tmp = fold_convert (gfc_charlen_type_node,
5947 gfc_get_cfi_desc_elem_len (cfi));
5948 if (e->ts.kind != 1)
5949 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5950 gfc_charlen_type_node, tmp,
5951 build_int_cst (gfc_charlen_type_node,
5952 e->ts.kind));
5953 gfc_add_modify (&block2, gfc_strlen, tmp);
5954 }
5955
5956 tmp = gfc_get_cfi_desc_base_addr (cfi),
5957 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5958 tmp, null_pointer_node);
5959 tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
5960 build_empty_stmt (input_location));
5961 gfc_add_expr_to_block (&block, tmp);
5962
5963 post_call:
5964 gfc_add_block_to_block (&block, &se.post);
5965 if (present && block.head)
5966 {
5967 tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
5968 build_empty_stmt (input_location));
5969 gfc_add_expr_to_block (&parmse->post, tmp);
5970 }
5971 else if (block.head)
5972 gfc_add_block_to_block (&parmse->post, &block);
5973 }
5974
5975
5976 /* Generate code for a procedure call. Note can return se->post != NULL.
5977 If se->direct_byref is set then se->expr contains the return parameter.
5978 Return nonzero, if the call has alternate specifiers.
5979 'expr' is only needed for procedure pointer components. */
5980
5981 int
gfc_conv_procedure_call(gfc_se * se,gfc_symbol * sym,gfc_actual_arglist * args,gfc_expr * expr,vec<tree,va_gc> * append_args)5982 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5983 gfc_actual_arglist * args, gfc_expr * expr,
5984 vec<tree, va_gc> *append_args)
5985 {
5986 gfc_interface_mapping mapping;
5987 vec<tree, va_gc> *arglist;
5988 vec<tree, va_gc> *retargs;
5989 tree tmp;
5990 tree fntype;
5991 gfc_se parmse;
5992 gfc_array_info *info;
5993 int byref;
5994 int parm_kind;
5995 tree type;
5996 tree var;
5997 tree len;
5998 tree base_object;
5999 vec<tree, va_gc> *stringargs;
6000 vec<tree, va_gc> *optionalargs;
6001 tree result = NULL;
6002 gfc_formal_arglist *formal;
6003 gfc_actual_arglist *arg;
6004 int has_alternate_specifier = 0;
6005 bool need_interface_mapping;
6006 bool callee_alloc;
6007 bool ulim_copy;
6008 gfc_typespec ts;
6009 gfc_charlen cl;
6010 gfc_expr *e;
6011 gfc_symbol *fsym;
6012 stmtblock_t post;
6013 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6014 gfc_component *comp = NULL;
6015 int arglen;
6016 unsigned int argc;
6017
6018 arglist = NULL;
6019 retargs = NULL;
6020 stringargs = NULL;
6021 optionalargs = NULL;
6022 var = NULL_TREE;
6023 len = NULL_TREE;
6024 gfc_clear_ts (&ts);
6025
6026 comp = gfc_get_proc_ptr_comp (expr);
6027
6028 bool elemental_proc = (comp
6029 && comp->ts.interface
6030 && comp->ts.interface->attr.elemental)
6031 || (comp && comp->attr.elemental)
6032 || sym->attr.elemental;
6033
6034 if (se->ss != NULL)
6035 {
6036 if (!elemental_proc)
6037 {
6038 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6039 if (se->ss->info->useflags)
6040 {
6041 gcc_assert ((!comp && gfc_return_by_reference (sym)
6042 && sym->result->attr.dimension)
6043 || (comp && comp->attr.dimension)
6044 || gfc_is_class_array_function (expr));
6045 gcc_assert (se->loop != NULL);
6046 /* Access the previously obtained result. */
6047 gfc_conv_tmp_array_ref (se);
6048 return 0;
6049 }
6050 }
6051 info = &se->ss->info->data.array;
6052 }
6053 else
6054 info = NULL;
6055
6056 gfc_init_block (&post);
6057 gfc_init_interface_mapping (&mapping);
6058 if (!comp)
6059 {
6060 formal = gfc_sym_get_dummy_args (sym);
6061 need_interface_mapping = sym->attr.dimension ||
6062 (sym->ts.type == BT_CHARACTER
6063 && sym->ts.u.cl->length
6064 && sym->ts.u.cl->length->expr_type
6065 != EXPR_CONSTANT);
6066 }
6067 else
6068 {
6069 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
6070 need_interface_mapping = comp->attr.dimension ||
6071 (comp->ts.type == BT_CHARACTER
6072 && comp->ts.u.cl->length
6073 && comp->ts.u.cl->length->expr_type
6074 != EXPR_CONSTANT);
6075 }
6076
6077 base_object = NULL_TREE;
6078 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6079 is the third and fourth argument to such a function call a value
6080 denoting the number of elements to copy (i.e., most of the time the
6081 length of a deferred length string). */
6082 ulim_copy = (formal == NULL)
6083 && UNLIMITED_POLY (sym)
6084 && comp && (strcmp ("_copy", comp->name) == 0);
6085
6086 /* Evaluate the arguments. */
6087 for (arg = args, argc = 0; arg != NULL;
6088 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
6089 {
6090 bool finalized = false;
6091 tree derived_array = NULL_TREE;
6092
6093 e = arg->expr;
6094 fsym = formal ? formal->sym : NULL;
6095 parm_kind = MISSING;
6096
6097 /* If the procedure requires an explicit interface, the actual
6098 argument is passed according to the corresponding formal
6099 argument. If the corresponding formal argument is a POINTER,
6100 ALLOCATABLE or assumed shape, we do not use g77's calling
6101 convention, and pass the address of the array descriptor
6102 instead. Otherwise we use g77's calling convention, in other words
6103 pass the array data pointer without descriptor. */
6104 bool nodesc_arg = fsym != NULL
6105 && !(fsym->attr.pointer || fsym->attr.allocatable)
6106 && fsym->as
6107 && fsym->as->type != AS_ASSUMED_SHAPE
6108 && fsym->as->type != AS_ASSUMED_RANK;
6109 if (comp)
6110 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
6111 else
6112 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
6113
6114 /* Class array expressions are sometimes coming completely unadorned
6115 with either arrayspec or _data component. Correct that here.
6116 OOP-TODO: Move this to the frontend. */
6117 if (e && e->expr_type == EXPR_VARIABLE
6118 && !e->ref
6119 && e->ts.type == BT_CLASS
6120 && (CLASS_DATA (e)->attr.codimension
6121 || CLASS_DATA (e)->attr.dimension))
6122 {
6123 gfc_typespec temp_ts = e->ts;
6124 gfc_add_class_array_ref (e);
6125 e->ts = temp_ts;
6126 }
6127
6128 if (e == NULL)
6129 {
6130 if (se->ignore_optional)
6131 {
6132 /* Some intrinsics have already been resolved to the correct
6133 parameters. */
6134 continue;
6135 }
6136 else if (arg->label)
6137 {
6138 has_alternate_specifier = 1;
6139 continue;
6140 }
6141 else
6142 {
6143 gfc_init_se (&parmse, NULL);
6144
6145 /* For scalar arguments with VALUE attribute which are passed by
6146 value, pass "0" and a hidden argument gives the optional
6147 status. */
6148 if (fsym && fsym->attr.optional && fsym->attr.value
6149 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
6150 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
6151 {
6152 parmse.expr = fold_convert (gfc_sym_type (fsym),
6153 integer_zero_node);
6154 vec_safe_push (optionalargs, boolean_false_node);
6155 }
6156 else
6157 {
6158 /* Pass a NULL pointer for an absent arg. */
6159 parmse.expr = null_pointer_node;
6160 gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
6161 if (dummy_arg
6162 && gfc_dummy_arg_get_typespec (*dummy_arg).type
6163 == BT_CHARACTER)
6164 parmse.string_length = build_int_cst (gfc_charlen_type_node,
6165 0);
6166 }
6167 }
6168 }
6169 else if (arg->expr->expr_type == EXPR_NULL
6170 && fsym && !fsym->attr.pointer
6171 && (fsym->ts.type != BT_CLASS
6172 || !CLASS_DATA (fsym)->attr.class_pointer))
6173 {
6174 /* Pass a NULL pointer to denote an absent arg. */
6175 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
6176 && (fsym->ts.type != BT_CLASS
6177 || !CLASS_DATA (fsym)->attr.allocatable));
6178 gfc_init_se (&parmse, NULL);
6179 parmse.expr = null_pointer_node;
6180 if (arg->associated_dummy
6181 && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
6182 == BT_CHARACTER)
6183 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
6184 }
6185 else if (fsym && fsym->ts.type == BT_CLASS
6186 && e->ts.type == BT_DERIVED)
6187 {
6188 /* The derived type needs to be converted to a temporary
6189 CLASS object. */
6190 gfc_init_se (&parmse, se);
6191 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
6192 fsym->attr.optional
6193 && e->expr_type == EXPR_VARIABLE
6194 && e->symtree->n.sym->attr.optional,
6195 CLASS_DATA (fsym)->attr.class_pointer
6196 || CLASS_DATA (fsym)->attr.allocatable,
6197 &derived_array);
6198 }
6199 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
6200 && e->ts.type != BT_PROCEDURE
6201 && (gfc_expr_attr (e).flavor != FL_PROCEDURE
6202 || gfc_expr_attr (e).proc != PROC_UNKNOWN))
6203 {
6204 /* The intrinsic type needs to be converted to a temporary
6205 CLASS object for the unlimited polymorphic formal. */
6206 gfc_find_vtab (&e->ts);
6207 gfc_init_se (&parmse, se);
6208 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
6209
6210 }
6211 else if (se->ss && se->ss->info->useflags)
6212 {
6213 gfc_ss *ss;
6214
6215 ss = se->ss;
6216
6217 /* An elemental function inside a scalarized loop. */
6218 gfc_init_se (&parmse, se);
6219 parm_kind = ELEMENTAL;
6220
6221 /* When no fsym is present, ulim_copy is set and this is a third or
6222 fourth argument, use call-by-value instead of by reference to
6223 hand the length properties to the copy routine (i.e., most of the
6224 time this will be a call to a __copy_character_* routine where the
6225 third and fourth arguments are the lengths of a deferred length
6226 char array). */
6227 if ((fsym && fsym->attr.value)
6228 || (ulim_copy && (argc == 2 || argc == 3)))
6229 gfc_conv_expr (&parmse, e);
6230 else
6231 gfc_conv_expr_reference (&parmse, e);
6232
6233 if (e->ts.type == BT_CHARACTER && !e->rank
6234 && e->expr_type == EXPR_FUNCTION)
6235 parmse.expr = build_fold_indirect_ref_loc (input_location,
6236 parmse.expr);
6237
6238 if (fsym && fsym->ts.type == BT_DERIVED
6239 && gfc_is_class_container_ref (e))
6240 {
6241 parmse.expr = gfc_class_data_get (parmse.expr);
6242
6243 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6244 && e->symtree->n.sym->attr.optional)
6245 {
6246 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
6247 parmse.expr = build3_loc (input_location, COND_EXPR,
6248 TREE_TYPE (parmse.expr),
6249 cond, parmse.expr,
6250 fold_convert (TREE_TYPE (parmse.expr),
6251 null_pointer_node));
6252 }
6253 }
6254
6255 /* If we are passing an absent array as optional dummy to an
6256 elemental procedure, make sure that we pass NULL when the data
6257 pointer is NULL. We need this extra conditional because of
6258 scalarization which passes arrays elements to the procedure,
6259 ignoring the fact that the array can be absent/unallocated/... */
6260 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
6261 {
6262 tree descriptor_data;
6263
6264 descriptor_data = ss->info->data.array.data;
6265 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6266 descriptor_data,
6267 fold_convert (TREE_TYPE (descriptor_data),
6268 null_pointer_node));
6269 parmse.expr
6270 = fold_build3_loc (input_location, COND_EXPR,
6271 TREE_TYPE (parmse.expr),
6272 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
6273 fold_convert (TREE_TYPE (parmse.expr),
6274 null_pointer_node),
6275 parmse.expr);
6276 }
6277
6278 /* The scalarizer does not repackage the reference to a class
6279 array - instead it returns a pointer to the data element. */
6280 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
6281 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
6282 fsym->attr.intent != INTENT_IN
6283 && (CLASS_DATA (fsym)->attr.class_pointer
6284 || CLASS_DATA (fsym)->attr.allocatable),
6285 fsym->attr.optional
6286 && e->expr_type == EXPR_VARIABLE
6287 && e->symtree->n.sym->attr.optional,
6288 CLASS_DATA (fsym)->attr.class_pointer
6289 || CLASS_DATA (fsym)->attr.allocatable);
6290 }
6291 else
6292 {
6293 bool scalar;
6294 gfc_ss *argss;
6295
6296 gfc_init_se (&parmse, NULL);
6297
6298 /* Check whether the expression is a scalar or not; we cannot use
6299 e->rank as it can be nonzero for functions arguments. */
6300 argss = gfc_walk_expr (e);
6301 scalar = argss == gfc_ss_terminator;
6302 if (!scalar)
6303 gfc_free_ss_chain (argss);
6304
6305 /* Special handling for passing scalar polymorphic coarrays;
6306 otherwise one passes "class->_data.data" instead of "&class". */
6307 if (e->rank == 0 && e->ts.type == BT_CLASS
6308 && fsym && fsym->ts.type == BT_CLASS
6309 && CLASS_DATA (fsym)->attr.codimension
6310 && !CLASS_DATA (fsym)->attr.dimension)
6311 {
6312 gfc_add_class_array_ref (e);
6313 parmse.want_coarray = 1;
6314 scalar = false;
6315 }
6316
6317 /* A scalar or transformational function. */
6318 if (scalar)
6319 {
6320 if (e->expr_type == EXPR_VARIABLE
6321 && e->symtree->n.sym->attr.cray_pointee
6322 && fsym && fsym->attr.flavor == FL_PROCEDURE)
6323 {
6324 /* The Cray pointer needs to be converted to a pointer to
6325 a type given by the expression. */
6326 gfc_conv_expr (&parmse, e);
6327 type = build_pointer_type (TREE_TYPE (parmse.expr));
6328 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
6329 parmse.expr = convert (type, tmp);
6330 }
6331
6332 else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
6333 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6334 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6335
6336 else if (fsym && fsym->attr.value)
6337 {
6338 if (fsym->ts.type == BT_CHARACTER
6339 && fsym->ts.is_c_interop
6340 && fsym->ns->proc_name != NULL
6341 && fsym->ns->proc_name->attr.is_bind_c)
6342 {
6343 parmse.expr = NULL;
6344 gfc_conv_scalar_char_value (fsym, &parmse, &e);
6345 if (parmse.expr == NULL)
6346 gfc_conv_expr (&parmse, e);
6347 }
6348 else
6349 {
6350 gfc_conv_expr (&parmse, e);
6351 if (fsym->attr.optional
6352 && fsym->ts.type != BT_CLASS
6353 && fsym->ts.type != BT_DERIVED)
6354 {
6355 if (e->expr_type != EXPR_VARIABLE
6356 || !e->symtree->n.sym->attr.optional
6357 || e->ref != NULL)
6358 vec_safe_push (optionalargs, boolean_true_node);
6359 else
6360 {
6361 tmp = gfc_conv_expr_present (e->symtree->n.sym);
6362 if (!e->symtree->n.sym->attr.value)
6363 parmse.expr
6364 = fold_build3_loc (input_location, COND_EXPR,
6365 TREE_TYPE (parmse.expr),
6366 tmp, parmse.expr,
6367 fold_convert (TREE_TYPE (parmse.expr),
6368 integer_zero_node));
6369
6370 vec_safe_push (optionalargs,
6371 fold_convert (boolean_type_node,
6372 tmp));
6373 }
6374 }
6375 }
6376 }
6377
6378 else if (arg->name && arg->name[0] == '%')
6379 /* Argument list functions %VAL, %LOC and %REF are signalled
6380 through arg->name. */
6381 conv_arglist_function (&parmse, arg->expr, arg->name);
6382 else if ((e->expr_type == EXPR_FUNCTION)
6383 && ((e->value.function.esym
6384 && e->value.function.esym->result->attr.pointer)
6385 || (!e->value.function.esym
6386 && e->symtree->n.sym->attr.pointer))
6387 && fsym && fsym->attr.target)
6388 /* Make sure the function only gets called once. */
6389 gfc_conv_expr_reference (&parmse, e, false);
6390 else if (e->expr_type == EXPR_FUNCTION
6391 && e->symtree->n.sym->result
6392 && e->symtree->n.sym->result != e->symtree->n.sym
6393 && e->symtree->n.sym->result->attr.proc_pointer)
6394 {
6395 /* Functions returning procedure pointers. */
6396 gfc_conv_expr (&parmse, e);
6397 if (fsym && fsym->attr.proc_pointer)
6398 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6399 }
6400
6401 else
6402 {
6403 if (e->ts.type == BT_CLASS && fsym
6404 && fsym->ts.type == BT_CLASS
6405 && (!CLASS_DATA (fsym)->as
6406 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
6407 && CLASS_DATA (e)->attr.codimension)
6408 {
6409 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
6410 gcc_assert (!CLASS_DATA (fsym)->as);
6411 gfc_add_class_array_ref (e);
6412 parmse.want_coarray = 1;
6413 gfc_conv_expr_reference (&parmse, e);
6414 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
6415 fsym->attr.optional
6416 && e->expr_type == EXPR_VARIABLE);
6417 }
6418 else if (e->ts.type == BT_CLASS && fsym
6419 && fsym->ts.type == BT_CLASS
6420 && !CLASS_DATA (fsym)->as
6421 && !CLASS_DATA (e)->as
6422 && strcmp (fsym->ts.u.derived->name,
6423 e->ts.u.derived->name))
6424 {
6425 type = gfc_typenode_for_spec (&fsym->ts);
6426 var = gfc_create_var (type, fsym->name);
6427 gfc_conv_expr (&parmse, e);
6428 if (fsym->attr.optional
6429 && e->expr_type == EXPR_VARIABLE
6430 && e->symtree->n.sym->attr.optional)
6431 {
6432 stmtblock_t block;
6433 tree cond;
6434 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6435 cond = fold_build2_loc (input_location, NE_EXPR,
6436 logical_type_node, tmp,
6437 fold_convert (TREE_TYPE (tmp),
6438 null_pointer_node));
6439 gfc_start_block (&block);
6440 gfc_add_modify (&block, var,
6441 fold_build1_loc (input_location,
6442 VIEW_CONVERT_EXPR,
6443 type, parmse.expr));
6444 gfc_add_expr_to_block (&parmse.pre,
6445 fold_build3_loc (input_location,
6446 COND_EXPR, void_type_node,
6447 cond, gfc_finish_block (&block),
6448 build_empty_stmt (input_location)));
6449 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6450 parmse.expr = build3_loc (input_location, COND_EXPR,
6451 TREE_TYPE (parmse.expr),
6452 cond, parmse.expr,
6453 fold_convert (TREE_TYPE (parmse.expr),
6454 null_pointer_node));
6455 }
6456 else
6457 {
6458 /* Since the internal representation of unlimited
6459 polymorphic expressions includes an extra field
6460 that other class objects do not, a cast to the
6461 formal type does not work. */
6462 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
6463 {
6464 tree efield;
6465
6466 /* Set the _data field. */
6467 tmp = gfc_class_data_get (var);
6468 efield = fold_convert (TREE_TYPE (tmp),
6469 gfc_class_data_get (parmse.expr));
6470 gfc_add_modify (&parmse.pre, tmp, efield);
6471
6472 /* Set the _vptr field. */
6473 tmp = gfc_class_vptr_get (var);
6474 efield = fold_convert (TREE_TYPE (tmp),
6475 gfc_class_vptr_get (parmse.expr));
6476 gfc_add_modify (&parmse.pre, tmp, efield);
6477
6478 /* Set the _len field. */
6479 tmp = gfc_class_len_get (var);
6480 gfc_add_modify (&parmse.pre, tmp,
6481 build_int_cst (TREE_TYPE (tmp), 0));
6482 }
6483 else
6484 {
6485 tmp = fold_build1_loc (input_location,
6486 VIEW_CONVERT_EXPR,
6487 type, parmse.expr);
6488 gfc_add_modify (&parmse.pre, var, tmp);
6489 ;
6490 }
6491 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6492 }
6493 }
6494 else
6495 {
6496 bool add_clobber;
6497 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
6498 && !fsym->attr.allocatable && !fsym->attr.pointer
6499 && e->symtree && e->symtree->n.sym
6500 && !e->symtree->n.sym->attr.dimension
6501 && !e->symtree->n.sym->attr.pointer
6502 && !e->symtree->n.sym->attr.allocatable
6503 /* See PR 41453. */
6504 && !e->symtree->n.sym->attr.dummy
6505 /* FIXME - PR 87395 and PR 41453 */
6506 && e->symtree->n.sym->attr.save == SAVE_NONE
6507 && !e->symtree->n.sym->attr.associate_var
6508 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
6509 && e->ts.type != BT_CLASS && !sym->attr.elemental;
6510
6511 gfc_conv_expr_reference (&parmse, e, add_clobber);
6512 }
6513 /* Catch base objects that are not variables. */
6514 if (e->ts.type == BT_CLASS
6515 && e->expr_type != EXPR_VARIABLE
6516 && expr && e == expr->base_expr)
6517 base_object = build_fold_indirect_ref_loc (input_location,
6518 parmse.expr);
6519
6520 /* A class array element needs converting back to be a
6521 class object, if the formal argument is a class object. */
6522 if (fsym && fsym->ts.type == BT_CLASS
6523 && e->ts.type == BT_CLASS
6524 && ((CLASS_DATA (fsym)->as
6525 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
6526 || CLASS_DATA (e)->attr.dimension))
6527 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6528 fsym->attr.intent != INTENT_IN
6529 && (CLASS_DATA (fsym)->attr.class_pointer
6530 || CLASS_DATA (fsym)->attr.allocatable),
6531 fsym->attr.optional
6532 && e->expr_type == EXPR_VARIABLE
6533 && e->symtree->n.sym->attr.optional,
6534 CLASS_DATA (fsym)->attr.class_pointer
6535 || CLASS_DATA (fsym)->attr.allocatable);
6536
6537 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6538 allocated on entry, it must be deallocated. */
6539 if (fsym && fsym->attr.intent == INTENT_OUT
6540 && (fsym->attr.allocatable
6541 || (fsym->ts.type == BT_CLASS
6542 && CLASS_DATA (fsym)->attr.allocatable))
6543 && !is_CFI_desc (fsym, NULL))
6544 {
6545 stmtblock_t block;
6546 tree ptr;
6547
6548 gfc_init_block (&block);
6549 ptr = parmse.expr;
6550 if (e->ts.type == BT_CLASS)
6551 ptr = gfc_class_data_get (ptr);
6552
6553 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
6554 NULL_TREE, true,
6555 e, e->ts);
6556 gfc_add_expr_to_block (&block, tmp);
6557 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6558 void_type_node, ptr,
6559 null_pointer_node);
6560 gfc_add_expr_to_block (&block, tmp);
6561
6562 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
6563 {
6564 gfc_add_modify (&block, ptr,
6565 fold_convert (TREE_TYPE (ptr),
6566 null_pointer_node));
6567 gfc_add_expr_to_block (&block, tmp);
6568 }
6569 else if (fsym->ts.type == BT_CLASS)
6570 {
6571 gfc_symbol *vtab;
6572 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
6573 tmp = gfc_get_symbol_decl (vtab);
6574 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6575 ptr = gfc_class_vptr_get (parmse.expr);
6576 gfc_add_modify (&block, ptr,
6577 fold_convert (TREE_TYPE (ptr), tmp));
6578 gfc_add_expr_to_block (&block, tmp);
6579 }
6580
6581 if (fsym->attr.optional
6582 && e->expr_type == EXPR_VARIABLE
6583 && e->symtree->n.sym->attr.optional)
6584 {
6585 tmp = fold_build3_loc (input_location, COND_EXPR,
6586 void_type_node,
6587 gfc_conv_expr_present (e->symtree->n.sym),
6588 gfc_finish_block (&block),
6589 build_empty_stmt (input_location));
6590 }
6591 else
6592 tmp = gfc_finish_block (&block);
6593
6594 gfc_add_expr_to_block (&se->pre, tmp);
6595 }
6596
6597 if (fsym && (fsym->ts.type == BT_DERIVED
6598 || fsym->ts.type == BT_ASSUMED)
6599 && e->ts.type == BT_CLASS
6600 && !CLASS_DATA (e)->attr.dimension
6601 && !CLASS_DATA (e)->attr.codimension)
6602 {
6603 parmse.expr = gfc_class_data_get (parmse.expr);
6604 /* The result is a class temporary, whose _data component
6605 must be freed to avoid a memory leak. */
6606 if (e->expr_type == EXPR_FUNCTION
6607 && CLASS_DATA (e)->attr.allocatable)
6608 {
6609 tree zero;
6610
6611 gfc_expr *var;
6612
6613 /* Borrow the function symbol to make a call to
6614 gfc_add_finalizer_call and then restore it. */
6615 tmp = e->symtree->n.sym->backend_decl;
6616 e->symtree->n.sym->backend_decl
6617 = TREE_OPERAND (parmse.expr, 0);
6618 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
6619 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
6620 finalized = gfc_add_finalizer_call (&parmse.post,
6621 var);
6622 gfc_free_expr (var);
6623 e->symtree->n.sym->backend_decl = tmp;
6624 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
6625
6626 /* Then free the class _data. */
6627 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
6628 tmp = fold_build2_loc (input_location, NE_EXPR,
6629 logical_type_node,
6630 parmse.expr, zero);
6631 tmp = build3_v (COND_EXPR, tmp,
6632 gfc_call_free (parmse.expr),
6633 build_empty_stmt (input_location));
6634 gfc_add_expr_to_block (&parmse.post, tmp);
6635 gfc_add_modify (&parmse.post, parmse.expr, zero);
6636 }
6637 }
6638
6639 /* Wrap scalar variable in a descriptor. We need to convert
6640 the address of a pointer back to the pointer itself before,
6641 we can assign it to the data field. */
6642
6643 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
6644 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
6645 {
6646 tmp = parmse.expr;
6647 if (TREE_CODE (tmp) == ADDR_EXPR)
6648 tmp = TREE_OPERAND (tmp, 0);
6649 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
6650 fsym->attr);
6651 parmse.expr = gfc_build_addr_expr (NULL_TREE,
6652 parmse.expr);
6653 }
6654 else if (fsym && e->expr_type != EXPR_NULL
6655 && ((fsym->attr.pointer
6656 && fsym->attr.flavor != FL_PROCEDURE)
6657 || (fsym->attr.proc_pointer
6658 && !(e->expr_type == EXPR_VARIABLE
6659 && e->symtree->n.sym->attr.dummy))
6660 || (fsym->attr.proc_pointer
6661 && e->expr_type == EXPR_VARIABLE
6662 && gfc_is_proc_ptr_comp (e))
6663 || (fsym->attr.allocatable
6664 && fsym->attr.flavor != FL_PROCEDURE)))
6665 {
6666 /* Scalar pointer dummy args require an extra level of
6667 indirection. The null pointer already contains
6668 this level of indirection. */
6669 parm_kind = SCALAR_POINTER;
6670 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6671 }
6672 }
6673 }
6674 else if (e->ts.type == BT_CLASS
6675 && fsym && fsym->ts.type == BT_CLASS
6676 && (CLASS_DATA (fsym)->attr.dimension
6677 || CLASS_DATA (fsym)->attr.codimension))
6678 {
6679 /* Pass a class array. */
6680 parmse.use_offset = 1;
6681 gfc_conv_expr_descriptor (&parmse, e);
6682
6683 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6684 allocated on entry, it must be deallocated. */
6685 if (fsym->attr.intent == INTENT_OUT
6686 && CLASS_DATA (fsym)->attr.allocatable)
6687 {
6688 stmtblock_t block;
6689 tree ptr;
6690
6691 gfc_init_block (&block);
6692 ptr = parmse.expr;
6693 ptr = gfc_class_data_get (ptr);
6694
6695 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
6696 NULL_TREE, NULL_TREE,
6697 NULL_TREE, true, e,
6698 GFC_CAF_COARRAY_NOCOARRAY);
6699 gfc_add_expr_to_block (&block, tmp);
6700 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6701 void_type_node, ptr,
6702 null_pointer_node);
6703 gfc_add_expr_to_block (&block, tmp);
6704 gfc_reset_vptr (&block, e);
6705
6706 if (fsym->attr.optional
6707 && e->expr_type == EXPR_VARIABLE
6708 && (!e->ref
6709 || (e->ref->type == REF_ARRAY
6710 && e->ref->u.ar.type != AR_FULL))
6711 && e->symtree->n.sym->attr.optional)
6712 {
6713 tmp = fold_build3_loc (input_location, COND_EXPR,
6714 void_type_node,
6715 gfc_conv_expr_present (e->symtree->n.sym),
6716 gfc_finish_block (&block),
6717 build_empty_stmt (input_location));
6718 }
6719 else
6720 tmp = gfc_finish_block (&block);
6721
6722 gfc_add_expr_to_block (&se->pre, tmp);
6723 }
6724
6725 /* The conversion does not repackage the reference to a class
6726 array - _data descriptor. */
6727 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6728 fsym->attr.intent != INTENT_IN
6729 && (CLASS_DATA (fsym)->attr.class_pointer
6730 || CLASS_DATA (fsym)->attr.allocatable),
6731 fsym->attr.optional
6732 && e->expr_type == EXPR_VARIABLE
6733 && e->symtree->n.sym->attr.optional,
6734 CLASS_DATA (fsym)->attr.class_pointer
6735 || CLASS_DATA (fsym)->attr.allocatable);
6736 }
6737 else
6738 {
6739 /* If the argument is a function call that may not create
6740 a temporary for the result, we have to check that we
6741 can do it, i.e. that there is no alias between this
6742 argument and another one. */
6743 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
6744 {
6745 gfc_expr *iarg;
6746 sym_intent intent;
6747
6748 if (fsym != NULL)
6749 intent = fsym->attr.intent;
6750 else
6751 intent = INTENT_UNKNOWN;
6752
6753 if (gfc_check_fncall_dependency (e, intent, sym, args,
6754 NOT_ELEMENTAL))
6755 parmse.force_tmp = 1;
6756
6757 iarg = e->value.function.actual->expr;
6758
6759 /* Temporary needed if aliasing due to host association. */
6760 if (sym->attr.contained
6761 && !sym->attr.pure
6762 && !sym->attr.implicit_pure
6763 && !sym->attr.use_assoc
6764 && iarg->expr_type == EXPR_VARIABLE
6765 && sym->ns == iarg->symtree->n.sym->ns)
6766 parmse.force_tmp = 1;
6767
6768 /* Ditto within module. */
6769 if (sym->attr.use_assoc
6770 && !sym->attr.pure
6771 && !sym->attr.implicit_pure
6772 && iarg->expr_type == EXPR_VARIABLE
6773 && sym->module == iarg->symtree->n.sym->module)
6774 parmse.force_tmp = 1;
6775 }
6776
6777 /* Special case for assumed-rank arrays: when passing an
6778 argument to a nonallocatable/nonpointer dummy, the bounds have
6779 to be reset as otherwise a last-dim ubound of -1 is
6780 indistinguishable from an assumed-size array in the callee. */
6781 if (!sym->attr.is_bind_c && e && fsym && fsym->as
6782 && fsym->as->type == AS_ASSUMED_RANK
6783 && e->rank != -1
6784 && e->expr_type == EXPR_VARIABLE
6785 && ((fsym->ts.type == BT_CLASS
6786 && !CLASS_DATA (fsym)->attr.class_pointer
6787 && !CLASS_DATA (fsym)->attr.allocatable)
6788 || (fsym->ts.type != BT_CLASS
6789 && !fsym->attr.pointer && !fsym->attr.allocatable)))
6790 {
6791 /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
6792 gfc_ref *ref;
6793 for (ref = e->ref; ref->next; ref = ref->next)
6794 ;
6795 if (ref->u.ar.type == AR_FULL
6796 && ref->u.ar.as->type != AS_ASSUMED_SIZE)
6797 ref->u.ar.type = AR_SECTION;
6798 }
6799
6800 if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
6801 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6802 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6803
6804 else if (e->expr_type == EXPR_VARIABLE
6805 && is_subref_array (e)
6806 && !(fsym && fsym->attr.pointer))
6807 /* The actual argument is a component reference to an
6808 array of derived types. In this case, the argument
6809 is converted to a temporary, which is passed and then
6810 written back after the procedure call. */
6811 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6812 fsym ? fsym->attr.intent : INTENT_INOUT,
6813 fsym && fsym->attr.pointer);
6814
6815 else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
6816 && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
6817 && nodesc_arg && fsym->ts.type == BT_DERIVED)
6818 /* An assumed size class actual argument being passed to
6819 a 'no descriptor' formal argument just requires the
6820 data pointer to be passed. For class dummy arguments
6821 this is stored in the symbol backend decl.. */
6822 parmse.expr = e->symtree->n.sym->backend_decl;
6823
6824 else if (gfc_is_class_array_ref (e, NULL)
6825 && fsym && fsym->ts.type == BT_DERIVED)
6826 /* The actual argument is a component reference to an
6827 array of derived types. In this case, the argument
6828 is converted to a temporary, which is passed and then
6829 written back after the procedure call.
6830 OOP-TODO: Insert code so that if the dynamic type is
6831 the same as the declared type, copy-in/copy-out does
6832 not occur. */
6833 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6834 fsym->attr.intent,
6835 fsym->attr.pointer);
6836
6837 else if (gfc_is_class_array_function (e)
6838 && fsym && fsym->ts.type == BT_DERIVED)
6839 /* See previous comment. For function actual argument,
6840 the write out is not needed so the intent is set as
6841 intent in. */
6842 {
6843 e->must_finalize = 1;
6844 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6845 INTENT_IN, fsym->attr.pointer);
6846 }
6847 else if (fsym && fsym->attr.contiguous
6848 && !gfc_is_simply_contiguous (e, false, true)
6849 && gfc_expr_is_variable (e))
6850 {
6851 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6852 fsym->attr.intent,
6853 fsym->attr.pointer);
6854 }
6855 else
6856 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
6857 sym->name, NULL);
6858
6859 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6860 allocated on entry, it must be deallocated.
6861 CFI descriptors are handled elsewhere. */
6862 if (fsym && fsym->attr.allocatable
6863 && fsym->attr.intent == INTENT_OUT
6864 && !is_CFI_desc (fsym, NULL))
6865 {
6866 if (fsym->ts.type == BT_DERIVED
6867 && fsym->ts.u.derived->attr.alloc_comp)
6868 {
6869 // deallocate the components first
6870 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
6871 parmse.expr, e->rank);
6872 /* But check whether dummy argument is optional. */
6873 if (tmp != NULL_TREE
6874 && fsym->attr.optional
6875 && e->expr_type == EXPR_VARIABLE
6876 && e->symtree->n.sym->attr.optional)
6877 {
6878 tree present;
6879 present = gfc_conv_expr_present (e->symtree->n.sym);
6880 tmp = build3_v (COND_EXPR, present, tmp,
6881 build_empty_stmt (input_location));
6882 }
6883 if (tmp != NULL_TREE)
6884 gfc_add_expr_to_block (&se->pre, tmp);
6885 }
6886
6887 tmp = parmse.expr;
6888 /* With bind(C), the actual argument is replaced by a bind-C
6889 descriptor; in this case, the data component arrives here,
6890 which shall not be dereferenced, but still freed and
6891 nullified. */
6892 if (TREE_TYPE(tmp) != pvoid_type_node)
6893 tmp = build_fold_indirect_ref_loc (input_location,
6894 parmse.expr);
6895 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6896 tmp = gfc_conv_descriptor_data_get (tmp);
6897 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6898 NULL_TREE, NULL_TREE, true,
6899 e,
6900 GFC_CAF_COARRAY_NOCOARRAY);
6901 if (fsym->attr.optional
6902 && e->expr_type == EXPR_VARIABLE
6903 && e->symtree->n.sym->attr.optional)
6904 tmp = fold_build3_loc (input_location, COND_EXPR,
6905 void_type_node,
6906 gfc_conv_expr_present (e->symtree->n.sym),
6907 tmp, build_empty_stmt (input_location));
6908 gfc_add_expr_to_block (&se->pre, tmp);
6909 }
6910 }
6911 }
6912 /* Special case for an assumed-rank dummy argument. */
6913 if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
6914 && (fsym->ts.type == BT_CLASS
6915 ? (CLASS_DATA (fsym)->as
6916 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
6917 : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
6918 {
6919 if (fsym->ts.type == BT_CLASS
6920 ? (CLASS_DATA (fsym)->attr.class_pointer
6921 || CLASS_DATA (fsym)->attr.allocatable)
6922 : (fsym->attr.pointer || fsym->attr.allocatable))
6923 {
6924 /* Unallocated allocatable arrays and unassociated pointer
6925 arrays need their dtype setting if they are argument
6926 associated with assumed rank dummies to set the rank. */
6927 set_dtype_for_unallocated (&parmse, e);
6928 }
6929 else if (e->expr_type == EXPR_VARIABLE
6930 && e->symtree->n.sym->attr.dummy
6931 && (e->ts.type == BT_CLASS
6932 ? (e->ref && e->ref->next
6933 && e->ref->next->type == REF_ARRAY
6934 && e->ref->next->u.ar.type == AR_FULL
6935 && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
6936 : (e->ref && e->ref->type == REF_ARRAY
6937 && e->ref->u.ar.type == AR_FULL
6938 && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
6939 {
6940 /* Assumed-size actual to assumed-rank dummy requires
6941 dim[rank-1].ubound = -1. */
6942 tree minus_one;
6943 tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
6944 if (fsym->ts.type == BT_CLASS)
6945 tmp = gfc_class_data_get (tmp);
6946 minus_one = build_int_cst (gfc_array_index_type, -1);
6947 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
6948 gfc_rank_cst[e->rank - 1],
6949 minus_one);
6950 }
6951 }
6952
6953 /* The case with fsym->attr.optional is that of a user subroutine
6954 with an interface indicating an optional argument. When we call
6955 an intrinsic subroutine, however, fsym is NULL, but we might still
6956 have an optional argument, so we proceed to the substitution
6957 just in case. */
6958 if (e && (fsym == NULL || fsym->attr.optional))
6959 {
6960 /* If an optional argument is itself an optional dummy argument,
6961 check its presence and substitute a null if absent. This is
6962 only needed when passing an array to an elemental procedure
6963 as then array elements are accessed - or no NULL pointer is
6964 allowed and a "1" or "0" should be passed if not present.
6965 When passing a non-array-descriptor full array to a
6966 non-array-descriptor dummy, no check is needed. For
6967 array-descriptor actual to array-descriptor dummy, see
6968 PR 41911 for why a check has to be inserted.
6969 fsym == NULL is checked as intrinsics required the descriptor
6970 but do not always set fsym.
6971 Also, it is necessary to pass a NULL pointer to library routines
6972 which usually ignore optional arguments, so they can handle
6973 these themselves. */
6974 if (e->expr_type == EXPR_VARIABLE
6975 && e->symtree->n.sym->attr.optional
6976 && (((e->rank != 0 && elemental_proc)
6977 || e->representation.length || e->ts.type == BT_CHARACTER
6978 || (e->rank != 0
6979 && (fsym == NULL
6980 || (fsym->as
6981 && (fsym->as->type == AS_ASSUMED_SHAPE
6982 || fsym->as->type == AS_ASSUMED_RANK
6983 || fsym->as->type == AS_DEFERRED)))))
6984 || se->ignore_optional))
6985 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6986 e->representation.length);
6987 }
6988
6989 if (fsym && e)
6990 {
6991 /* Obtain the character length of an assumed character length
6992 length procedure from the typespec. */
6993 if (fsym->ts.type == BT_CHARACTER
6994 && parmse.string_length == NULL_TREE
6995 && e->ts.type == BT_PROCEDURE
6996 && e->symtree->n.sym->ts.type == BT_CHARACTER
6997 && e->symtree->n.sym->ts.u.cl->length != NULL
6998 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6999 {
7000 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
7001 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
7002 }
7003 }
7004
7005 if (fsym && need_interface_mapping && e)
7006 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7007
7008 gfc_add_block_to_block (&se->pre, &parmse.pre);
7009 gfc_add_block_to_block (&post, &parmse.post);
7010
7011 /* Allocated allocatable components of derived types must be
7012 deallocated for non-variable scalars, array arguments to elemental
7013 procedures, and array arguments with descriptor to non-elemental
7014 procedures. As bounds information for descriptorless arrays is no
7015 longer available here, they are dealt with in trans-array.c
7016 (gfc_conv_array_parameter). */
7017 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
7018 && e->ts.u.derived->attr.alloc_comp
7019 && (e->rank == 0 || elemental_proc || !nodesc_arg)
7020 && !expr_may_alias_variables (e, elemental_proc))
7021 {
7022 int parm_rank;
7023 /* It is known the e returns a structure type with at least one
7024 allocatable component. When e is a function, ensure that the
7025 function is called once only by using a temporary variable. */
7026 if (!DECL_P (parmse.expr))
7027 parmse.expr = gfc_evaluate_now_loc (input_location,
7028 parmse.expr, &se->pre);
7029
7030 if (fsym && fsym->attr.value)
7031 tmp = parmse.expr;
7032 else
7033 tmp = build_fold_indirect_ref_loc (input_location,
7034 parmse.expr);
7035
7036 parm_rank = e->rank;
7037 switch (parm_kind)
7038 {
7039 case (ELEMENTAL):
7040 case (SCALAR):
7041 parm_rank = 0;
7042 break;
7043
7044 case (SCALAR_POINTER):
7045 tmp = build_fold_indirect_ref_loc (input_location,
7046 tmp);
7047 break;
7048 }
7049
7050 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
7051 {
7052 /* The derived type is passed to gfc_deallocate_alloc_comp.
7053 Therefore, class actuals can be handled correctly but derived
7054 types passed to class formals need the _data component. */
7055 tmp = gfc_class_data_get (tmp);
7056 if (!CLASS_DATA (fsym)->attr.dimension)
7057 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7058 }
7059
7060 if (e->expr_type == EXPR_OP
7061 && e->value.op.op == INTRINSIC_PARENTHESES
7062 && e->value.op.op1->expr_type == EXPR_VARIABLE)
7063 {
7064 tree local_tmp;
7065 local_tmp = gfc_evaluate_now (tmp, &se->pre);
7066 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
7067 parm_rank, 0);
7068 gfc_add_expr_to_block (&se->post, local_tmp);
7069 }
7070
7071 if (!finalized && !e->must_finalize)
7072 {
7073 bool scalar_res_outside_loop;
7074 scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
7075 && parm_rank == 0
7076 && parmse.loop;
7077
7078 /* Scalars passed to an assumed rank argument are converted to
7079 a descriptor. Obtain the data field before deallocating any
7080 allocatable components. */
7081 if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7082 tmp = gfc_conv_descriptor_data_get (tmp);
7083
7084 if (scalar_res_outside_loop)
7085 {
7086 /* Go through the ss chain to find the argument and use
7087 the stored value. */
7088 gfc_ss *tmp_ss = parmse.loop->ss;
7089 for (; tmp_ss; tmp_ss = tmp_ss->next)
7090 if (tmp_ss->info
7091 && tmp_ss->info->expr == e
7092 && tmp_ss->info->data.scalar.value != NULL_TREE)
7093 {
7094 tmp = tmp_ss->info->data.scalar.value;
7095 break;
7096 }
7097 }
7098
7099 STRIP_NOPS (tmp);
7100
7101 if (derived_array != NULL_TREE)
7102 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
7103 derived_array,
7104 parm_rank);
7105 else if ((e->ts.type == BT_CLASS
7106 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
7107 || e->ts.type == BT_DERIVED)
7108 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
7109 parm_rank);
7110 else if (e->ts.type == BT_CLASS)
7111 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
7112 tmp, parm_rank);
7113
7114 if (scalar_res_outside_loop)
7115 gfc_add_expr_to_block (&parmse.loop->post, tmp);
7116 else
7117 gfc_prepend_expr_to_block (&post, tmp);
7118 }
7119 }
7120
7121 /* Add argument checking of passing an unallocated/NULL actual to
7122 a nonallocatable/nonpointer dummy. */
7123
7124 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
7125 {
7126 symbol_attribute attr;
7127 char *msg;
7128 tree cond;
7129 tree tmp;
7130 symbol_attribute fsym_attr;
7131
7132 if (fsym)
7133 {
7134 if (fsym->ts.type == BT_CLASS)
7135 {
7136 fsym_attr = CLASS_DATA (fsym)->attr;
7137 fsym_attr.pointer = fsym_attr.class_pointer;
7138 }
7139 else
7140 fsym_attr = fsym->attr;
7141 }
7142
7143 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
7144 attr = gfc_expr_attr (e);
7145 else
7146 goto end_pointer_check;
7147
7148 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
7149 allocatable to an optional dummy, cf. 12.5.2.12. */
7150 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
7151 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
7152 goto end_pointer_check;
7153
7154 if (attr.optional)
7155 {
7156 /* If the actual argument is an optional pointer/allocatable and
7157 the formal argument takes an nonpointer optional value,
7158 it is invalid to pass a non-present argument on, even
7159 though there is no technical reason for this in gfortran.
7160 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
7161 tree present, null_ptr, type;
7162
7163 if (attr.allocatable
7164 && (fsym == NULL || !fsym_attr.allocatable))
7165 msg = xasprintf ("Allocatable actual argument '%s' is not "
7166 "allocated or not present",
7167 e->symtree->n.sym->name);
7168 else if (attr.pointer
7169 && (fsym == NULL || !fsym_attr.pointer))
7170 msg = xasprintf ("Pointer actual argument '%s' is not "
7171 "associated or not present",
7172 e->symtree->n.sym->name);
7173 else if (attr.proc_pointer && !e->value.function.actual
7174 && (fsym == NULL || !fsym_attr.proc_pointer))
7175 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
7176 "associated or not present",
7177 e->symtree->n.sym->name);
7178 else
7179 goto end_pointer_check;
7180
7181 present = gfc_conv_expr_present (e->symtree->n.sym);
7182 type = TREE_TYPE (present);
7183 present = fold_build2_loc (input_location, EQ_EXPR,
7184 logical_type_node, present,
7185 fold_convert (type,
7186 null_pointer_node));
7187 type = TREE_TYPE (parmse.expr);
7188 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
7189 logical_type_node, parmse.expr,
7190 fold_convert (type,
7191 null_pointer_node));
7192 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7193 logical_type_node, present, null_ptr);
7194 }
7195 else
7196 {
7197 if (attr.allocatable
7198 && (fsym == NULL || !fsym_attr.allocatable))
7199 msg = xasprintf ("Allocatable actual argument '%s' is not "
7200 "allocated", e->symtree->n.sym->name);
7201 else if (attr.pointer
7202 && (fsym == NULL || !fsym_attr.pointer))
7203 msg = xasprintf ("Pointer actual argument '%s' is not "
7204 "associated", e->symtree->n.sym->name);
7205 else if (attr.proc_pointer && !e->value.function.actual
7206 && (fsym == NULL || !fsym_attr.proc_pointer))
7207 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
7208 "associated", e->symtree->n.sym->name);
7209 else
7210 goto end_pointer_check;
7211
7212 if (fsym && fsym->ts.type == BT_CLASS)
7213 {
7214 tmp = build_fold_indirect_ref_loc (input_location,
7215 parmse.expr);
7216 tmp = gfc_class_data_get (tmp);
7217 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7218 tmp = gfc_conv_descriptor_data_get (tmp);
7219 }
7220 else
7221 tmp = parmse.expr;
7222
7223 /* If the argument is passed by value, we need to strip the
7224 INDIRECT_REF. */
7225 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
7226 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
7227
7228 cond = fold_build2_loc (input_location, EQ_EXPR,
7229 logical_type_node, tmp,
7230 fold_convert (TREE_TYPE (tmp),
7231 null_pointer_node));
7232 }
7233
7234 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
7235 msg);
7236 free (msg);
7237 }
7238 end_pointer_check:
7239
7240 /* Deferred length dummies pass the character length by reference
7241 so that the value can be returned. */
7242 if (parmse.string_length && fsym && fsym->ts.deferred)
7243 {
7244 if (INDIRECT_REF_P (parmse.string_length))
7245 /* In chains of functions/procedure calls the string_length already
7246 is a pointer to the variable holding the length. Therefore
7247 remove the deref on call. */
7248 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
7249 else
7250 {
7251 tmp = parmse.string_length;
7252 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
7253 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
7254 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
7255 }
7256 }
7257
7258 /* Character strings are passed as two parameters, a length and a
7259 pointer - except for Bind(c) which only passes the pointer.
7260 An unlimited polymorphic formal argument likewise does not
7261 need the length. */
7262 if (parmse.string_length != NULL_TREE
7263 && !sym->attr.is_bind_c
7264 && !(fsym && UNLIMITED_POLY (fsym)))
7265 vec_safe_push (stringargs, parmse.string_length);
7266
7267 /* When calling __copy for character expressions to unlimited
7268 polymorphic entities, the dst argument needs a string length. */
7269 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
7270 && startswith (sym->name, "__vtab_CHARACTER")
7271 && arg->next && arg->next->expr
7272 && (arg->next->expr->ts.type == BT_DERIVED
7273 || arg->next->expr->ts.type == BT_CLASS)
7274 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
7275 vec_safe_push (stringargs, parmse.string_length);
7276
7277 /* For descriptorless coarrays and assumed-shape coarray dummies, we
7278 pass the token and the offset as additional arguments. */
7279 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
7280 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
7281 && !fsym->attr.allocatable)
7282 || (fsym->ts.type == BT_CLASS
7283 && CLASS_DATA (fsym)->attr.codimension
7284 && !CLASS_DATA (fsym)->attr.allocatable)))
7285 {
7286 /* Token and offset. */
7287 vec_safe_push (stringargs, null_pointer_node);
7288 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
7289 gcc_assert (fsym->attr.optional);
7290 }
7291 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
7292 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
7293 && !fsym->attr.allocatable)
7294 || (fsym->ts.type == BT_CLASS
7295 && CLASS_DATA (fsym)->attr.codimension
7296 && !CLASS_DATA (fsym)->attr.allocatable)))
7297 {
7298 tree caf_decl, caf_type;
7299 tree offset, tmp2;
7300
7301 caf_decl = gfc_get_tree_for_caf_expr (e);
7302 caf_type = TREE_TYPE (caf_decl);
7303
7304 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
7305 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
7306 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
7307 tmp = gfc_conv_descriptor_token (caf_decl);
7308 else if (DECL_LANG_SPECIFIC (caf_decl)
7309 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
7310 tmp = GFC_DECL_TOKEN (caf_decl);
7311 else
7312 {
7313 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
7314 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
7315 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
7316 }
7317
7318 vec_safe_push (stringargs, tmp);
7319
7320 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
7321 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
7322 offset = build_int_cst (gfc_array_index_type, 0);
7323 else if (DECL_LANG_SPECIFIC (caf_decl)
7324 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
7325 offset = GFC_DECL_CAF_OFFSET (caf_decl);
7326 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
7327 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
7328 else
7329 offset = build_int_cst (gfc_array_index_type, 0);
7330
7331 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
7332 tmp = gfc_conv_descriptor_data_get (caf_decl);
7333 else
7334 {
7335 gcc_assert (POINTER_TYPE_P (caf_type));
7336 tmp = caf_decl;
7337 }
7338
7339 tmp2 = fsym->ts.type == BT_CLASS
7340 ? gfc_class_data_get (parmse.expr) : parmse.expr;
7341 if ((fsym->ts.type != BT_CLASS
7342 && (fsym->as->type == AS_ASSUMED_SHAPE
7343 || fsym->as->type == AS_ASSUMED_RANK))
7344 || (fsym->ts.type == BT_CLASS
7345 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
7346 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
7347 {
7348 if (fsym->ts.type == BT_CLASS)
7349 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
7350 else
7351 {
7352 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
7353 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
7354 }
7355 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
7356 tmp2 = gfc_conv_descriptor_data_get (tmp2);
7357 }
7358 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
7359 tmp2 = gfc_conv_descriptor_data_get (tmp2);
7360 else
7361 {
7362 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
7363 }
7364
7365 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7366 gfc_array_index_type,
7367 fold_convert (gfc_array_index_type, tmp2),
7368 fold_convert (gfc_array_index_type, tmp));
7369 offset = fold_build2_loc (input_location, PLUS_EXPR,
7370 gfc_array_index_type, offset, tmp);
7371
7372 vec_safe_push (stringargs, offset);
7373 }
7374
7375 vec_safe_push (arglist, parmse.expr);
7376 }
7377 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
7378
7379 if (comp)
7380 ts = comp->ts;
7381 else if (sym->ts.type == BT_CLASS)
7382 ts = CLASS_DATA (sym)->ts;
7383 else
7384 ts = sym->ts;
7385
7386 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
7387 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
7388 else if (ts.type == BT_CHARACTER)
7389 {
7390 if (ts.u.cl->length == NULL)
7391 {
7392 /* Assumed character length results are not allowed by C418 of the 2003
7393 standard and are trapped in resolve.c; except in the case of SPREAD
7394 (and other intrinsics?) and dummy functions. In the case of SPREAD,
7395 we take the character length of the first argument for the result.
7396 For dummies, we have to look through the formal argument list for
7397 this function and use the character length found there.*/
7398 if (ts.deferred)
7399 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
7400 else if (!sym->attr.dummy)
7401 cl.backend_decl = (*stringargs)[0];
7402 else
7403 {
7404 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
7405 for (; formal; formal = formal->next)
7406 if (strcmp (formal->sym->name, sym->name) == 0)
7407 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
7408 }
7409 len = cl.backend_decl;
7410 }
7411 else
7412 {
7413 tree tmp;
7414
7415 /* Calculate the length of the returned string. */
7416 gfc_init_se (&parmse, NULL);
7417 if (need_interface_mapping)
7418 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
7419 else
7420 gfc_conv_expr (&parmse, ts.u.cl->length);
7421 gfc_add_block_to_block (&se->pre, &parmse.pre);
7422 gfc_add_block_to_block (&se->post, &parmse.post);
7423 tmp = parmse.expr;
7424 /* TODO: It would be better to have the charlens as
7425 gfc_charlen_type_node already when the interface is
7426 created instead of converting it here (see PR 84615). */
7427 tmp = fold_build2_loc (input_location, MAX_EXPR,
7428 gfc_charlen_type_node,
7429 fold_convert (gfc_charlen_type_node, tmp),
7430 build_zero_cst (gfc_charlen_type_node));
7431 cl.backend_decl = tmp;
7432 }
7433
7434 /* Set up a charlen structure for it. */
7435 cl.next = NULL;
7436 cl.length = NULL;
7437 ts.u.cl = &cl;
7438
7439 len = cl.backend_decl;
7440 }
7441
7442 byref = (comp && (comp->attr.dimension
7443 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
7444 || (!comp && gfc_return_by_reference (sym));
7445 if (byref)
7446 {
7447 if (se->direct_byref)
7448 {
7449 /* Sometimes, too much indirection can be applied; e.g. for
7450 function_result = array_valued_recursive_function. */
7451 if (TREE_TYPE (TREE_TYPE (se->expr))
7452 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
7453 && GFC_DESCRIPTOR_TYPE_P
7454 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
7455 se->expr = build_fold_indirect_ref_loc (input_location,
7456 se->expr);
7457
7458 /* If the lhs of an assignment x = f(..) is allocatable and
7459 f2003 is allowed, we must do the automatic reallocation.
7460 TODO - deal with intrinsics, without using a temporary. */
7461 if (flag_realloc_lhs
7462 && se->ss && se->ss->loop_chain
7463 && se->ss->loop_chain->is_alloc_lhs
7464 && !expr->value.function.isym
7465 && sym->result->as != NULL)
7466 {
7467 /* Evaluate the bounds of the result, if known. */
7468 gfc_set_loop_bounds_from_array_spec (&mapping, se,
7469 sym->result->as);
7470
7471 /* Perform the automatic reallocation. */
7472 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
7473 expr, NULL);
7474 gfc_add_expr_to_block (&se->pre, tmp);
7475
7476 /* Pass the temporary as the first argument. */
7477 result = info->descriptor;
7478 }
7479 else
7480 result = build_fold_indirect_ref_loc (input_location,
7481 se->expr);
7482 vec_safe_push (retargs, se->expr);
7483 }
7484 else if (comp && comp->attr.dimension)
7485 {
7486 gcc_assert (se->loop && info);
7487
7488 /* Set the type of the array. */
7489 tmp = gfc_typenode_for_spec (&comp->ts);
7490 gcc_assert (se->ss->dimen == se->loop->dimen);
7491
7492 /* Evaluate the bounds of the result, if known. */
7493 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
7494
7495 /* If the lhs of an assignment x = f(..) is allocatable and
7496 f2003 is allowed, we must not generate the function call
7497 here but should just send back the results of the mapping.
7498 This is signalled by the function ss being flagged. */
7499 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7500 {
7501 gfc_free_interface_mapping (&mapping);
7502 return has_alternate_specifier;
7503 }
7504
7505 /* Create a temporary to store the result. In case the function
7506 returns a pointer, the temporary will be a shallow copy and
7507 mustn't be deallocated. */
7508 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
7509 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7510 tmp, NULL_TREE, false,
7511 !comp->attr.pointer, callee_alloc,
7512 &se->ss->info->expr->where);
7513
7514 /* Pass the temporary as the first argument. */
7515 result = info->descriptor;
7516 tmp = gfc_build_addr_expr (NULL_TREE, result);
7517 vec_safe_push (retargs, tmp);
7518 }
7519 else if (!comp && sym->result->attr.dimension)
7520 {
7521 gcc_assert (se->loop && info);
7522
7523 /* Set the type of the array. */
7524 tmp = gfc_typenode_for_spec (&ts);
7525 gcc_assert (se->ss->dimen == se->loop->dimen);
7526
7527 /* Evaluate the bounds of the result, if known. */
7528 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
7529
7530 /* If the lhs of an assignment x = f(..) is allocatable and
7531 f2003 is allowed, we must not generate the function call
7532 here but should just send back the results of the mapping.
7533 This is signalled by the function ss being flagged. */
7534 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7535 {
7536 gfc_free_interface_mapping (&mapping);
7537 return has_alternate_specifier;
7538 }
7539
7540 /* Create a temporary to store the result. In case the function
7541 returns a pointer, the temporary will be a shallow copy and
7542 mustn't be deallocated. */
7543 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
7544 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7545 tmp, NULL_TREE, false,
7546 !sym->attr.pointer, callee_alloc,
7547 &se->ss->info->expr->where);
7548
7549 /* Pass the temporary as the first argument. */
7550 result = info->descriptor;
7551 tmp = gfc_build_addr_expr (NULL_TREE, result);
7552 vec_safe_push (retargs, tmp);
7553 }
7554 else if (ts.type == BT_CHARACTER)
7555 {
7556 /* Pass the string length. */
7557 type = gfc_get_character_type (ts.kind, ts.u.cl);
7558 type = build_pointer_type (type);
7559
7560 /* Emit a DECL_EXPR for the VLA type. */
7561 tmp = TREE_TYPE (type);
7562 if (TYPE_SIZE (tmp)
7563 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
7564 {
7565 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
7566 DECL_ARTIFICIAL (tmp) = 1;
7567 DECL_IGNORED_P (tmp) = 1;
7568 tmp = fold_build1_loc (input_location, DECL_EXPR,
7569 TREE_TYPE (tmp), tmp);
7570 gfc_add_expr_to_block (&se->pre, tmp);
7571 }
7572
7573 /* Return an address to a char[0:len-1]* temporary for
7574 character pointers. */
7575 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7576 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
7577 {
7578 var = gfc_create_var (type, "pstr");
7579
7580 if ((!comp && sym->attr.allocatable)
7581 || (comp && comp->attr.allocatable))
7582 {
7583 gfc_add_modify (&se->pre, var,
7584 fold_convert (TREE_TYPE (var),
7585 null_pointer_node));
7586 tmp = gfc_call_free (var);
7587 gfc_add_expr_to_block (&se->post, tmp);
7588 }
7589
7590 /* Provide an address expression for the function arguments. */
7591 var = gfc_build_addr_expr (NULL_TREE, var);
7592 }
7593 else
7594 var = gfc_conv_string_tmp (se, type, len);
7595
7596 vec_safe_push (retargs, var);
7597 }
7598 else
7599 {
7600 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
7601
7602 type = gfc_get_complex_type (ts.kind);
7603 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
7604 vec_safe_push (retargs, var);
7605 }
7606
7607 /* Add the string length to the argument list. */
7608 if (ts.type == BT_CHARACTER && ts.deferred)
7609 {
7610 tmp = len;
7611 if (!VAR_P (tmp))
7612 tmp = gfc_evaluate_now (len, &se->pre);
7613 TREE_STATIC (tmp) = 1;
7614 gfc_add_modify (&se->pre, tmp,
7615 build_int_cst (TREE_TYPE (tmp), 0));
7616 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
7617 vec_safe_push (retargs, tmp);
7618 }
7619 else if (ts.type == BT_CHARACTER)
7620 vec_safe_push (retargs, len);
7621 }
7622 gfc_free_interface_mapping (&mapping);
7623
7624 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
7625 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
7626 + vec_safe_length (stringargs) + vec_safe_length (append_args));
7627 vec_safe_reserve (retargs, arglen);
7628
7629 /* Add the return arguments. */
7630 vec_safe_splice (retargs, arglist);
7631
7632 /* Add the hidden present status for optional+value to the arguments. */
7633 vec_safe_splice (retargs, optionalargs);
7634
7635 /* Add the hidden string length parameters to the arguments. */
7636 vec_safe_splice (retargs, stringargs);
7637
7638 /* We may want to append extra arguments here. This is used e.g. for
7639 calls to libgfortran_matmul_??, which need extra information. */
7640 vec_safe_splice (retargs, append_args);
7641
7642 arglist = retargs;
7643
7644 /* Generate the actual call. */
7645 if (base_object == NULL_TREE)
7646 conv_function_val (se, sym, expr, args);
7647 else
7648 conv_base_obj_fcn_val (se, base_object, expr);
7649
7650 /* If there are alternate return labels, function type should be
7651 integer. Can't modify the type in place though, since it can be shared
7652 with other functions. For dummy arguments, the typing is done to
7653 this result, even if it has to be repeated for each call. */
7654 if (has_alternate_specifier
7655 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
7656 {
7657 if (!sym->attr.dummy)
7658 {
7659 TREE_TYPE (sym->backend_decl)
7660 = build_function_type (integer_type_node,
7661 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
7662 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
7663 }
7664 else
7665 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
7666 }
7667
7668 fntype = TREE_TYPE (TREE_TYPE (se->expr));
7669 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
7670
7671 /* Allocatable scalar function results must be freed and nullified
7672 after use. This necessitates the creation of a temporary to
7673 hold the result to prevent duplicate calls. */
7674 if (!byref && sym->ts.type != BT_CHARACTER
7675 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
7676 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
7677 {
7678 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
7679 gfc_add_modify (&se->pre, tmp, se->expr);
7680 se->expr = tmp;
7681 tmp = gfc_call_free (tmp);
7682 gfc_add_expr_to_block (&post, tmp);
7683 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
7684 }
7685
7686 /* If we have a pointer function, but we don't want a pointer, e.g.
7687 something like
7688 x = f()
7689 where f is pointer valued, we have to dereference the result. */
7690 if (!se->want_pointer && !byref
7691 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7692 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
7693 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7694
7695 /* f2c calling conventions require a scalar default real function to
7696 return a double precision result. Convert this back to default
7697 real. We only care about the cases that can happen in Fortran 77.
7698 */
7699 if (flag_f2c && sym->ts.type == BT_REAL
7700 && sym->ts.kind == gfc_default_real_kind
7701 && !sym->attr.always_explicit)
7702 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
7703
7704 /* A pure function may still have side-effects - it may modify its
7705 parameters. */
7706 TREE_SIDE_EFFECTS (se->expr) = 1;
7707 #if 0
7708 if (!sym->attr.pure)
7709 TREE_SIDE_EFFECTS (se->expr) = 1;
7710 #endif
7711
7712 if (byref)
7713 {
7714 /* Add the function call to the pre chain. There is no expression. */
7715 gfc_add_expr_to_block (&se->pre, se->expr);
7716 se->expr = NULL_TREE;
7717
7718 if (!se->direct_byref)
7719 {
7720 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
7721 {
7722 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
7723 {
7724 /* Check the data pointer hasn't been modified. This would
7725 happen in a function returning a pointer. */
7726 tmp = gfc_conv_descriptor_data_get (info->descriptor);
7727 tmp = fold_build2_loc (input_location, NE_EXPR,
7728 logical_type_node,
7729 tmp, info->data);
7730 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
7731 gfc_msg_fault);
7732 }
7733 se->expr = info->descriptor;
7734 /* Bundle in the string length. */
7735 se->string_length = len;
7736 }
7737 else if (ts.type == BT_CHARACTER)
7738 {
7739 /* Dereference for character pointer results. */
7740 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7741 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
7742 se->expr = build_fold_indirect_ref_loc (input_location, var);
7743 else
7744 se->expr = var;
7745
7746 se->string_length = len;
7747 }
7748 else
7749 {
7750 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
7751 se->expr = build_fold_indirect_ref_loc (input_location, var);
7752 }
7753 }
7754 }
7755
7756 /* Associate the rhs class object's meta-data with the result, when the
7757 result is a temporary. */
7758 if (args && args->expr && args->expr->ts.type == BT_CLASS
7759 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
7760 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
7761 {
7762 gfc_se parmse;
7763 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
7764
7765 gfc_init_se (&parmse, NULL);
7766 parmse.data_not_needed = 1;
7767 gfc_conv_expr (&parmse, class_expr);
7768 if (!DECL_LANG_SPECIFIC (result))
7769 gfc_allocate_lang_decl (result);
7770 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
7771 gfc_free_expr (class_expr);
7772 /* -fcheck= can add diagnostic code, which has to be placed before
7773 the call. */
7774 if (parmse.pre.head != NULL)
7775 gfc_add_expr_to_block (&se->pre, parmse.pre.head);
7776 gcc_assert (parmse.post.head == NULL_TREE);
7777 }
7778
7779 /* Follow the function call with the argument post block. */
7780 if (byref)
7781 {
7782 gfc_add_block_to_block (&se->pre, &post);
7783
7784 /* Transformational functions of derived types with allocatable
7785 components must have the result allocatable components copied when the
7786 argument is actually given. */
7787 arg = expr->value.function.actual;
7788 if (result && arg && expr->rank
7789 && expr->value.function.isym
7790 && expr->value.function.isym->transformational
7791 && arg->expr
7792 && arg->expr->ts.type == BT_DERIVED
7793 && arg->expr->ts.u.derived->attr.alloc_comp)
7794 {
7795 tree tmp2;
7796 /* Copy the allocatable components. We have to use a
7797 temporary here to prevent source allocatable components
7798 from being corrupted. */
7799 tmp2 = gfc_evaluate_now (result, &se->pre);
7800 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
7801 result, tmp2, expr->rank, 0);
7802 gfc_add_expr_to_block (&se->pre, tmp);
7803 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
7804 expr->rank);
7805 gfc_add_expr_to_block (&se->pre, tmp);
7806
7807 /* Finally free the temporary's data field. */
7808 tmp = gfc_conv_descriptor_data_get (tmp2);
7809 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7810 NULL_TREE, NULL_TREE, true,
7811 NULL, GFC_CAF_COARRAY_NOCOARRAY);
7812 gfc_add_expr_to_block (&se->pre, tmp);
7813 }
7814 }
7815 else
7816 {
7817 /* For a function with a class array result, save the result as
7818 a temporary, set the info fields needed by the scalarizer and
7819 call the finalization function of the temporary. Note that the
7820 nullification of allocatable components needed by the result
7821 is done in gfc_trans_assignment_1. */
7822 if (expr && ((gfc_is_class_array_function (expr)
7823 && se->ss && se->ss->loop)
7824 || gfc_is_alloc_class_scalar_function (expr))
7825 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
7826 && expr->must_finalize)
7827 {
7828 tree final_fndecl;
7829 tree is_final;
7830 int n;
7831 if (se->ss && se->ss->loop)
7832 {
7833 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
7834 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
7835 tmp = gfc_class_data_get (se->expr);
7836 info->descriptor = tmp;
7837 info->data = gfc_conv_descriptor_data_get (tmp);
7838 info->offset = gfc_conv_descriptor_offset_get (tmp);
7839 for (n = 0; n < se->ss->loop->dimen; n++)
7840 {
7841 tree dim = gfc_rank_cst[n];
7842 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
7843 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
7844 }
7845 }
7846 else
7847 {
7848 /* TODO Eliminate the doubling of temporaries. This
7849 one is necessary to ensure no memory leakage. */
7850 se->expr = gfc_evaluate_now (se->expr, &se->pre);
7851 tmp = gfc_class_data_get (se->expr);
7852 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
7853 CLASS_DATA (expr->value.function.esym->result)->attr);
7854 }
7855
7856 if ((gfc_is_class_array_function (expr)
7857 || gfc_is_alloc_class_scalar_function (expr))
7858 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
7859 goto no_finalization;
7860
7861 final_fndecl = gfc_class_vtab_final_get (se->expr);
7862 is_final = fold_build2_loc (input_location, NE_EXPR,
7863 logical_type_node,
7864 final_fndecl,
7865 fold_convert (TREE_TYPE (final_fndecl),
7866 null_pointer_node));
7867 final_fndecl = build_fold_indirect_ref_loc (input_location,
7868 final_fndecl);
7869 tmp = build_call_expr_loc (input_location,
7870 final_fndecl, 3,
7871 gfc_build_addr_expr (NULL, tmp),
7872 gfc_class_vtab_size_get (se->expr),
7873 boolean_false_node);
7874 tmp = fold_build3_loc (input_location, COND_EXPR,
7875 void_type_node, is_final, tmp,
7876 build_empty_stmt (input_location));
7877
7878 if (se->ss && se->ss->loop)
7879 {
7880 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
7881 tmp = fold_build2_loc (input_location, NE_EXPR,
7882 logical_type_node,
7883 info->data,
7884 fold_convert (TREE_TYPE (info->data),
7885 null_pointer_node));
7886 tmp = fold_build3_loc (input_location, COND_EXPR,
7887 void_type_node, tmp,
7888 gfc_call_free (info->data),
7889 build_empty_stmt (input_location));
7890 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
7891 }
7892 else
7893 {
7894 tree classdata;
7895 gfc_prepend_expr_to_block (&se->post, tmp);
7896 classdata = gfc_class_data_get (se->expr);
7897 tmp = fold_build2_loc (input_location, NE_EXPR,
7898 logical_type_node,
7899 classdata,
7900 fold_convert (TREE_TYPE (classdata),
7901 null_pointer_node));
7902 tmp = fold_build3_loc (input_location, COND_EXPR,
7903 void_type_node, tmp,
7904 gfc_call_free (classdata),
7905 build_empty_stmt (input_location));
7906 gfc_add_expr_to_block (&se->post, tmp);
7907 }
7908 }
7909
7910 no_finalization:
7911 gfc_add_block_to_block (&se->post, &post);
7912 }
7913
7914 return has_alternate_specifier;
7915 }
7916
7917
7918 /* Fill a character string with spaces. */
7919
7920 static tree
fill_with_spaces(tree start,tree type,tree size)7921 fill_with_spaces (tree start, tree type, tree size)
7922 {
7923 stmtblock_t block, loop;
7924 tree i, el, exit_label, cond, tmp;
7925
7926 /* For a simple char type, we can call memset(). */
7927 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
7928 return build_call_expr_loc (input_location,
7929 builtin_decl_explicit (BUILT_IN_MEMSET),
7930 3, start,
7931 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
7932 lang_hooks.to_target_charset (' ')),
7933 fold_convert (size_type_node, size));
7934
7935 /* Otherwise, we use a loop:
7936 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7937 *el = (type) ' ';
7938 */
7939
7940 /* Initialize variables. */
7941 gfc_init_block (&block);
7942 i = gfc_create_var (sizetype, "i");
7943 gfc_add_modify (&block, i, fold_convert (sizetype, size));
7944 el = gfc_create_var (build_pointer_type (type), "el");
7945 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
7946 exit_label = gfc_build_label_decl (NULL_TREE);
7947 TREE_USED (exit_label) = 1;
7948
7949
7950 /* Loop body. */
7951 gfc_init_block (&loop);
7952
7953 /* Exit condition. */
7954 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
7955 build_zero_cst (sizetype));
7956 tmp = build1_v (GOTO_EXPR, exit_label);
7957 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7958 build_empty_stmt (input_location));
7959 gfc_add_expr_to_block (&loop, tmp);
7960
7961 /* Assignment. */
7962 gfc_add_modify (&loop,
7963 fold_build1_loc (input_location, INDIRECT_REF, type, el),
7964 build_int_cst (type, lang_hooks.to_target_charset (' ')));
7965
7966 /* Increment loop variables. */
7967 gfc_add_modify (&loop, i,
7968 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
7969 TYPE_SIZE_UNIT (type)));
7970 gfc_add_modify (&loop, el,
7971 fold_build_pointer_plus_loc (input_location,
7972 el, TYPE_SIZE_UNIT (type)));
7973
7974 /* Making the loop... actually loop! */
7975 tmp = gfc_finish_block (&loop);
7976 tmp = build1_v (LOOP_EXPR, tmp);
7977 gfc_add_expr_to_block (&block, tmp);
7978
7979 /* The exit label. */
7980 tmp = build1_v (LABEL_EXPR, exit_label);
7981 gfc_add_expr_to_block (&block, tmp);
7982
7983
7984 return gfc_finish_block (&block);
7985 }
7986
7987
7988 /* Generate code to copy a string. */
7989
7990 void
gfc_trans_string_copy(stmtblock_t * block,tree dlength,tree dest,int dkind,tree slength,tree src,int skind)7991 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
7992 int dkind, tree slength, tree src, int skind)
7993 {
7994 tree tmp, dlen, slen;
7995 tree dsc;
7996 tree ssc;
7997 tree cond;
7998 tree cond2;
7999 tree tmp2;
8000 tree tmp3;
8001 tree tmp4;
8002 tree chartype;
8003 stmtblock_t tempblock;
8004
8005 gcc_assert (dkind == skind);
8006
8007 if (slength != NULL_TREE)
8008 {
8009 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
8010 ssc = gfc_string_to_single_character (slen, src, skind);
8011 }
8012 else
8013 {
8014 slen = build_one_cst (gfc_charlen_type_node);
8015 ssc = src;
8016 }
8017
8018 if (dlength != NULL_TREE)
8019 {
8020 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
8021 dsc = gfc_string_to_single_character (dlen, dest, dkind);
8022 }
8023 else
8024 {
8025 dlen = build_one_cst (gfc_charlen_type_node);
8026 dsc = dest;
8027 }
8028
8029 /* Assign directly if the types are compatible. */
8030 if (dsc != NULL_TREE && ssc != NULL_TREE
8031 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
8032 {
8033 gfc_add_modify (block, dsc, ssc);
8034 return;
8035 }
8036
8037 /* The string copy algorithm below generates code like
8038
8039 if (destlen > 0)
8040 {
8041 if (srclen < destlen)
8042 {
8043 memmove (dest, src, srclen);
8044 // Pad with spaces.
8045 memset (&dest[srclen], ' ', destlen - srclen);
8046 }
8047 else
8048 {
8049 // Truncate if too long.
8050 memmove (dest, src, destlen);
8051 }
8052 }
8053 */
8054
8055 /* Do nothing if the destination length is zero. */
8056 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
8057 build_zero_cst (TREE_TYPE (dlen)));
8058
8059 /* For non-default character kinds, we have to multiply the string
8060 length by the base type size. */
8061 chartype = gfc_get_char_type (dkind);
8062 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
8063 slen,
8064 fold_convert (TREE_TYPE (slen),
8065 TYPE_SIZE_UNIT (chartype)));
8066 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
8067 dlen,
8068 fold_convert (TREE_TYPE (dlen),
8069 TYPE_SIZE_UNIT (chartype)));
8070
8071 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
8072 dest = fold_convert (pvoid_type_node, dest);
8073 else
8074 dest = gfc_build_addr_expr (pvoid_type_node, dest);
8075
8076 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
8077 src = fold_convert (pvoid_type_node, src);
8078 else
8079 src = gfc_build_addr_expr (pvoid_type_node, src);
8080
8081 /* Truncate string if source is too long. */
8082 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
8083 dlen);
8084
8085 /* Copy and pad with spaces. */
8086 tmp3 = build_call_expr_loc (input_location,
8087 builtin_decl_explicit (BUILT_IN_MEMMOVE),
8088 3, dest, src,
8089 fold_convert (size_type_node, slen));
8090
8091 /* Wstringop-overflow appears at -O3 even though this warning is not
8092 explicitly available in fortran nor can it be switched off. If the
8093 source length is a constant, its negative appears as a very large
8094 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
8095 the result of the MINUS_EXPR suppresses this spurious warning. */
8096 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8097 TREE_TYPE(dlen), dlen, slen);
8098 if (slength && TREE_CONSTANT (slength))
8099 tmp = gfc_evaluate_now (tmp, block);
8100
8101 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
8102 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
8103
8104 gfc_init_block (&tempblock);
8105 gfc_add_expr_to_block (&tempblock, tmp3);
8106 gfc_add_expr_to_block (&tempblock, tmp4);
8107 tmp3 = gfc_finish_block (&tempblock);
8108
8109 /* The truncated memmove if the slen >= dlen. */
8110 tmp2 = build_call_expr_loc (input_location,
8111 builtin_decl_explicit (BUILT_IN_MEMMOVE),
8112 3, dest, src,
8113 fold_convert (size_type_node, dlen));
8114
8115 /* The whole copy_string function is there. */
8116 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
8117 tmp3, tmp2);
8118 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8119 build_empty_stmt (input_location));
8120 gfc_add_expr_to_block (block, tmp);
8121 }
8122
8123
8124 /* Translate a statement function.
8125 The value of a statement function reference is obtained by evaluating the
8126 expression using the values of the actual arguments for the values of the
8127 corresponding dummy arguments. */
8128
8129 static void
gfc_conv_statement_function(gfc_se * se,gfc_expr * expr)8130 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
8131 {
8132 gfc_symbol *sym;
8133 gfc_symbol *fsym;
8134 gfc_formal_arglist *fargs;
8135 gfc_actual_arglist *args;
8136 gfc_se lse;
8137 gfc_se rse;
8138 gfc_saved_var *saved_vars;
8139 tree *temp_vars;
8140 tree type;
8141 tree tmp;
8142 int n;
8143
8144 sym = expr->symtree->n.sym;
8145 args = expr->value.function.actual;
8146 gfc_init_se (&lse, NULL);
8147 gfc_init_se (&rse, NULL);
8148
8149 n = 0;
8150 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
8151 n++;
8152 saved_vars = XCNEWVEC (gfc_saved_var, n);
8153 temp_vars = XCNEWVEC (tree, n);
8154
8155 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8156 fargs = fargs->next, n++)
8157 {
8158 /* Each dummy shall be specified, explicitly or implicitly, to be
8159 scalar. */
8160 gcc_assert (fargs->sym->attr.dimension == 0);
8161 fsym = fargs->sym;
8162
8163 if (fsym->ts.type == BT_CHARACTER)
8164 {
8165 /* Copy string arguments. */
8166 tree arglen;
8167
8168 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
8169 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
8170
8171 /* Create a temporary to hold the value. */
8172 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
8173 fsym->ts.u.cl->backend_decl
8174 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
8175
8176 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
8177 temp_vars[n] = gfc_create_var (type, fsym->name);
8178
8179 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
8180
8181 gfc_conv_expr (&rse, args->expr);
8182 gfc_conv_string_parameter (&rse);
8183 gfc_add_block_to_block (&se->pre, &lse.pre);
8184 gfc_add_block_to_block (&se->pre, &rse.pre);
8185
8186 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
8187 rse.string_length, rse.expr, fsym->ts.kind);
8188 gfc_add_block_to_block (&se->pre, &lse.post);
8189 gfc_add_block_to_block (&se->pre, &rse.post);
8190 }
8191 else
8192 {
8193 /* For everything else, just evaluate the expression. */
8194
8195 /* Create a temporary to hold the value. */
8196 type = gfc_typenode_for_spec (&fsym->ts);
8197 temp_vars[n] = gfc_create_var (type, fsym->name);
8198
8199 gfc_conv_expr (&lse, args->expr);
8200
8201 gfc_add_block_to_block (&se->pre, &lse.pre);
8202 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
8203 gfc_add_block_to_block (&se->pre, &lse.post);
8204 }
8205
8206 args = args->next;
8207 }
8208
8209 /* Use the temporary variables in place of the real ones. */
8210 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8211 fargs = fargs->next, n++)
8212 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
8213
8214 gfc_conv_expr (se, sym->value);
8215
8216 if (sym->ts.type == BT_CHARACTER)
8217 {
8218 gfc_conv_const_charlen (sym->ts.u.cl);
8219
8220 /* Force the expression to the correct length. */
8221 if (!INTEGER_CST_P (se->string_length)
8222 || tree_int_cst_lt (se->string_length,
8223 sym->ts.u.cl->backend_decl))
8224 {
8225 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
8226 tmp = gfc_create_var (type, sym->name);
8227 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
8228 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
8229 sym->ts.kind, se->string_length, se->expr,
8230 sym->ts.kind);
8231 se->expr = tmp;
8232 }
8233 se->string_length = sym->ts.u.cl->backend_decl;
8234 }
8235
8236 /* Restore the original variables. */
8237 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8238 fargs = fargs->next, n++)
8239 gfc_restore_sym (fargs->sym, &saved_vars[n]);
8240 free (temp_vars);
8241 free (saved_vars);
8242 }
8243
8244
8245 /* Translate a function expression. */
8246
8247 static void
gfc_conv_function_expr(gfc_se * se,gfc_expr * expr)8248 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
8249 {
8250 gfc_symbol *sym;
8251
8252 if (expr->value.function.isym)
8253 {
8254 gfc_conv_intrinsic_function (se, expr);
8255 return;
8256 }
8257
8258 /* expr.value.function.esym is the resolved (specific) function symbol for
8259 most functions. However this isn't set for dummy procedures. */
8260 sym = expr->value.function.esym;
8261 if (!sym)
8262 sym = expr->symtree->n.sym;
8263
8264 /* The IEEE_ARITHMETIC functions are caught here. */
8265 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
8266 if (gfc_conv_ieee_arithmetic_function (se, expr))
8267 return;
8268
8269 /* We distinguish statement functions from general functions to improve
8270 runtime performance. */
8271 if (sym->attr.proc == PROC_ST_FUNCTION)
8272 {
8273 gfc_conv_statement_function (se, expr);
8274 return;
8275 }
8276
8277 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
8278 NULL);
8279 }
8280
8281
8282 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
8283
8284 static bool
is_zero_initializer_p(gfc_expr * expr)8285 is_zero_initializer_p (gfc_expr * expr)
8286 {
8287 if (expr->expr_type != EXPR_CONSTANT)
8288 return false;
8289
8290 /* We ignore constants with prescribed memory representations for now. */
8291 if (expr->representation.string)
8292 return false;
8293
8294 switch (expr->ts.type)
8295 {
8296 case BT_INTEGER:
8297 return mpz_cmp_si (expr->value.integer, 0) == 0;
8298
8299 case BT_REAL:
8300 return mpfr_zero_p (expr->value.real)
8301 && MPFR_SIGN (expr->value.real) >= 0;
8302
8303 case BT_LOGICAL:
8304 return expr->value.logical == 0;
8305
8306 case BT_COMPLEX:
8307 return mpfr_zero_p (mpc_realref (expr->value.complex))
8308 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
8309 && mpfr_zero_p (mpc_imagref (expr->value.complex))
8310 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
8311
8312 default:
8313 break;
8314 }
8315 return false;
8316 }
8317
8318
8319 static void
gfc_conv_array_constructor_expr(gfc_se * se,gfc_expr * expr)8320 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
8321 {
8322 gfc_ss *ss;
8323
8324 ss = se->ss;
8325 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
8326 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
8327
8328 gfc_conv_tmp_array_ref (se);
8329 }
8330
8331
8332 /* Build a static initializer. EXPR is the expression for the initial value.
8333 The other parameters describe the variable of the component being
8334 initialized. EXPR may be null. */
8335
8336 tree
gfc_conv_initializer(gfc_expr * expr,gfc_typespec * ts,tree type,bool array,bool pointer,bool procptr)8337 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
8338 bool array, bool pointer, bool procptr)
8339 {
8340 gfc_se se;
8341
8342 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
8343 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
8344 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
8345 return build_constructor (type, NULL);
8346
8347 if (!(expr || pointer || procptr))
8348 return NULL_TREE;
8349
8350 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
8351 (these are the only two iso_c_binding derived types that can be
8352 used as initialization expressions). If so, we need to modify
8353 the 'expr' to be that for a (void *). */
8354 if (expr != NULL && expr->ts.type == BT_DERIVED
8355 && expr->ts.is_iso_c && expr->ts.u.derived)
8356 {
8357 if (TREE_CODE (type) == ARRAY_TYPE)
8358 return build_constructor (type, NULL);
8359 else if (POINTER_TYPE_P (type))
8360 return build_int_cst (type, 0);
8361 else
8362 gcc_unreachable ();
8363 }
8364
8365 if (array && !procptr)
8366 {
8367 tree ctor;
8368 /* Arrays need special handling. */
8369 if (pointer)
8370 ctor = gfc_build_null_descriptor (type);
8371 /* Special case assigning an array to zero. */
8372 else if (is_zero_initializer_p (expr))
8373 ctor = build_constructor (type, NULL);
8374 else
8375 ctor = gfc_conv_array_initializer (type, expr);
8376 TREE_STATIC (ctor) = 1;
8377 return ctor;
8378 }
8379 else if (pointer || procptr)
8380 {
8381 if (ts->type == BT_CLASS && !procptr)
8382 {
8383 gfc_init_se (&se, NULL);
8384 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
8385 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
8386 TREE_STATIC (se.expr) = 1;
8387 return se.expr;
8388 }
8389 else if (!expr || expr->expr_type == EXPR_NULL)
8390 return fold_convert (type, null_pointer_node);
8391 else
8392 {
8393 gfc_init_se (&se, NULL);
8394 se.want_pointer = 1;
8395 gfc_conv_expr (&se, expr);
8396 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8397 return se.expr;
8398 }
8399 }
8400 else
8401 {
8402 switch (ts->type)
8403 {
8404 case_bt_struct:
8405 case BT_CLASS:
8406 gfc_init_se (&se, NULL);
8407 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
8408 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
8409 else
8410 gfc_conv_structure (&se, expr, 1);
8411 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
8412 TREE_STATIC (se.expr) = 1;
8413 return se.expr;
8414
8415 case BT_CHARACTER:
8416 if (expr->expr_type == EXPR_CONSTANT)
8417 {
8418 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
8419 TREE_STATIC (ctor) = 1;
8420 return ctor;
8421 }
8422
8423 /* Fallthrough. */
8424 default:
8425 gfc_init_se (&se, NULL);
8426 gfc_conv_constant (&se, expr);
8427 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8428 return se.expr;
8429 }
8430 }
8431 }
8432
8433 static tree
gfc_trans_subarray_assign(tree dest,gfc_component * cm,gfc_expr * expr)8434 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
8435 {
8436 gfc_se rse;
8437 gfc_se lse;
8438 gfc_ss *rss;
8439 gfc_ss *lss;
8440 gfc_array_info *lss_array;
8441 stmtblock_t body;
8442 stmtblock_t block;
8443 gfc_loopinfo loop;
8444 int n;
8445 tree tmp;
8446
8447 gfc_start_block (&block);
8448
8449 /* Initialize the scalarizer. */
8450 gfc_init_loopinfo (&loop);
8451
8452 gfc_init_se (&lse, NULL);
8453 gfc_init_se (&rse, NULL);
8454
8455 /* Walk the rhs. */
8456 rss = gfc_walk_expr (expr);
8457 if (rss == gfc_ss_terminator)
8458 /* The rhs is scalar. Add a ss for the expression. */
8459 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
8460
8461 /* Create a SS for the destination. */
8462 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
8463 GFC_SS_COMPONENT);
8464 lss_array = &lss->info->data.array;
8465 lss_array->shape = gfc_get_shape (cm->as->rank);
8466 lss_array->descriptor = dest;
8467 lss_array->data = gfc_conv_array_data (dest);
8468 lss_array->offset = gfc_conv_array_offset (dest);
8469 for (n = 0; n < cm->as->rank; n++)
8470 {
8471 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
8472 lss_array->stride[n] = gfc_index_one_node;
8473
8474 mpz_init (lss_array->shape[n]);
8475 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
8476 cm->as->lower[n]->value.integer);
8477 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
8478 }
8479
8480 /* Associate the SS with the loop. */
8481 gfc_add_ss_to_loop (&loop, lss);
8482 gfc_add_ss_to_loop (&loop, rss);
8483
8484 /* Calculate the bounds of the scalarization. */
8485 gfc_conv_ss_startstride (&loop);
8486
8487 /* Setup the scalarizing loops. */
8488 gfc_conv_loop_setup (&loop, &expr->where);
8489
8490 /* Setup the gfc_se structures. */
8491 gfc_copy_loopinfo_to_se (&lse, &loop);
8492 gfc_copy_loopinfo_to_se (&rse, &loop);
8493
8494 rse.ss = rss;
8495 gfc_mark_ss_chain_used (rss, 1);
8496 lse.ss = lss;
8497 gfc_mark_ss_chain_used (lss, 1);
8498
8499 /* Start the scalarized loop body. */
8500 gfc_start_scalarized_body (&loop, &body);
8501
8502 gfc_conv_tmp_array_ref (&lse);
8503 if (cm->ts.type == BT_CHARACTER)
8504 lse.string_length = cm->ts.u.cl->backend_decl;
8505
8506 gfc_conv_expr (&rse, expr);
8507
8508 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
8509 gfc_add_expr_to_block (&body, tmp);
8510
8511 gcc_assert (rse.ss == gfc_ss_terminator);
8512
8513 /* Generate the copying loops. */
8514 gfc_trans_scalarizing_loops (&loop, &body);
8515
8516 /* Wrap the whole thing up. */
8517 gfc_add_block_to_block (&block, &loop.pre);
8518 gfc_add_block_to_block (&block, &loop.post);
8519
8520 gcc_assert (lss_array->shape != NULL);
8521 gfc_free_shape (&lss_array->shape, cm->as->rank);
8522 gfc_cleanup_loop (&loop);
8523
8524 return gfc_finish_block (&block);
8525 }
8526
8527
8528 static tree
gfc_trans_alloc_subarray_assign(tree dest,gfc_component * cm,gfc_expr * expr)8529 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
8530 gfc_expr * expr)
8531 {
8532 gfc_se se;
8533 stmtblock_t block;
8534 tree offset;
8535 int n;
8536 tree tmp;
8537 tree tmp2;
8538 gfc_array_spec *as;
8539 gfc_expr *arg = NULL;
8540
8541 gfc_start_block (&block);
8542 gfc_init_se (&se, NULL);
8543
8544 /* Get the descriptor for the expressions. */
8545 se.want_pointer = 0;
8546 gfc_conv_expr_descriptor (&se, expr);
8547 gfc_add_block_to_block (&block, &se.pre);
8548 gfc_add_modify (&block, dest, se.expr);
8549
8550 /* Deal with arrays of derived types with allocatable components. */
8551 if (gfc_bt_struct (cm->ts.type)
8552 && cm->ts.u.derived->attr.alloc_comp)
8553 // TODO: Fix caf_mode
8554 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
8555 se.expr, dest,
8556 cm->as->rank, 0);
8557 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
8558 && CLASS_DATA(cm)->attr.allocatable)
8559 {
8560 if (cm->ts.u.derived->attr.alloc_comp)
8561 // TODO: Fix caf_mode
8562 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
8563 se.expr, dest,
8564 expr->rank, 0);
8565 else
8566 {
8567 tmp = TREE_TYPE (dest);
8568 tmp = gfc_duplicate_allocatable (dest, se.expr,
8569 tmp, expr->rank, NULL_TREE);
8570 }
8571 }
8572 else
8573 tmp = gfc_duplicate_allocatable (dest, se.expr,
8574 TREE_TYPE(cm->backend_decl),
8575 cm->as->rank, NULL_TREE);
8576
8577 gfc_add_expr_to_block (&block, tmp);
8578 gfc_add_block_to_block (&block, &se.post);
8579
8580 if (expr->expr_type != EXPR_VARIABLE)
8581 gfc_conv_descriptor_data_set (&block, se.expr,
8582 null_pointer_node);
8583
8584 /* We need to know if the argument of a conversion function is a
8585 variable, so that the correct lower bound can be used. */
8586 if (expr->expr_type == EXPR_FUNCTION
8587 && expr->value.function.isym
8588 && expr->value.function.isym->conversion
8589 && expr->value.function.actual->expr
8590 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
8591 arg = expr->value.function.actual->expr;
8592
8593 /* Obtain the array spec of full array references. */
8594 if (arg)
8595 as = gfc_get_full_arrayspec_from_expr (arg);
8596 else
8597 as = gfc_get_full_arrayspec_from_expr (expr);
8598
8599 /* Shift the lbound and ubound of temporaries to being unity,
8600 rather than zero, based. Always calculate the offset. */
8601 offset = gfc_conv_descriptor_offset_get (dest);
8602 gfc_add_modify (&block, offset, gfc_index_zero_node);
8603 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
8604
8605 for (n = 0; n < expr->rank; n++)
8606 {
8607 tree span;
8608 tree lbound;
8609
8610 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8611 TODO It looks as if gfc_conv_expr_descriptor should return
8612 the correct bounds and that the following should not be
8613 necessary. This would simplify gfc_conv_intrinsic_bound
8614 as well. */
8615 if (as && as->lower[n])
8616 {
8617 gfc_se lbse;
8618 gfc_init_se (&lbse, NULL);
8619 gfc_conv_expr (&lbse, as->lower[n]);
8620 gfc_add_block_to_block (&block, &lbse.pre);
8621 lbound = gfc_evaluate_now (lbse.expr, &block);
8622 }
8623 else if (as && arg)
8624 {
8625 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
8626 lbound = gfc_conv_descriptor_lbound_get (tmp,
8627 gfc_rank_cst[n]);
8628 }
8629 else if (as)
8630 lbound = gfc_conv_descriptor_lbound_get (dest,
8631 gfc_rank_cst[n]);
8632 else
8633 lbound = gfc_index_one_node;
8634
8635 lbound = fold_convert (gfc_array_index_type, lbound);
8636
8637 /* Shift the bounds and set the offset accordingly. */
8638 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
8639 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8640 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
8641 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8642 span, lbound);
8643 gfc_conv_descriptor_ubound_set (&block, dest,
8644 gfc_rank_cst[n], tmp);
8645 gfc_conv_descriptor_lbound_set (&block, dest,
8646 gfc_rank_cst[n], lbound);
8647
8648 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8649 gfc_conv_descriptor_lbound_get (dest,
8650 gfc_rank_cst[n]),
8651 gfc_conv_descriptor_stride_get (dest,
8652 gfc_rank_cst[n]));
8653 gfc_add_modify (&block, tmp2, tmp);
8654 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8655 offset, tmp2);
8656 gfc_conv_descriptor_offset_set (&block, dest, tmp);
8657 }
8658
8659 if (arg)
8660 {
8661 /* If a conversion expression has a null data pointer
8662 argument, nullify the allocatable component. */
8663 tree non_null_expr;
8664 tree null_expr;
8665
8666 if (arg->symtree->n.sym->attr.allocatable
8667 || arg->symtree->n.sym->attr.pointer)
8668 {
8669 non_null_expr = gfc_finish_block (&block);
8670 gfc_start_block (&block);
8671 gfc_conv_descriptor_data_set (&block, dest,
8672 null_pointer_node);
8673 null_expr = gfc_finish_block (&block);
8674 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
8675 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
8676 fold_convert (TREE_TYPE (tmp), null_pointer_node));
8677 return build3_v (COND_EXPR, tmp,
8678 null_expr, non_null_expr);
8679 }
8680 }
8681
8682 return gfc_finish_block (&block);
8683 }
8684
8685
8686 /* Allocate or reallocate scalar component, as necessary. */
8687
8688 static void
alloc_scalar_allocatable_for_subcomponent_assignment(stmtblock_t * block,tree comp,gfc_component * cm,gfc_expr * expr2,gfc_symbol * sym)8689 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
8690 tree comp,
8691 gfc_component *cm,
8692 gfc_expr *expr2,
8693 gfc_symbol *sym)
8694 {
8695 tree tmp;
8696 tree ptr;
8697 tree size;
8698 tree size_in_bytes;
8699 tree lhs_cl_size = NULL_TREE;
8700
8701 if (!comp)
8702 return;
8703
8704 if (!expr2 || expr2->rank)
8705 return;
8706
8707 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
8708
8709 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8710 {
8711 char name[GFC_MAX_SYMBOL_LEN+9];
8712 gfc_component *strlen;
8713 /* Use the rhs string length and the lhs element size. */
8714 gcc_assert (expr2->ts.type == BT_CHARACTER);
8715 if (!expr2->ts.u.cl->backend_decl)
8716 {
8717 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
8718 gcc_assert (expr2->ts.u.cl->backend_decl);
8719 }
8720
8721 size = expr2->ts.u.cl->backend_decl;
8722
8723 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
8724 component. */
8725 sprintf (name, "_%s_length", cm->name);
8726 strlen = gfc_find_component (sym, name, true, true, NULL);
8727 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
8728 gfc_charlen_type_node,
8729 TREE_OPERAND (comp, 0),
8730 strlen->backend_decl, NULL_TREE);
8731
8732 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
8733 tmp = TYPE_SIZE_UNIT (tmp);
8734 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
8735 TREE_TYPE (tmp), tmp,
8736 fold_convert (TREE_TYPE (tmp), size));
8737 }
8738 else if (cm->ts.type == BT_CLASS)
8739 {
8740 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
8741 if (expr2->ts.type == BT_DERIVED)
8742 {
8743 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
8744 size = TYPE_SIZE_UNIT (tmp);
8745 }
8746 else
8747 {
8748 gfc_expr *e2vtab;
8749 gfc_se se;
8750 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
8751 gfc_add_vptr_component (e2vtab);
8752 gfc_add_size_component (e2vtab);
8753 gfc_init_se (&se, NULL);
8754 gfc_conv_expr (&se, e2vtab);
8755 gfc_add_block_to_block (block, &se.pre);
8756 size = fold_convert (size_type_node, se.expr);
8757 gfc_free_expr (e2vtab);
8758 }
8759 size_in_bytes = size;
8760 }
8761 else
8762 {
8763 /* Otherwise use the length in bytes of the rhs. */
8764 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
8765 size_in_bytes = size;
8766 }
8767
8768 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
8769 size_in_bytes, size_one_node);
8770
8771 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
8772 {
8773 tmp = build_call_expr_loc (input_location,
8774 builtin_decl_explicit (BUILT_IN_CALLOC),
8775 2, build_one_cst (size_type_node),
8776 size_in_bytes);
8777 tmp = fold_convert (TREE_TYPE (comp), tmp);
8778 gfc_add_modify (block, comp, tmp);
8779 }
8780 else
8781 {
8782 tmp = build_call_expr_loc (input_location,
8783 builtin_decl_explicit (BUILT_IN_MALLOC),
8784 1, size_in_bytes);
8785 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
8786 ptr = gfc_class_data_get (comp);
8787 else
8788 ptr = comp;
8789 tmp = fold_convert (TREE_TYPE (ptr), tmp);
8790 gfc_add_modify (block, ptr, tmp);
8791 }
8792
8793 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8794 /* Update the lhs character length. */
8795 gfc_add_modify (block, lhs_cl_size,
8796 fold_convert (TREE_TYPE (lhs_cl_size), size));
8797 }
8798
8799
8800 /* Assign a single component of a derived type constructor. */
8801
8802 static tree
gfc_trans_subcomponent_assign(tree dest,gfc_component * cm,gfc_expr * expr,gfc_symbol * sym,bool init)8803 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
8804 gfc_symbol *sym, bool init)
8805 {
8806 gfc_se se;
8807 gfc_se lse;
8808 stmtblock_t block;
8809 tree tmp;
8810 tree vtab;
8811
8812 gfc_start_block (&block);
8813
8814 if (cm->attr.pointer || cm->attr.proc_pointer)
8815 {
8816 /* Only care about pointers here, not about allocatables. */
8817 gfc_init_se (&se, NULL);
8818 /* Pointer component. */
8819 if ((cm->attr.dimension || cm->attr.codimension)
8820 && !cm->attr.proc_pointer)
8821 {
8822 /* Array pointer. */
8823 if (expr->expr_type == EXPR_NULL)
8824 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8825 else
8826 {
8827 se.direct_byref = 1;
8828 se.expr = dest;
8829 gfc_conv_expr_descriptor (&se, expr);
8830 gfc_add_block_to_block (&block, &se.pre);
8831 gfc_add_block_to_block (&block, &se.post);
8832 }
8833 }
8834 else
8835 {
8836 /* Scalar pointers. */
8837 se.want_pointer = 1;
8838 gfc_conv_expr (&se, expr);
8839 gfc_add_block_to_block (&block, &se.pre);
8840
8841 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8842 && expr->symtree->n.sym->attr.dummy)
8843 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8844
8845 gfc_add_modify (&block, dest,
8846 fold_convert (TREE_TYPE (dest), se.expr));
8847 gfc_add_block_to_block (&block, &se.post);
8848 }
8849 }
8850 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
8851 {
8852 /* NULL initialization for CLASS components. */
8853 tmp = gfc_trans_structure_assign (dest,
8854 gfc_class_initializer (&cm->ts, expr),
8855 false);
8856 gfc_add_expr_to_block (&block, tmp);
8857 }
8858 else if ((cm->attr.dimension || cm->attr.codimension)
8859 && !cm->attr.proc_pointer)
8860 {
8861 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8862 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8863 else if (cm->attr.allocatable || cm->attr.pdt_array)
8864 {
8865 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
8866 gfc_add_expr_to_block (&block, tmp);
8867 }
8868 else
8869 {
8870 tmp = gfc_trans_subarray_assign (dest, cm, expr);
8871 gfc_add_expr_to_block (&block, tmp);
8872 }
8873 }
8874 else if (cm->ts.type == BT_CLASS
8875 && CLASS_DATA (cm)->attr.dimension
8876 && CLASS_DATA (cm)->attr.allocatable
8877 && expr->ts.type == BT_DERIVED)
8878 {
8879 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8880 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8881 tmp = gfc_class_vptr_get (dest);
8882 gfc_add_modify (&block, tmp,
8883 fold_convert (TREE_TYPE (tmp), vtab));
8884 tmp = gfc_class_data_get (dest);
8885 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
8886 gfc_add_expr_to_block (&block, tmp);
8887 }
8888 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8889 {
8890 /* NULL initialization for allocatable components. */
8891 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
8892 null_pointer_node));
8893 }
8894 else if (init && (cm->attr.allocatable
8895 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
8896 && expr->ts.type != BT_CLASS)))
8897 {
8898 /* Take care about non-array allocatable components here. The alloc_*
8899 routine below is motivated by the alloc_scalar_allocatable_for_
8900 assignment() routine, but with the realloc portions removed and
8901 different input. */
8902 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
8903 dest,
8904 cm,
8905 expr,
8906 sym);
8907 /* The remainder of these instructions follow the if (cm->attr.pointer)
8908 if (!cm->attr.dimension) part above. */
8909 gfc_init_se (&se, NULL);
8910 gfc_conv_expr (&se, expr);
8911 gfc_add_block_to_block (&block, &se.pre);
8912
8913 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8914 && expr->symtree->n.sym->attr.dummy)
8915 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8916
8917 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
8918 {
8919 tmp = gfc_class_data_get (dest);
8920 tmp = build_fold_indirect_ref_loc (input_location, tmp);
8921 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8922 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8923 gfc_add_modify (&block, gfc_class_vptr_get (dest),
8924 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
8925 }
8926 else
8927 tmp = build_fold_indirect_ref_loc (input_location, dest);
8928
8929 /* For deferred strings insert a memcpy. */
8930 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8931 {
8932 tree size;
8933 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
8934 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
8935 ? se.string_length
8936 : expr->ts.u.cl->backend_decl);
8937 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
8938 gfc_add_expr_to_block (&block, tmp);
8939 }
8940 else
8941 gfc_add_modify (&block, tmp,
8942 fold_convert (TREE_TYPE (tmp), se.expr));
8943 gfc_add_block_to_block (&block, &se.post);
8944 }
8945 else if (expr->ts.type == BT_UNION)
8946 {
8947 tree tmp;
8948 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
8949 /* We mark that the entire union should be initialized with a contrived
8950 EXPR_NULL expression at the beginning. */
8951 if (c != NULL && c->n.component == NULL
8952 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
8953 {
8954 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8955 dest, build_constructor (TREE_TYPE (dest), NULL));
8956 gfc_add_expr_to_block (&block, tmp);
8957 c = gfc_constructor_next (c);
8958 }
8959 /* The following constructor expression, if any, represents a specific
8960 map intializer, as given by the user. */
8961 if (c != NULL && c->expr != NULL)
8962 {
8963 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8964 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8965 gfc_add_expr_to_block (&block, tmp);
8966 }
8967 }
8968 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
8969 {
8970 if (expr->expr_type != EXPR_STRUCTURE)
8971 {
8972 tree dealloc = NULL_TREE;
8973 gfc_init_se (&se, NULL);
8974 gfc_conv_expr (&se, expr);
8975 gfc_add_block_to_block (&block, &se.pre);
8976 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8977 expression in a temporary variable and deallocate the allocatable
8978 components. Then we can the copy the expression to the result. */
8979 if (cm->ts.u.derived->attr.alloc_comp
8980 && expr->expr_type != EXPR_VARIABLE)
8981 {
8982 se.expr = gfc_evaluate_now (se.expr, &block);
8983 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
8984 expr->rank);
8985 }
8986 gfc_add_modify (&block, dest,
8987 fold_convert (TREE_TYPE (dest), se.expr));
8988 if (cm->ts.u.derived->attr.alloc_comp
8989 && expr->expr_type != EXPR_NULL)
8990 {
8991 // TODO: Fix caf_mode
8992 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
8993 dest, expr->rank, 0);
8994 gfc_add_expr_to_block (&block, tmp);
8995 if (dealloc != NULL_TREE)
8996 gfc_add_expr_to_block (&block, dealloc);
8997 }
8998 gfc_add_block_to_block (&block, &se.post);
8999 }
9000 else
9001 {
9002 /* Nested constructors. */
9003 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
9004 gfc_add_expr_to_block (&block, tmp);
9005 }
9006 }
9007 else if (gfc_deferred_strlen (cm, &tmp))
9008 {
9009 tree strlen;
9010 strlen = tmp;
9011 gcc_assert (strlen);
9012 strlen = fold_build3_loc (input_location, COMPONENT_REF,
9013 TREE_TYPE (strlen),
9014 TREE_OPERAND (dest, 0),
9015 strlen, NULL_TREE);
9016
9017 if (expr->expr_type == EXPR_NULL)
9018 {
9019 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
9020 gfc_add_modify (&block, dest, tmp);
9021 tmp = build_int_cst (TREE_TYPE (strlen), 0);
9022 gfc_add_modify (&block, strlen, tmp);
9023 }
9024 else
9025 {
9026 tree size;
9027 gfc_init_se (&se, NULL);
9028 gfc_conv_expr (&se, expr);
9029 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
9030 tmp = build_call_expr_loc (input_location,
9031 builtin_decl_explicit (BUILT_IN_MALLOC),
9032 1, size);
9033 gfc_add_modify (&block, dest,
9034 fold_convert (TREE_TYPE (dest), tmp));
9035 gfc_add_modify (&block, strlen,
9036 fold_convert (TREE_TYPE (strlen), se.string_length));
9037 tmp = gfc_build_memcpy_call (dest, se.expr, size);
9038 gfc_add_expr_to_block (&block, tmp);
9039 }
9040 }
9041 else if (!cm->attr.artificial)
9042 {
9043 /* Scalar component (excluding deferred parameters). */
9044 gfc_init_se (&se, NULL);
9045 gfc_init_se (&lse, NULL);
9046
9047 gfc_conv_expr (&se, expr);
9048 if (cm->ts.type == BT_CHARACTER)
9049 lse.string_length = cm->ts.u.cl->backend_decl;
9050 lse.expr = dest;
9051 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
9052 gfc_add_expr_to_block (&block, tmp);
9053 }
9054 return gfc_finish_block (&block);
9055 }
9056
9057 /* Assign a derived type constructor to a variable. */
9058
9059 tree
gfc_trans_structure_assign(tree dest,gfc_expr * expr,bool init,bool coarray)9060 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
9061 {
9062 gfc_constructor *c;
9063 gfc_component *cm;
9064 stmtblock_t block;
9065 tree field;
9066 tree tmp;
9067 gfc_se se;
9068
9069 gfc_start_block (&block);
9070
9071 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
9072 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
9073 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
9074 {
9075 gfc_se lse;
9076
9077 gfc_init_se (&se, NULL);
9078 gfc_init_se (&lse, NULL);
9079 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
9080 lse.expr = dest;
9081 gfc_add_modify (&block, lse.expr,
9082 fold_convert (TREE_TYPE (lse.expr), se.expr));
9083
9084 return gfc_finish_block (&block);
9085 }
9086
9087 /* Make sure that the derived type has been completely built. */
9088 if (!expr->ts.u.derived->backend_decl
9089 || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
9090 {
9091 tmp = gfc_typenode_for_spec (&expr->ts);
9092 gcc_assert (tmp);
9093 }
9094
9095 cm = expr->ts.u.derived->components;
9096
9097
9098 if (coarray)
9099 gfc_init_se (&se, NULL);
9100
9101 for (c = gfc_constructor_first (expr->value.constructor);
9102 c; c = gfc_constructor_next (c), cm = cm->next)
9103 {
9104 /* Skip absent members in default initializers. */
9105 if (!c->expr && !cm->attr.allocatable)
9106 continue;
9107
9108 /* Register the component with the caf-lib before it is initialized.
9109 Register only allocatable components, that are not coarray'ed
9110 components (%comp[*]). Only register when the constructor is not the
9111 null-expression. */
9112 if (coarray && !cm->attr.codimension
9113 && (cm->attr.allocatable || cm->attr.pointer)
9114 && (!c->expr || c->expr->expr_type == EXPR_NULL))
9115 {
9116 tree token, desc, size;
9117 bool is_array = cm->ts.type == BT_CLASS
9118 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
9119
9120 field = cm->backend_decl;
9121 field = fold_build3_loc (input_location, COMPONENT_REF,
9122 TREE_TYPE (field), dest, field, NULL_TREE);
9123 if (cm->ts.type == BT_CLASS)
9124 field = gfc_class_data_get (field);
9125
9126 token = is_array ? gfc_conv_descriptor_token (field)
9127 : fold_build3_loc (input_location, COMPONENT_REF,
9128 TREE_TYPE (cm->caf_token), dest,
9129 cm->caf_token, NULL_TREE);
9130
9131 if (is_array)
9132 {
9133 /* The _caf_register routine looks at the rank of the array
9134 descriptor to decide whether the data registered is an array
9135 or not. */
9136 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
9137 : cm->as->rank;
9138 /* When the rank is not known just set a positive rank, which
9139 suffices to recognize the data as array. */
9140 if (rank < 0)
9141 rank = 1;
9142 size = build_zero_cst (size_type_node);
9143 desc = field;
9144 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
9145 build_int_cst (signed_char_type_node, rank));
9146 }
9147 else
9148 {
9149 desc = gfc_conv_scalar_to_descriptor (&se, field,
9150 cm->ts.type == BT_CLASS
9151 ? CLASS_DATA (cm)->attr
9152 : cm->attr);
9153 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
9154 }
9155 gfc_add_block_to_block (&block, &se.pre);
9156 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
9157 7, size, build_int_cst (
9158 integer_type_node,
9159 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
9160 gfc_build_addr_expr (pvoid_type_node,
9161 token),
9162 gfc_build_addr_expr (NULL_TREE, desc),
9163 null_pointer_node, null_pointer_node,
9164 integer_zero_node);
9165 gfc_add_expr_to_block (&block, tmp);
9166 }
9167 field = cm->backend_decl;
9168 gcc_assert(field);
9169 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
9170 dest, field, NULL_TREE);
9171 if (!c->expr)
9172 {
9173 gfc_expr *e = gfc_get_null_expr (NULL);
9174 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
9175 init);
9176 gfc_free_expr (e);
9177 }
9178 else
9179 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
9180 expr->ts.u.derived, init);
9181 gfc_add_expr_to_block (&block, tmp);
9182 }
9183 return gfc_finish_block (&block);
9184 }
9185
9186 void
gfc_conv_union_initializer(vec<constructor_elt,va_gc> * v,gfc_component * un,gfc_expr * init)9187 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
9188 gfc_component *un, gfc_expr *init)
9189 {
9190 gfc_constructor *ctor;
9191
9192 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
9193 return;
9194
9195 ctor = gfc_constructor_first (init->value.constructor);
9196
9197 if (ctor == NULL || ctor->expr == NULL)
9198 return;
9199
9200 gcc_assert (init->expr_type == EXPR_STRUCTURE);
9201
9202 /* If we have an 'initialize all' constructor, do it first. */
9203 if (ctor->expr->expr_type == EXPR_NULL)
9204 {
9205 tree union_type = TREE_TYPE (un->backend_decl);
9206 tree val = build_constructor (union_type, NULL);
9207 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
9208 ctor = gfc_constructor_next (ctor);
9209 }
9210
9211 /* Add the map initializer on top. */
9212 if (ctor != NULL && ctor->expr != NULL)
9213 {
9214 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
9215 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
9216 TREE_TYPE (un->backend_decl),
9217 un->attr.dimension, un->attr.pointer,
9218 un->attr.proc_pointer);
9219 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
9220 }
9221 }
9222
9223 /* Build an expression for a constructor. If init is nonzero then
9224 this is part of a static variable initializer. */
9225
9226 void
gfc_conv_structure(gfc_se * se,gfc_expr * expr,int init)9227 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
9228 {
9229 gfc_constructor *c;
9230 gfc_component *cm;
9231 tree val;
9232 tree type;
9233 tree tmp;
9234 vec<constructor_elt, va_gc> *v = NULL;
9235
9236 gcc_assert (se->ss == NULL);
9237 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
9238 type = gfc_typenode_for_spec (&expr->ts);
9239
9240 if (!init)
9241 {
9242 /* Create a temporary variable and fill it in. */
9243 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
9244 /* The symtree in expr is NULL, if the code to generate is for
9245 initializing the static members only. */
9246 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
9247 se->want_coarray);
9248 gfc_add_expr_to_block (&se->pre, tmp);
9249 return;
9250 }
9251
9252 cm = expr->ts.u.derived->components;
9253
9254 for (c = gfc_constructor_first (expr->value.constructor);
9255 c; c = gfc_constructor_next (c), cm = cm->next)
9256 {
9257 /* Skip absent members in default initializers and allocatable
9258 components. Although the latter have a default initializer
9259 of EXPR_NULL,... by default, the static nullify is not needed
9260 since this is done every time we come into scope. */
9261 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
9262 continue;
9263
9264 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
9265 && strcmp (cm->name, "_extends") == 0
9266 && cm->initializer->symtree)
9267 {
9268 tree vtab;
9269 gfc_symbol *vtabs;
9270 vtabs = cm->initializer->symtree->n.sym;
9271 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
9272 vtab = unshare_expr_without_location (vtab);
9273 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
9274 }
9275 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
9276 {
9277 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
9278 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
9279 fold_convert (TREE_TYPE (cm->backend_decl),
9280 val));
9281 }
9282 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
9283 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
9284 fold_convert (TREE_TYPE (cm->backend_decl),
9285 integer_zero_node));
9286 else if (cm->ts.type == BT_UNION)
9287 gfc_conv_union_initializer (v, cm, c->expr);
9288 else
9289 {
9290 val = gfc_conv_initializer (c->expr, &cm->ts,
9291 TREE_TYPE (cm->backend_decl),
9292 cm->attr.dimension, cm->attr.pointer,
9293 cm->attr.proc_pointer);
9294 val = unshare_expr_without_location (val);
9295
9296 /* Append it to the constructor list. */
9297 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
9298 }
9299 }
9300
9301 se->expr = build_constructor (type, v);
9302 if (init)
9303 TREE_CONSTANT (se->expr) = 1;
9304 }
9305
9306
9307 /* Translate a substring expression. */
9308
9309 static void
gfc_conv_substring_expr(gfc_se * se,gfc_expr * expr)9310 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
9311 {
9312 gfc_ref *ref;
9313
9314 ref = expr->ref;
9315
9316 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
9317
9318 se->expr = gfc_build_wide_string_const (expr->ts.kind,
9319 expr->value.character.length,
9320 expr->value.character.string);
9321
9322 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
9323 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
9324
9325 if (ref)
9326 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
9327 }
9328
9329
9330 /* Entry point for expression translation. Evaluates a scalar quantity.
9331 EXPR is the expression to be translated, and SE is the state structure if
9332 called from within the scalarized. */
9333
9334 void
gfc_conv_expr(gfc_se * se,gfc_expr * expr)9335 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
9336 {
9337 gfc_ss *ss;
9338
9339 ss = se->ss;
9340 if (ss && ss->info->expr == expr
9341 && (ss->info->type == GFC_SS_SCALAR
9342 || ss->info->type == GFC_SS_REFERENCE))
9343 {
9344 gfc_ss_info *ss_info;
9345
9346 ss_info = ss->info;
9347 /* Substitute a scalar expression evaluated outside the scalarization
9348 loop. */
9349 se->expr = ss_info->data.scalar.value;
9350 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
9351 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9352
9353 se->string_length = ss_info->string_length;
9354 gfc_advance_se_ss_chain (se);
9355 return;
9356 }
9357
9358 /* We need to convert the expressions for the iso_c_binding derived types.
9359 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
9360 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
9361 typespec for the C_PTR and C_FUNPTR symbols, which has already been
9362 updated to be an integer with a kind equal to the size of a (void *). */
9363 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
9364 && expr->ts.u.derived->attr.is_bind_c)
9365 {
9366 if (expr->expr_type == EXPR_VARIABLE
9367 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
9368 || expr->symtree->n.sym->intmod_sym_id
9369 == ISOCBINDING_NULL_FUNPTR))
9370 {
9371 /* Set expr_type to EXPR_NULL, which will result in
9372 null_pointer_node being used below. */
9373 expr->expr_type = EXPR_NULL;
9374 }
9375 else
9376 {
9377 /* Update the type/kind of the expression to be what the new
9378 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
9379 expr->ts.type = BT_INTEGER;
9380 expr->ts.f90_type = BT_VOID;
9381 expr->ts.kind = gfc_index_integer_kind;
9382 }
9383 }
9384
9385 gfc_fix_class_refs (expr);
9386
9387 switch (expr->expr_type)
9388 {
9389 case EXPR_OP:
9390 gfc_conv_expr_op (se, expr);
9391 break;
9392
9393 case EXPR_FUNCTION:
9394 gfc_conv_function_expr (se, expr);
9395 break;
9396
9397 case EXPR_CONSTANT:
9398 gfc_conv_constant (se, expr);
9399 break;
9400
9401 case EXPR_VARIABLE:
9402 gfc_conv_variable (se, expr);
9403 break;
9404
9405 case EXPR_NULL:
9406 se->expr = null_pointer_node;
9407 break;
9408
9409 case EXPR_SUBSTRING:
9410 gfc_conv_substring_expr (se, expr);
9411 break;
9412
9413 case EXPR_STRUCTURE:
9414 gfc_conv_structure (se, expr, 0);
9415 break;
9416
9417 case EXPR_ARRAY:
9418 gfc_conv_array_constructor_expr (se, expr);
9419 break;
9420
9421 default:
9422 gcc_unreachable ();
9423 break;
9424 }
9425 }
9426
9427 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
9428 of an assignment. */
9429 void
gfc_conv_expr_lhs(gfc_se * se,gfc_expr * expr)9430 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
9431 {
9432 gfc_conv_expr (se, expr);
9433 /* All numeric lvalues should have empty post chains. If not we need to
9434 figure out a way of rewriting an lvalue so that it has no post chain. */
9435 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
9436 }
9437
9438 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
9439 numeric expressions. Used for scalar values where inserting cleanup code
9440 is inconvenient. */
9441 void
gfc_conv_expr_val(gfc_se * se,gfc_expr * expr)9442 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
9443 {
9444 tree val;
9445
9446 gcc_assert (expr->ts.type != BT_CHARACTER);
9447 gfc_conv_expr (se, expr);
9448 if (se->post.head)
9449 {
9450 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
9451 gfc_add_modify (&se->pre, val, se->expr);
9452 se->expr = val;
9453 gfc_add_block_to_block (&se->pre, &se->post);
9454 }
9455 }
9456
9457 /* Helper to translate an expression and convert it to a particular type. */
9458 void
gfc_conv_expr_type(gfc_se * se,gfc_expr * expr,tree type)9459 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
9460 {
9461 gfc_conv_expr_val (se, expr);
9462 se->expr = convert (type, se->expr);
9463 }
9464
9465
9466 /* Converts an expression so that it can be passed by reference. Scalar
9467 values only. */
9468
9469 void
gfc_conv_expr_reference(gfc_se * se,gfc_expr * expr,bool add_clobber)9470 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
9471 {
9472 gfc_ss *ss;
9473 tree var;
9474
9475 ss = se->ss;
9476 if (ss && ss->info->expr == expr
9477 && ss->info->type == GFC_SS_REFERENCE)
9478 {
9479 /* Returns a reference to the scalar evaluated outside the loop
9480 for this case. */
9481 gfc_conv_expr (se, expr);
9482
9483 if (expr->ts.type == BT_CHARACTER
9484 && expr->expr_type != EXPR_FUNCTION)
9485 gfc_conv_string_parameter (se);
9486 else
9487 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9488
9489 return;
9490 }
9491
9492 if (expr->ts.type == BT_CHARACTER)
9493 {
9494 gfc_conv_expr (se, expr);
9495 gfc_conv_string_parameter (se);
9496 return;
9497 }
9498
9499 if (expr->expr_type == EXPR_VARIABLE)
9500 {
9501 se->want_pointer = 1;
9502 gfc_conv_expr (se, expr);
9503 if (se->post.head)
9504 {
9505 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9506 gfc_add_modify (&se->pre, var, se->expr);
9507 gfc_add_block_to_block (&se->pre, &se->post);
9508 se->expr = var;
9509 }
9510 else if (add_clobber && expr->ref == NULL)
9511 {
9512 tree clobber;
9513 tree var;
9514 /* FIXME: This fails if var is passed by reference, see PR
9515 41453. */
9516 var = expr->symtree->n.sym->backend_decl;
9517 clobber = build_clobber (TREE_TYPE (var));
9518 gfc_add_modify (&se->pre, var, clobber);
9519 }
9520 return;
9521 }
9522
9523 if (expr->expr_type == EXPR_FUNCTION
9524 && ((expr->value.function.esym
9525 && expr->value.function.esym->result
9526 && expr->value.function.esym->result->attr.pointer
9527 && !expr->value.function.esym->result->attr.dimension)
9528 || (!expr->value.function.esym && !expr->ref
9529 && expr->symtree->n.sym->attr.pointer
9530 && !expr->symtree->n.sym->attr.dimension)))
9531 {
9532 se->want_pointer = 1;
9533 gfc_conv_expr (se, expr);
9534 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9535 gfc_add_modify (&se->pre, var, se->expr);
9536 se->expr = var;
9537 return;
9538 }
9539
9540 gfc_conv_expr (se, expr);
9541
9542 /* Create a temporary var to hold the value. */
9543 if (TREE_CONSTANT (se->expr))
9544 {
9545 tree tmp = se->expr;
9546 STRIP_TYPE_NOPS (tmp);
9547 var = build_decl (input_location,
9548 CONST_DECL, NULL, TREE_TYPE (tmp));
9549 DECL_INITIAL (var) = tmp;
9550 TREE_STATIC (var) = 1;
9551 pushdecl (var);
9552 }
9553 else
9554 {
9555 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9556 gfc_add_modify (&se->pre, var, se->expr);
9557 }
9558
9559 if (!expr->must_finalize)
9560 gfc_add_block_to_block (&se->pre, &se->post);
9561
9562 /* Take the address of that value. */
9563 se->expr = gfc_build_addr_expr (NULL_TREE, var);
9564 }
9565
9566
9567 /* Get the _len component for an unlimited polymorphic expression. */
9568
9569 static tree
trans_get_upoly_len(stmtblock_t * block,gfc_expr * expr)9570 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
9571 {
9572 gfc_se se;
9573 gfc_ref *ref = expr->ref;
9574
9575 gfc_init_se (&se, NULL);
9576 while (ref && ref->next)
9577 ref = ref->next;
9578 gfc_add_len_component (expr);
9579 gfc_conv_expr (&se, expr);
9580 gfc_add_block_to_block (block, &se.pre);
9581 gcc_assert (se.post.head == NULL_TREE);
9582 if (ref)
9583 {
9584 gfc_free_ref_list (ref->next);
9585 ref->next = NULL;
9586 }
9587 else
9588 {
9589 gfc_free_ref_list (expr->ref);
9590 expr->ref = NULL;
9591 }
9592 return se.expr;
9593 }
9594
9595
9596 /* Assign _vptr and _len components as appropriate. BLOCK should be a
9597 statement-list outside of the scalarizer-loop. When code is generated, that
9598 depends on the scalarized expression, it is added to RSE.PRE.
9599 Returns le's _vptr tree and when set the len expressions in to_lenp and
9600 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
9601 expression. */
9602
9603 static tree
trans_class_vptr_len_assignment(stmtblock_t * block,gfc_expr * le,gfc_expr * re,gfc_se * rse,tree * to_lenp,tree * from_lenp)9604 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
9605 gfc_expr * re, gfc_se *rse,
9606 tree * to_lenp, tree * from_lenp)
9607 {
9608 gfc_se se;
9609 gfc_expr * vptr_expr;
9610 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
9611 bool set_vptr = false, temp_rhs = false;
9612 stmtblock_t *pre = block;
9613 tree class_expr = NULL_TREE;
9614
9615 /* Create a temporary for complicated expressions. */
9616 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
9617 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
9618 {
9619 if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
9620 class_expr = gfc_get_class_from_expr (rse->expr);
9621
9622 if (rse->loop)
9623 pre = &rse->loop->pre;
9624 else
9625 pre = &rse->pre;
9626
9627 if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
9628 {
9629 tmp = TREE_OPERAND (rse->expr, 0);
9630 tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
9631 gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
9632 }
9633 else
9634 {
9635 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
9636 gfc_add_modify (&rse->pre, tmp, rse->expr);
9637 }
9638
9639 rse->expr = tmp;
9640 temp_rhs = true;
9641 }
9642
9643 /* Get the _vptr for the left-hand side expression. */
9644 gfc_init_se (&se, NULL);
9645 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
9646 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
9647 {
9648 /* Care about _len for unlimited polymorphic entities. */
9649 if (UNLIMITED_POLY (vptr_expr)
9650 || (vptr_expr->ts.type == BT_DERIVED
9651 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
9652 to_len = trans_get_upoly_len (block, vptr_expr);
9653 gfc_add_vptr_component (vptr_expr);
9654 set_vptr = true;
9655 }
9656 else
9657 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
9658 se.want_pointer = 1;
9659 gfc_conv_expr (&se, vptr_expr);
9660 gfc_free_expr (vptr_expr);
9661 gfc_add_block_to_block (block, &se.pre);
9662 gcc_assert (se.post.head == NULL_TREE);
9663 lhs_vptr = se.expr;
9664 STRIP_NOPS (lhs_vptr);
9665
9666 /* Set the _vptr only when the left-hand side of the assignment is a
9667 class-object. */
9668 if (set_vptr)
9669 {
9670 /* Get the vptr from the rhs expression only, when it is variable.
9671 Functions are expected to be assigned to a temporary beforehand. */
9672 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
9673 ? gfc_find_and_cut_at_last_class_ref (re)
9674 : NULL;
9675 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
9676 {
9677 if (to_len != NULL_TREE)
9678 {
9679 /* Get the _len information from the rhs. */
9680 if (UNLIMITED_POLY (vptr_expr)
9681 || (vptr_expr->ts.type == BT_DERIVED
9682 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
9683 from_len = trans_get_upoly_len (block, vptr_expr);
9684 }
9685 gfc_add_vptr_component (vptr_expr);
9686 }
9687 else
9688 {
9689 if (re->expr_type == EXPR_VARIABLE
9690 && DECL_P (re->symtree->n.sym->backend_decl)
9691 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
9692 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
9693 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
9694 re->symtree->n.sym->backend_decl))))
9695 {
9696 vptr_expr = NULL;
9697 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
9698 re->symtree->n.sym->backend_decl));
9699 if (to_len)
9700 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
9701 re->symtree->n.sym->backend_decl));
9702 }
9703 else if (temp_rhs && re->ts.type == BT_CLASS)
9704 {
9705 vptr_expr = NULL;
9706 if (class_expr)
9707 tmp = class_expr;
9708 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
9709 tmp = gfc_get_class_from_expr (rse->expr);
9710 else
9711 tmp = rse->expr;
9712
9713 se.expr = gfc_class_vptr_get (tmp);
9714 if (UNLIMITED_POLY (re))
9715 from_len = gfc_class_len_get (tmp);
9716
9717 }
9718 else if (re->expr_type != EXPR_NULL)
9719 /* Only when rhs is non-NULL use its declared type for vptr
9720 initialisation. */
9721 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
9722 else
9723 /* When the rhs is NULL use the vtab of lhs' declared type. */
9724 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
9725 }
9726
9727 if (vptr_expr)
9728 {
9729 gfc_init_se (&se, NULL);
9730 se.want_pointer = 1;
9731 gfc_conv_expr (&se, vptr_expr);
9732 gfc_free_expr (vptr_expr);
9733 gfc_add_block_to_block (block, &se.pre);
9734 gcc_assert (se.post.head == NULL_TREE);
9735 }
9736 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
9737 se.expr));
9738
9739 if (to_len != NULL_TREE)
9740 {
9741 /* The _len component needs to be set. Figure how to get the
9742 value of the right-hand side. */
9743 if (from_len == NULL_TREE)
9744 {
9745 if (rse->string_length != NULL_TREE)
9746 from_len = rse->string_length;
9747 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
9748 {
9749 gfc_init_se (&se, NULL);
9750 gfc_conv_expr (&se, re->ts.u.cl->length);
9751 gfc_add_block_to_block (block, &se.pre);
9752 gcc_assert (se.post.head == NULL_TREE);
9753 from_len = gfc_evaluate_now (se.expr, block);
9754 }
9755 else
9756 from_len = build_zero_cst (gfc_charlen_type_node);
9757 }
9758 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
9759 from_len));
9760 }
9761 }
9762
9763 /* Return the _len trees only, when requested. */
9764 if (to_lenp)
9765 *to_lenp = to_len;
9766 if (from_lenp)
9767 *from_lenp = from_len;
9768 return lhs_vptr;
9769 }
9770
9771
9772 /* Assign tokens for pointer components. */
9773
9774 static void
trans_caf_token_assign(gfc_se * lse,gfc_se * rse,gfc_expr * expr1,gfc_expr * expr2)9775 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
9776 gfc_expr *expr2)
9777 {
9778 symbol_attribute lhs_attr, rhs_attr;
9779 tree tmp, lhs_tok, rhs_tok;
9780 /* Flag to indicated component refs on the rhs. */
9781 bool rhs_cr;
9782
9783 lhs_attr = gfc_caf_attr (expr1);
9784 if (expr2->expr_type != EXPR_NULL)
9785 {
9786 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
9787 if (lhs_attr.codimension && rhs_attr.codimension)
9788 {
9789 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
9790 lhs_tok = build_fold_indirect_ref (lhs_tok);
9791
9792 if (rhs_cr)
9793 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
9794 else
9795 {
9796 tree caf_decl;
9797 caf_decl = gfc_get_tree_for_caf_expr (expr2);
9798 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
9799 NULL_TREE, NULL);
9800 }
9801 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9802 lhs_tok,
9803 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
9804 gfc_prepend_expr_to_block (&lse->post, tmp);
9805 }
9806 }
9807 else if (lhs_attr.codimension)
9808 {
9809 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
9810 lhs_tok = build_fold_indirect_ref (lhs_tok);
9811 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9812 lhs_tok, null_pointer_node);
9813 gfc_prepend_expr_to_block (&lse->post, tmp);
9814 }
9815 }
9816
9817
9818 /* Do everything that is needed for a CLASS function expr2. */
9819
9820 static tree
trans_class_pointer_fcn(stmtblock_t * block,gfc_se * lse,gfc_se * rse,gfc_expr * expr1,gfc_expr * expr2)9821 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
9822 gfc_expr *expr1, gfc_expr *expr2)
9823 {
9824 tree expr1_vptr = NULL_TREE;
9825 tree tmp;
9826
9827 gfc_conv_function_expr (rse, expr2);
9828 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
9829
9830 if (expr1->ts.type != BT_CLASS)
9831 rse->expr = gfc_class_data_get (rse->expr);
9832 else
9833 {
9834 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
9835 expr2, rse,
9836 NULL, NULL);
9837 gfc_add_block_to_block (block, &rse->pre);
9838 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
9839 gfc_add_modify (&lse->pre, tmp, rse->expr);
9840
9841 gfc_add_modify (&lse->pre, expr1_vptr,
9842 fold_convert (TREE_TYPE (expr1_vptr),
9843 gfc_class_vptr_get (tmp)));
9844 rse->expr = gfc_class_data_get (tmp);
9845 }
9846
9847 return expr1_vptr;
9848 }
9849
9850
9851 tree
gfc_trans_pointer_assign(gfc_code * code)9852 gfc_trans_pointer_assign (gfc_code * code)
9853 {
9854 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
9855 }
9856
9857
9858 /* Generate code for a pointer assignment. */
9859
9860 tree
gfc_trans_pointer_assignment(gfc_expr * expr1,gfc_expr * expr2)9861 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
9862 {
9863 gfc_se lse;
9864 gfc_se rse;
9865 stmtblock_t block;
9866 tree desc;
9867 tree tmp;
9868 tree expr1_vptr = NULL_TREE;
9869 bool scalar, non_proc_ptr_assign;
9870 gfc_ss *ss;
9871
9872 gfc_start_block (&block);
9873
9874 gfc_init_se (&lse, NULL);
9875
9876 /* Usually testing whether this is not a proc pointer assignment. */
9877 non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
9878 && expr2->expr_type == EXPR_VARIABLE
9879 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
9880
9881 /* Check whether the expression is a scalar or not; we cannot use
9882 expr1->rank as it can be nonzero for proc pointers. */
9883 ss = gfc_walk_expr (expr1);
9884 scalar = ss == gfc_ss_terminator;
9885 if (!scalar)
9886 gfc_free_ss_chain (ss);
9887
9888 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
9889 && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
9890 {
9891 gfc_add_data_component (expr2);
9892 /* The following is required as gfc_add_data_component doesn't
9893 update ts.type if there is a trailing REF_ARRAY. */
9894 expr2->ts.type = BT_DERIVED;
9895 }
9896
9897 if (scalar)
9898 {
9899 /* Scalar pointers. */
9900 lse.want_pointer = 1;
9901 gfc_conv_expr (&lse, expr1);
9902 gfc_init_se (&rse, NULL);
9903 rse.want_pointer = 1;
9904 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9905 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
9906 else
9907 gfc_conv_expr (&rse, expr2);
9908
9909 if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
9910 {
9911 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
9912 NULL);
9913 lse.expr = gfc_class_data_get (lse.expr);
9914 }
9915
9916 if (expr1->symtree->n.sym->attr.proc_pointer
9917 && expr1->symtree->n.sym->attr.dummy)
9918 lse.expr = build_fold_indirect_ref_loc (input_location,
9919 lse.expr);
9920
9921 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
9922 && expr2->symtree->n.sym->attr.dummy)
9923 rse.expr = build_fold_indirect_ref_loc (input_location,
9924 rse.expr);
9925
9926 gfc_add_block_to_block (&block, &lse.pre);
9927 gfc_add_block_to_block (&block, &rse.pre);
9928
9929 /* Check character lengths if character expression. The test is only
9930 really added if -fbounds-check is enabled. Exclude deferred
9931 character length lefthand sides. */
9932 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
9933 && !expr1->ts.deferred
9934 && !expr1->symtree->n.sym->attr.proc_pointer
9935 && !gfc_is_proc_ptr_comp (expr1))
9936 {
9937 gcc_assert (expr2->ts.type == BT_CHARACTER);
9938 gcc_assert (lse.string_length && rse.string_length);
9939 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9940 lse.string_length, rse.string_length,
9941 &block);
9942 }
9943
9944 /* The assignment to an deferred character length sets the string
9945 length to that of the rhs. */
9946 if (expr1->ts.deferred)
9947 {
9948 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
9949 gfc_add_modify (&block, lse.string_length,
9950 fold_convert (TREE_TYPE (lse.string_length),
9951 rse.string_length));
9952 else if (lse.string_length != NULL)
9953 gfc_add_modify (&block, lse.string_length,
9954 build_zero_cst (TREE_TYPE (lse.string_length)));
9955 }
9956
9957 gfc_add_modify (&block, lse.expr,
9958 fold_convert (TREE_TYPE (lse.expr), rse.expr));
9959
9960 /* Also set the tokens for pointer components in derived typed
9961 coarrays. */
9962 if (flag_coarray == GFC_FCOARRAY_LIB)
9963 trans_caf_token_assign (&lse, &rse, expr1, expr2);
9964
9965 gfc_add_block_to_block (&block, &rse.post);
9966 gfc_add_block_to_block (&block, &lse.post);
9967 }
9968 else
9969 {
9970 gfc_ref* remap;
9971 bool rank_remap;
9972 tree strlen_lhs;
9973 tree strlen_rhs = NULL_TREE;
9974
9975 /* Array pointer. Find the last reference on the LHS and if it is an
9976 array section ref, we're dealing with bounds remapping. In this case,
9977 set it to AR_FULL so that gfc_conv_expr_descriptor does
9978 not see it and process the bounds remapping afterwards explicitly. */
9979 for (remap = expr1->ref; remap; remap = remap->next)
9980 if (!remap->next && remap->type == REF_ARRAY
9981 && remap->u.ar.type == AR_SECTION)
9982 break;
9983 rank_remap = (remap && remap->u.ar.end[0]);
9984
9985 if (remap && expr2->expr_type == EXPR_NULL)
9986 {
9987 gfc_error ("If bounds remapping is specified at %L, "
9988 "the pointer target shall not be NULL", &expr1->where);
9989 return NULL_TREE;
9990 }
9991
9992 gfc_init_se (&lse, NULL);
9993 if (remap)
9994 lse.descriptor_only = 1;
9995 gfc_conv_expr_descriptor (&lse, expr1);
9996 strlen_lhs = lse.string_length;
9997 desc = lse.expr;
9998
9999 if (expr2->expr_type == EXPR_NULL)
10000 {
10001 /* Just set the data pointer to null. */
10002 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
10003 }
10004 else if (rank_remap)
10005 {
10006 /* If we are rank-remapping, just get the RHS's descriptor and
10007 process this later on. */
10008 gfc_init_se (&rse, NULL);
10009 rse.direct_byref = 1;
10010 rse.byref_noassign = 1;
10011
10012 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10013 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
10014 expr1, expr2);
10015 else if (expr2->expr_type == EXPR_FUNCTION)
10016 {
10017 tree bound[GFC_MAX_DIMENSIONS];
10018 int i;
10019
10020 for (i = 0; i < expr2->rank; i++)
10021 bound[i] = NULL_TREE;
10022 tmp = gfc_typenode_for_spec (&expr2->ts);
10023 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
10024 bound, bound, 0,
10025 GFC_ARRAY_POINTER_CONT, false);
10026 tmp = gfc_create_var (tmp, "ptrtemp");
10027 rse.descriptor_only = 0;
10028 rse.expr = tmp;
10029 rse.direct_byref = 1;
10030 gfc_conv_expr_descriptor (&rse, expr2);
10031 strlen_rhs = rse.string_length;
10032 rse.expr = tmp;
10033 }
10034 else
10035 {
10036 gfc_conv_expr_descriptor (&rse, expr2);
10037 strlen_rhs = rse.string_length;
10038 if (expr1->ts.type == BT_CLASS)
10039 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
10040 expr2, &rse,
10041 NULL, NULL);
10042 }
10043 }
10044 else if (expr2->expr_type == EXPR_VARIABLE)
10045 {
10046 /* Assign directly to the LHS's descriptor. */
10047 lse.descriptor_only = 0;
10048 lse.direct_byref = 1;
10049 gfc_conv_expr_descriptor (&lse, expr2);
10050 strlen_rhs = lse.string_length;
10051 gfc_init_se (&rse, NULL);
10052
10053 if (expr1->ts.type == BT_CLASS)
10054 {
10055 rse.expr = NULL_TREE;
10056 rse.string_length = strlen_rhs;
10057 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
10058 NULL, NULL);
10059 }
10060
10061 if (remap == NULL)
10062 {
10063 /* If the target is not a whole array, use the target array
10064 reference for remap. */
10065 for (remap = expr2->ref; remap; remap = remap->next)
10066 if (remap->type == REF_ARRAY
10067 && remap->u.ar.type == AR_FULL
10068 && remap->next)
10069 break;
10070 }
10071 }
10072 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10073 {
10074 gfc_init_se (&rse, NULL);
10075 rse.want_pointer = 1;
10076 gfc_conv_function_expr (&rse, expr2);
10077 if (expr1->ts.type != BT_CLASS)
10078 {
10079 rse.expr = gfc_class_data_get (rse.expr);
10080 gfc_add_modify (&lse.pre, desc, rse.expr);
10081 /* Set the lhs span. */
10082 tmp = TREE_TYPE (rse.expr);
10083 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
10084 tmp = fold_convert (gfc_array_index_type, tmp);
10085 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
10086 }
10087 else
10088 {
10089 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
10090 expr2, &rse, NULL,
10091 NULL);
10092 gfc_add_block_to_block (&block, &rse.pre);
10093 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
10094 gfc_add_modify (&lse.pre, tmp, rse.expr);
10095
10096 gfc_add_modify (&lse.pre, expr1_vptr,
10097 fold_convert (TREE_TYPE (expr1_vptr),
10098 gfc_class_vptr_get (tmp)));
10099 rse.expr = gfc_class_data_get (tmp);
10100 gfc_add_modify (&lse.pre, desc, rse.expr);
10101 }
10102 }
10103 else
10104 {
10105 /* Assign to a temporary descriptor and then copy that
10106 temporary to the pointer. */
10107 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
10108 lse.descriptor_only = 0;
10109 lse.expr = tmp;
10110 lse.direct_byref = 1;
10111 gfc_conv_expr_descriptor (&lse, expr2);
10112 strlen_rhs = lse.string_length;
10113 gfc_add_modify (&lse.pre, desc, tmp);
10114 }
10115
10116 if (expr1->ts.type == BT_CHARACTER
10117 && expr1->symtree->n.sym->ts.deferred
10118 && expr1->symtree->n.sym->ts.u.cl->backend_decl
10119 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
10120 {
10121 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
10122 if (expr2->expr_type != EXPR_NULL)
10123 gfc_add_modify (&block, tmp,
10124 fold_convert (TREE_TYPE (tmp), strlen_rhs));
10125 else
10126 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
10127 }
10128
10129 gfc_add_block_to_block (&block, &lse.pre);
10130 if (rank_remap)
10131 gfc_add_block_to_block (&block, &rse.pre);
10132
10133 /* If we do bounds remapping, update LHS descriptor accordingly. */
10134 if (remap)
10135 {
10136 int dim;
10137 gcc_assert (remap->u.ar.dimen == expr1->rank);
10138
10139 if (rank_remap)
10140 {
10141 /* Do rank remapping. We already have the RHS's descriptor
10142 converted in rse and now have to build the correct LHS
10143 descriptor for it. */
10144
10145 tree dtype, data, span;
10146 tree offs, stride;
10147 tree lbound, ubound;
10148
10149 /* Set dtype. */
10150 dtype = gfc_conv_descriptor_dtype (desc);
10151 tmp = gfc_get_dtype (TREE_TYPE (desc));
10152 gfc_add_modify (&block, dtype, tmp);
10153
10154 /* Copy data pointer. */
10155 data = gfc_conv_descriptor_data_get (rse.expr);
10156 gfc_conv_descriptor_data_set (&block, desc, data);
10157
10158 /* Copy the span. */
10159 if (TREE_CODE (rse.expr) == VAR_DECL
10160 && GFC_DECL_PTR_ARRAY_P (rse.expr))
10161 span = gfc_conv_descriptor_span_get (rse.expr);
10162 else
10163 {
10164 tmp = TREE_TYPE (rse.expr);
10165 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
10166 span = fold_convert (gfc_array_index_type, tmp);
10167 }
10168 gfc_conv_descriptor_span_set (&block, desc, span);
10169
10170 /* Copy offset but adjust it such that it would correspond
10171 to a lbound of zero. */
10172 offs = gfc_conv_descriptor_offset_get (rse.expr);
10173 for (dim = 0; dim < expr2->rank; ++dim)
10174 {
10175 stride = gfc_conv_descriptor_stride_get (rse.expr,
10176 gfc_rank_cst[dim]);
10177 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
10178 gfc_rank_cst[dim]);
10179 tmp = fold_build2_loc (input_location, MULT_EXPR,
10180 gfc_array_index_type, stride, lbound);
10181 offs = fold_build2_loc (input_location, PLUS_EXPR,
10182 gfc_array_index_type, offs, tmp);
10183 }
10184 gfc_conv_descriptor_offset_set (&block, desc, offs);
10185
10186 /* Set the bounds as declared for the LHS and calculate strides as
10187 well as another offset update accordingly. */
10188 stride = gfc_conv_descriptor_stride_get (rse.expr,
10189 gfc_rank_cst[0]);
10190 for (dim = 0; dim < expr1->rank; ++dim)
10191 {
10192 gfc_se lower_se;
10193 gfc_se upper_se;
10194
10195 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
10196
10197 /* Convert declared bounds. */
10198 gfc_init_se (&lower_se, NULL);
10199 gfc_init_se (&upper_se, NULL);
10200 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
10201 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
10202
10203 gfc_add_block_to_block (&block, &lower_se.pre);
10204 gfc_add_block_to_block (&block, &upper_se.pre);
10205
10206 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
10207 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
10208
10209 lbound = gfc_evaluate_now (lbound, &block);
10210 ubound = gfc_evaluate_now (ubound, &block);
10211
10212 gfc_add_block_to_block (&block, &lower_se.post);
10213 gfc_add_block_to_block (&block, &upper_se.post);
10214
10215 /* Set bounds in descriptor. */
10216 gfc_conv_descriptor_lbound_set (&block, desc,
10217 gfc_rank_cst[dim], lbound);
10218 gfc_conv_descriptor_ubound_set (&block, desc,
10219 gfc_rank_cst[dim], ubound);
10220
10221 /* Set stride. */
10222 stride = gfc_evaluate_now (stride, &block);
10223 gfc_conv_descriptor_stride_set (&block, desc,
10224 gfc_rank_cst[dim], stride);
10225
10226 /* Update offset. */
10227 offs = gfc_conv_descriptor_offset_get (desc);
10228 tmp = fold_build2_loc (input_location, MULT_EXPR,
10229 gfc_array_index_type, lbound, stride);
10230 offs = fold_build2_loc (input_location, MINUS_EXPR,
10231 gfc_array_index_type, offs, tmp);
10232 offs = gfc_evaluate_now (offs, &block);
10233 gfc_conv_descriptor_offset_set (&block, desc, offs);
10234
10235 /* Update stride. */
10236 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
10237 stride = fold_build2_loc (input_location, MULT_EXPR,
10238 gfc_array_index_type, stride, tmp);
10239 }
10240 }
10241 else
10242 {
10243 /* Bounds remapping. Just shift the lower bounds. */
10244
10245 gcc_assert (expr1->rank == expr2->rank);
10246
10247 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
10248 {
10249 gfc_se lbound_se;
10250
10251 gcc_assert (!remap->u.ar.end[dim]);
10252 gfc_init_se (&lbound_se, NULL);
10253 if (remap->u.ar.start[dim])
10254 {
10255 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
10256 gfc_add_block_to_block (&block, &lbound_se.pre);
10257 }
10258 else
10259 /* This remap arises from a target that is not a whole
10260 array. The start expressions will be NULL but we need
10261 the lbounds to be one. */
10262 lbound_se.expr = gfc_index_one_node;
10263 gfc_conv_shift_descriptor_lbound (&block, desc,
10264 dim, lbound_se.expr);
10265 gfc_add_block_to_block (&block, &lbound_se.post);
10266 }
10267 }
10268 }
10269
10270 /* If rank remapping was done, check with -fcheck=bounds that
10271 the target is at least as large as the pointer. */
10272 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
10273 {
10274 tree lsize, rsize;
10275 tree fault;
10276 const char* msg;
10277
10278 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
10279 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
10280
10281 lsize = gfc_evaluate_now (lsize, &block);
10282 rsize = gfc_evaluate_now (rsize, &block);
10283 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10284 rsize, lsize);
10285
10286 msg = _("Target of rank remapping is too small (%ld < %ld)");
10287 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
10288 msg, rsize, lsize);
10289 }
10290
10291 /* Check string lengths if applicable. The check is only really added
10292 to the output code if -fbounds-check is enabled. */
10293 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
10294 {
10295 gcc_assert (expr2->ts.type == BT_CHARACTER);
10296 gcc_assert (strlen_lhs && strlen_rhs);
10297 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
10298 strlen_lhs, strlen_rhs, &block);
10299 }
10300
10301 gfc_add_block_to_block (&block, &lse.post);
10302 if (rank_remap)
10303 gfc_add_block_to_block (&block, &rse.post);
10304 }
10305
10306 return gfc_finish_block (&block);
10307 }
10308
10309
10310 /* Makes sure se is suitable for passing as a function string parameter. */
10311 /* TODO: Need to check all callers of this function. It may be abused. */
10312
10313 void
gfc_conv_string_parameter(gfc_se * se)10314 gfc_conv_string_parameter (gfc_se * se)
10315 {
10316 tree type;
10317
10318 if (TREE_CODE (se->expr) == STRING_CST)
10319 {
10320 type = TREE_TYPE (TREE_TYPE (se->expr));
10321 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
10322 return;
10323 }
10324
10325 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
10326 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
10327 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
10328 {
10329 if (TREE_CODE (se->expr) != INDIRECT_REF)
10330 {
10331 type = TREE_TYPE (se->expr);
10332 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
10333 }
10334 else
10335 {
10336 type = gfc_get_character_type_len (gfc_default_character_kind,
10337 se->string_length);
10338 type = build_pointer_type (type);
10339 se->expr = gfc_build_addr_expr (type, se->expr);
10340 }
10341 }
10342
10343 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
10344 }
10345
10346
10347 /* Generate code for assignment of scalar variables. Includes character
10348 strings and derived types with allocatable components.
10349 If you know that the LHS has no allocations, set dealloc to false.
10350
10351 DEEP_COPY has no effect if the typespec TS is not a derived type with
10352 allocatable components. Otherwise, if it is set, an explicit copy of each
10353 allocatable component is made. This is necessary as a simple copy of the
10354 whole object would copy array descriptors as is, so that the lhs's
10355 allocatable components would point to the rhs's after the assignment.
10356 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
10357 necessary if the rhs is a non-pointer function, as the allocatable components
10358 are not accessible by other means than the function's result after the
10359 function has returned. It is even more subtle when temporaries are involved,
10360 as the two following examples show:
10361 1. When we evaluate an array constructor, a temporary is created. Thus
10362 there is theoretically no alias possible. However, no deep copy is
10363 made for this temporary, so that if the constructor is made of one or
10364 more variable with allocatable components, those components still point
10365 to the variable's: DEEP_COPY should be set for the assignment from the
10366 temporary to the lhs in that case.
10367 2. When assigning a scalar to an array, we evaluate the scalar value out
10368 of the loop, store it into a temporary variable, and assign from that.
10369 In that case, deep copying when assigning to the temporary would be a
10370 waste of resources; however deep copies should happen when assigning from
10371 the temporary to each array element: again DEEP_COPY should be set for
10372 the assignment from the temporary to the lhs. */
10373
10374 tree
gfc_trans_scalar_assign(gfc_se * lse,gfc_se * rse,gfc_typespec ts,bool deep_copy,bool dealloc,bool in_coarray)10375 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
10376 bool deep_copy, bool dealloc, bool in_coarray)
10377 {
10378 stmtblock_t block;
10379 tree tmp;
10380 tree cond;
10381
10382 gfc_init_block (&block);
10383
10384 if (ts.type == BT_CHARACTER)
10385 {
10386 tree rlen = NULL;
10387 tree llen = NULL;
10388
10389 if (lse->string_length != NULL_TREE)
10390 {
10391 gfc_conv_string_parameter (lse);
10392 gfc_add_block_to_block (&block, &lse->pre);
10393 llen = lse->string_length;
10394 }
10395
10396 if (rse->string_length != NULL_TREE)
10397 {
10398 gfc_conv_string_parameter (rse);
10399 gfc_add_block_to_block (&block, &rse->pre);
10400 rlen = rse->string_length;
10401 }
10402
10403 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
10404 rse->expr, ts.kind);
10405 }
10406 else if (gfc_bt_struct (ts.type)
10407 && (ts.u.derived->attr.alloc_comp
10408 || (deep_copy && ts.u.derived->attr.pdt_type)))
10409 {
10410 tree tmp_var = NULL_TREE;
10411 cond = NULL_TREE;
10412
10413 /* Are the rhs and the lhs the same? */
10414 if (deep_copy)
10415 {
10416 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10417 gfc_build_addr_expr (NULL_TREE, lse->expr),
10418 gfc_build_addr_expr (NULL_TREE, rse->expr));
10419 cond = gfc_evaluate_now (cond, &lse->pre);
10420 }
10421
10422 /* Deallocate the lhs allocated components as long as it is not
10423 the same as the rhs. This must be done following the assignment
10424 to prevent deallocating data that could be used in the rhs
10425 expression. */
10426 if (dealloc)
10427 {
10428 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
10429 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
10430 if (deep_copy)
10431 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10432 tmp);
10433 gfc_add_expr_to_block (&lse->post, tmp);
10434 }
10435
10436 gfc_add_block_to_block (&block, &rse->pre);
10437 gfc_add_block_to_block (&block, &lse->pre);
10438
10439 gfc_add_modify (&block, lse->expr,
10440 fold_convert (TREE_TYPE (lse->expr), rse->expr));
10441
10442 /* Restore pointer address of coarray components. */
10443 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
10444 {
10445 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
10446 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10447 tmp);
10448 gfc_add_expr_to_block (&block, tmp);
10449 }
10450
10451 /* Do a deep copy if the rhs is a variable, if it is not the
10452 same as the lhs. */
10453 if (deep_copy)
10454 {
10455 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10456 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
10457 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
10458 caf_mode);
10459 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10460 tmp);
10461 gfc_add_expr_to_block (&block, tmp);
10462 }
10463 }
10464 else if (gfc_bt_struct (ts.type))
10465 {
10466 gfc_add_block_to_block (&block, &lse->pre);
10467 gfc_add_block_to_block (&block, &rse->pre);
10468 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10469 TREE_TYPE (lse->expr), rse->expr);
10470 gfc_add_modify (&block, lse->expr, tmp);
10471 }
10472 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
10473 else if (ts.type == BT_CLASS)
10474 {
10475 gfc_add_block_to_block (&block, &lse->pre);
10476 gfc_add_block_to_block (&block, &rse->pre);
10477
10478 if (!trans_scalar_class_assign (&block, lse, rse))
10479 {
10480 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
10481 for the lhs which ensures that class data rhs cast as a string assigns
10482 correctly. */
10483 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10484 TREE_TYPE (rse->expr), lse->expr);
10485 gfc_add_modify (&block, tmp, rse->expr);
10486 }
10487 }
10488 else if (ts.type != BT_CLASS)
10489 {
10490 gfc_add_block_to_block (&block, &lse->pre);
10491 gfc_add_block_to_block (&block, &rse->pre);
10492
10493 gfc_add_modify (&block, lse->expr,
10494 fold_convert (TREE_TYPE (lse->expr), rse->expr));
10495 }
10496
10497 gfc_add_block_to_block (&block, &lse->post);
10498 gfc_add_block_to_block (&block, &rse->post);
10499
10500 return gfc_finish_block (&block);
10501 }
10502
10503
10504 /* There are quite a lot of restrictions on the optimisation in using an
10505 array function assign without a temporary. */
10506
10507 static bool
arrayfunc_assign_needs_temporary(gfc_expr * expr1,gfc_expr * expr2)10508 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
10509 {
10510 gfc_ref * ref;
10511 bool seen_array_ref;
10512 bool c = false;
10513 gfc_symbol *sym = expr1->symtree->n.sym;
10514
10515 /* Play it safe with class functions assigned to a derived type. */
10516 if (gfc_is_class_array_function (expr2)
10517 && expr1->ts.type == BT_DERIVED)
10518 return true;
10519
10520 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10521 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
10522 return true;
10523
10524 /* Elemental functions are scalarized so that they don't need a
10525 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10526 they would need special treatment in gfc_trans_arrayfunc_assign. */
10527 if (expr2->value.function.esym != NULL
10528 && expr2->value.function.esym->attr.elemental)
10529 return true;
10530
10531 /* Need a temporary if rhs is not FULL or a contiguous section. */
10532 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
10533 return true;
10534
10535 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
10536 if (gfc_ref_needs_temporary_p (expr1->ref))
10537 return true;
10538
10539 /* Functions returning pointers or allocatables need temporaries. */
10540 if (gfc_expr_attr (expr2).pointer
10541 || gfc_expr_attr (expr2).allocatable)
10542 return true;
10543
10544 /* Character array functions need temporaries unless the
10545 character lengths are the same. */
10546 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
10547 {
10548 if (expr1->ts.u.cl->length == NULL
10549 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10550 return true;
10551
10552 if (expr2->ts.u.cl->length == NULL
10553 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10554 return true;
10555
10556 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
10557 expr2->ts.u.cl->length->value.integer) != 0)
10558 return true;
10559 }
10560
10561 /* Check that no LHS component references appear during an array
10562 reference. This is needed because we do not have the means to
10563 span any arbitrary stride with an array descriptor. This check
10564 is not needed for the rhs because the function result has to be
10565 a complete type. */
10566 seen_array_ref = false;
10567 for (ref = expr1->ref; ref; ref = ref->next)
10568 {
10569 if (ref->type == REF_ARRAY)
10570 seen_array_ref= true;
10571 else if (ref->type == REF_COMPONENT && seen_array_ref)
10572 return true;
10573 }
10574
10575 /* Check for a dependency. */
10576 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
10577 expr2->value.function.esym,
10578 expr2->value.function.actual,
10579 NOT_ELEMENTAL))
10580 return true;
10581
10582 /* If we have reached here with an intrinsic function, we do not
10583 need a temporary except in the particular case that reallocation
10584 on assignment is active and the lhs is allocatable and a target,
10585 or a pointer which may be a subref pointer. FIXME: The last
10586 condition can go away when we use span in the intrinsics
10587 directly.*/
10588 if (expr2->value.function.isym)
10589 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
10590 || (sym->attr.pointer && sym->attr.subref_array_pointer);
10591
10592 /* If the LHS is a dummy, we need a temporary if it is not
10593 INTENT(OUT). */
10594 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
10595 return true;
10596
10597 /* If the lhs has been host_associated, is in common, a pointer or is
10598 a target and the function is not using a RESULT variable, aliasing
10599 can occur and a temporary is needed. */
10600 if ((sym->attr.host_assoc
10601 || sym->attr.in_common
10602 || sym->attr.pointer
10603 || sym->attr.cray_pointee
10604 || sym->attr.target)
10605 && expr2->symtree != NULL
10606 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
10607 return true;
10608
10609 /* A PURE function can unconditionally be called without a temporary. */
10610 if (expr2->value.function.esym != NULL
10611 && expr2->value.function.esym->attr.pure)
10612 return false;
10613
10614 /* Implicit_pure functions are those which could legally be declared
10615 to be PURE. */
10616 if (expr2->value.function.esym != NULL
10617 && expr2->value.function.esym->attr.implicit_pure)
10618 return false;
10619
10620 if (!sym->attr.use_assoc
10621 && !sym->attr.in_common
10622 && !sym->attr.pointer
10623 && !sym->attr.target
10624 && !sym->attr.cray_pointee
10625 && expr2->value.function.esym)
10626 {
10627 /* A temporary is not needed if the function is not contained and
10628 the variable is local or host associated and not a pointer or
10629 a target. */
10630 if (!expr2->value.function.esym->attr.contained)
10631 return false;
10632
10633 /* A temporary is not needed if the lhs has never been host
10634 associated and the procedure is contained. */
10635 else if (!sym->attr.host_assoc)
10636 return false;
10637
10638 /* A temporary is not needed if the variable is local and not
10639 a pointer, a target or a result. */
10640 if (sym->ns->parent
10641 && expr2->value.function.esym->ns == sym->ns->parent)
10642 return false;
10643 }
10644
10645 /* Default to temporary use. */
10646 return true;
10647 }
10648
10649
10650 /* Provide the loop info so that the lhs descriptor can be built for
10651 reallocatable assignments from extrinsic function calls. */
10652
10653 static void
realloc_lhs_loop_for_fcn_call(gfc_se * se,locus * where,gfc_ss ** ss,gfc_loopinfo * loop)10654 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
10655 gfc_loopinfo *loop)
10656 {
10657 /* Signal that the function call should not be made by
10658 gfc_conv_loop_setup. */
10659 se->ss->is_alloc_lhs = 1;
10660 gfc_init_loopinfo (loop);
10661 gfc_add_ss_to_loop (loop, *ss);
10662 gfc_add_ss_to_loop (loop, se->ss);
10663 gfc_conv_ss_startstride (loop);
10664 gfc_conv_loop_setup (loop, where);
10665 gfc_copy_loopinfo_to_se (se, loop);
10666 gfc_add_block_to_block (&se->pre, &loop->pre);
10667 gfc_add_block_to_block (&se->pre, &loop->post);
10668 se->ss->is_alloc_lhs = 0;
10669 }
10670
10671
10672 /* For assignment to a reallocatable lhs from intrinsic functions,
10673 replace the se.expr (ie. the result) with a temporary descriptor.
10674 Null the data field so that the library allocates space for the
10675 result. Free the data of the original descriptor after the function,
10676 in case it appears in an argument expression and transfer the
10677 result to the original descriptor. */
10678
10679 static void
fcncall_realloc_result(gfc_se * se,int rank)10680 fcncall_realloc_result (gfc_se *se, int rank)
10681 {
10682 tree desc;
10683 tree res_desc;
10684 tree tmp;
10685 tree offset;
10686 tree zero_cond;
10687 tree not_same_shape;
10688 stmtblock_t shape_block;
10689 int n;
10690
10691 /* Use the allocation done by the library. Substitute the lhs
10692 descriptor with a copy, whose data field is nulled.*/
10693 desc = build_fold_indirect_ref_loc (input_location, se->expr);
10694 if (POINTER_TYPE_P (TREE_TYPE (desc)))
10695 desc = build_fold_indirect_ref_loc (input_location, desc);
10696
10697 /* Unallocated, the descriptor does not have a dtype. */
10698 tmp = gfc_conv_descriptor_dtype (desc);
10699 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
10700
10701 res_desc = gfc_evaluate_now (desc, &se->pre);
10702 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
10703 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
10704
10705 /* Free the lhs after the function call and copy the result data to
10706 the lhs descriptor. */
10707 tmp = gfc_conv_descriptor_data_get (desc);
10708 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
10709 logical_type_node, tmp,
10710 build_int_cst (TREE_TYPE (tmp), 0));
10711 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
10712 tmp = gfc_call_free (tmp);
10713 gfc_add_expr_to_block (&se->post, tmp);
10714
10715 tmp = gfc_conv_descriptor_data_get (res_desc);
10716 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
10717
10718 /* Check that the shapes are the same between lhs and expression.
10719 The evaluation of the shape is done in 'shape_block' to avoid
10720 unitialized warnings from the lhs bounds. */
10721 not_same_shape = boolean_false_node;
10722 gfc_start_block (&shape_block);
10723 for (n = 0 ; n < rank; n++)
10724 {
10725 tree tmp1;
10726 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10727 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
10728 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10729 gfc_array_index_type, tmp, tmp1);
10730 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
10731 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10732 gfc_array_index_type, tmp, tmp1);
10733 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
10734 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10735 gfc_array_index_type, tmp, tmp1);
10736 tmp = fold_build2_loc (input_location, NE_EXPR,
10737 logical_type_node, tmp,
10738 gfc_index_zero_node);
10739 tmp = gfc_evaluate_now (tmp, &shape_block);
10740 if (n == 0)
10741 not_same_shape = tmp;
10742 else
10743 not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10744 logical_type_node, tmp,
10745 not_same_shape);
10746 }
10747
10748 /* 'zero_cond' being true is equal to lhs not being allocated or the
10749 shapes being different. */
10750 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
10751 zero_cond, not_same_shape);
10752 gfc_add_modify (&shape_block, zero_cond, tmp);
10753 tmp = gfc_finish_block (&shape_block);
10754 tmp = build3_v (COND_EXPR, zero_cond,
10755 build_empty_stmt (input_location), tmp);
10756 gfc_add_expr_to_block (&se->post, tmp);
10757
10758 /* Now reset the bounds returned from the function call to bounds based
10759 on the lhs lbounds, except where the lhs is not allocated or the shapes
10760 of 'variable and 'expr' are different. Set the offset accordingly. */
10761 offset = gfc_index_zero_node;
10762 for (n = 0 ; n < rank; n++)
10763 {
10764 tree lbound;
10765
10766 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10767 lbound = fold_build3_loc (input_location, COND_EXPR,
10768 gfc_array_index_type, zero_cond,
10769 gfc_index_one_node, lbound);
10770 lbound = gfc_evaluate_now (lbound, &se->post);
10771
10772 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
10773 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10774 gfc_array_index_type, tmp, lbound);
10775 gfc_conv_descriptor_lbound_set (&se->post, desc,
10776 gfc_rank_cst[n], lbound);
10777 gfc_conv_descriptor_ubound_set (&se->post, desc,
10778 gfc_rank_cst[n], tmp);
10779
10780 /* Set stride and accumulate the offset. */
10781 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
10782 gfc_conv_descriptor_stride_set (&se->post, desc,
10783 gfc_rank_cst[n], tmp);
10784 tmp = fold_build2_loc (input_location, MULT_EXPR,
10785 gfc_array_index_type, lbound, tmp);
10786 offset = fold_build2_loc (input_location, MINUS_EXPR,
10787 gfc_array_index_type, offset, tmp);
10788 offset = gfc_evaluate_now (offset, &se->post);
10789 }
10790
10791 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
10792 }
10793
10794
10795
10796 /* Try to translate array(:) = func (...), where func is a transformational
10797 array function, without using a temporary. Returns NULL if this isn't the
10798 case. */
10799
10800 static tree
gfc_trans_arrayfunc_assign(gfc_expr * expr1,gfc_expr * expr2)10801 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
10802 {
10803 gfc_se se;
10804 gfc_ss *ss = NULL;
10805 gfc_component *comp = NULL;
10806 gfc_loopinfo loop;
10807
10808 if (arrayfunc_assign_needs_temporary (expr1, expr2))
10809 return NULL;
10810
10811 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10812 functions. */
10813 comp = gfc_get_proc_ptr_comp (expr2);
10814
10815 if (!(expr2->value.function.isym
10816 || (comp && comp->attr.dimension)
10817 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
10818 && expr2->value.function.esym->result->attr.dimension)))
10819 return NULL;
10820
10821 gfc_init_se (&se, NULL);
10822 gfc_start_block (&se.pre);
10823 se.want_pointer = 1;
10824
10825 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
10826
10827 if (expr1->ts.type == BT_DERIVED
10828 && expr1->ts.u.derived->attr.alloc_comp)
10829 {
10830 tree tmp;
10831 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
10832 expr1->rank);
10833 gfc_add_expr_to_block (&se.pre, tmp);
10834 }
10835
10836 se.direct_byref = 1;
10837 se.ss = gfc_walk_expr (expr2);
10838 gcc_assert (se.ss != gfc_ss_terminator);
10839
10840 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10841 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10842 Clearly, this cannot be done for an allocatable function result, since
10843 the shape of the result is unknown and, in any case, the function must
10844 correctly take care of the reallocation internally. For intrinsic
10845 calls, the array data is freed and the library takes care of allocation.
10846 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10847 to the library. */
10848 if (flag_realloc_lhs
10849 && gfc_is_reallocatable_lhs (expr1)
10850 && !gfc_expr_attr (expr1).codimension
10851 && !gfc_is_coindexed (expr1)
10852 && !(expr2->value.function.esym
10853 && expr2->value.function.esym->result->attr.allocatable))
10854 {
10855 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10856
10857 if (!expr2->value.function.isym)
10858 {
10859 ss = gfc_walk_expr (expr1);
10860 gcc_assert (ss != gfc_ss_terminator);
10861
10862 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
10863 ss->is_alloc_lhs = 1;
10864 }
10865 else
10866 fcncall_realloc_result (&se, expr1->rank);
10867 }
10868
10869 gfc_conv_function_expr (&se, expr2);
10870 gfc_add_block_to_block (&se.pre, &se.post);
10871
10872 if (ss)
10873 gfc_cleanup_loop (&loop);
10874 else
10875 gfc_free_ss_chain (se.ss);
10876
10877 return gfc_finish_block (&se.pre);
10878 }
10879
10880
10881 /* Try to efficiently translate array(:) = 0. Return NULL if this
10882 can't be done. */
10883
10884 static tree
gfc_trans_zero_assign(gfc_expr * expr)10885 gfc_trans_zero_assign (gfc_expr * expr)
10886 {
10887 tree dest, len, type;
10888 tree tmp;
10889 gfc_symbol *sym;
10890
10891 sym = expr->symtree->n.sym;
10892 dest = gfc_get_symbol_decl (sym);
10893
10894 type = TREE_TYPE (dest);
10895 if (POINTER_TYPE_P (type))
10896 type = TREE_TYPE (type);
10897 if (!GFC_ARRAY_TYPE_P (type))
10898 return NULL_TREE;
10899
10900 /* Determine the length of the array. */
10901 len = GFC_TYPE_ARRAY_SIZE (type);
10902 if (!len || TREE_CODE (len) != INTEGER_CST)
10903 return NULL_TREE;
10904
10905 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10906 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10907 fold_convert (gfc_array_index_type, tmp));
10908
10909 /* If we are zeroing a local array avoid taking its address by emitting
10910 a = {} instead. */
10911 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
10912 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
10913 dest, build_constructor (TREE_TYPE (dest),
10914 NULL));
10915
10916 /* Convert arguments to the correct types. */
10917 dest = fold_convert (pvoid_type_node, dest);
10918 len = fold_convert (size_type_node, len);
10919
10920 /* Construct call to __builtin_memset. */
10921 tmp = build_call_expr_loc (input_location,
10922 builtin_decl_explicit (BUILT_IN_MEMSET),
10923 3, dest, integer_zero_node, len);
10924 return fold_convert (void_type_node, tmp);
10925 }
10926
10927
10928 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10929 that constructs the call to __builtin_memcpy. */
10930
10931 tree
gfc_build_memcpy_call(tree dst,tree src,tree len)10932 gfc_build_memcpy_call (tree dst, tree src, tree len)
10933 {
10934 tree tmp;
10935
10936 /* Convert arguments to the correct types. */
10937 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
10938 dst = gfc_build_addr_expr (pvoid_type_node, dst);
10939 else
10940 dst = fold_convert (pvoid_type_node, dst);
10941
10942 if (!POINTER_TYPE_P (TREE_TYPE (src)))
10943 src = gfc_build_addr_expr (pvoid_type_node, src);
10944 else
10945 src = fold_convert (pvoid_type_node, src);
10946
10947 len = fold_convert (size_type_node, len);
10948
10949 /* Construct call to __builtin_memcpy. */
10950 tmp = build_call_expr_loc (input_location,
10951 builtin_decl_explicit (BUILT_IN_MEMCPY),
10952 3, dst, src, len);
10953 return fold_convert (void_type_node, tmp);
10954 }
10955
10956
10957 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10958 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10959 source/rhs, both are gfc_full_array_ref_p which have been checked for
10960 dependencies. */
10961
10962 static tree
gfc_trans_array_copy(gfc_expr * expr1,gfc_expr * expr2)10963 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
10964 {
10965 tree dst, dlen, dtype;
10966 tree src, slen, stype;
10967 tree tmp;
10968
10969 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10970 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
10971
10972 dtype = TREE_TYPE (dst);
10973 if (POINTER_TYPE_P (dtype))
10974 dtype = TREE_TYPE (dtype);
10975 stype = TREE_TYPE (src);
10976 if (POINTER_TYPE_P (stype))
10977 stype = TREE_TYPE (stype);
10978
10979 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
10980 return NULL_TREE;
10981
10982 /* Determine the lengths of the arrays. */
10983 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
10984 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
10985 return NULL_TREE;
10986 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10987 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10988 dlen, fold_convert (gfc_array_index_type, tmp));
10989
10990 slen = GFC_TYPE_ARRAY_SIZE (stype);
10991 if (!slen || TREE_CODE (slen) != INTEGER_CST)
10992 return NULL_TREE;
10993 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
10994 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10995 slen, fold_convert (gfc_array_index_type, tmp));
10996
10997 /* Sanity check that they are the same. This should always be
10998 the case, as we should already have checked for conformance. */
10999 if (!tree_int_cst_equal (slen, dlen))
11000 return NULL_TREE;
11001
11002 return gfc_build_memcpy_call (dst, src, dlen);
11003 }
11004
11005
11006 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
11007 this can't be done. EXPR1 is the destination/lhs for which
11008 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
11009
11010 static tree
gfc_trans_array_constructor_copy(gfc_expr * expr1,gfc_expr * expr2)11011 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
11012 {
11013 unsigned HOST_WIDE_INT nelem;
11014 tree dst, dtype;
11015 tree src, stype;
11016 tree len;
11017 tree tmp;
11018
11019 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
11020 if (nelem == 0)
11021 return NULL_TREE;
11022
11023 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
11024 dtype = TREE_TYPE (dst);
11025 if (POINTER_TYPE_P (dtype))
11026 dtype = TREE_TYPE (dtype);
11027 if (!GFC_ARRAY_TYPE_P (dtype))
11028 return NULL_TREE;
11029
11030 /* Determine the lengths of the array. */
11031 len = GFC_TYPE_ARRAY_SIZE (dtype);
11032 if (!len || TREE_CODE (len) != INTEGER_CST)
11033 return NULL_TREE;
11034
11035 /* Confirm that the constructor is the same size. */
11036 if (compare_tree_int (len, nelem) != 0)
11037 return NULL_TREE;
11038
11039 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
11040 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
11041 fold_convert (gfc_array_index_type, tmp));
11042
11043 stype = gfc_typenode_for_spec (&expr2->ts);
11044 src = gfc_build_constant_array_constructor (expr2, stype);
11045
11046 return gfc_build_memcpy_call (dst, src, len);
11047 }
11048
11049
11050 /* Tells whether the expression is to be treated as a variable reference. */
11051
11052 bool
gfc_expr_is_variable(gfc_expr * expr)11053 gfc_expr_is_variable (gfc_expr *expr)
11054 {
11055 gfc_expr *arg;
11056 gfc_component *comp;
11057 gfc_symbol *func_ifc;
11058
11059 if (expr->expr_type == EXPR_VARIABLE)
11060 return true;
11061
11062 arg = gfc_get_noncopying_intrinsic_argument (expr);
11063 if (arg)
11064 {
11065 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
11066 return gfc_expr_is_variable (arg);
11067 }
11068
11069 /* A data-pointer-returning function should be considered as a variable
11070 too. */
11071 if (expr->expr_type == EXPR_FUNCTION
11072 && expr->ref == NULL)
11073 {
11074 if (expr->value.function.isym != NULL)
11075 return false;
11076
11077 if (expr->value.function.esym != NULL)
11078 {
11079 func_ifc = expr->value.function.esym;
11080 goto found_ifc;
11081 }
11082 gcc_assert (expr->symtree);
11083 func_ifc = expr->symtree->n.sym;
11084 goto found_ifc;
11085 }
11086
11087 comp = gfc_get_proc_ptr_comp (expr);
11088 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
11089 && comp)
11090 {
11091 func_ifc = comp->ts.interface;
11092 goto found_ifc;
11093 }
11094
11095 if (expr->expr_type == EXPR_COMPCALL)
11096 {
11097 gcc_assert (!expr->value.compcall.tbp->is_generic);
11098 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
11099 goto found_ifc;
11100 }
11101
11102 return false;
11103
11104 found_ifc:
11105 gcc_assert (func_ifc->attr.function
11106 && func_ifc->result != NULL);
11107 return func_ifc->result->attr.pointer;
11108 }
11109
11110
11111 /* Is the lhs OK for automatic reallocation? */
11112
11113 static bool
is_scalar_reallocatable_lhs(gfc_expr * expr)11114 is_scalar_reallocatable_lhs (gfc_expr *expr)
11115 {
11116 gfc_ref * ref;
11117
11118 /* An allocatable variable with no reference. */
11119 if (expr->symtree->n.sym->attr.allocatable
11120 && !expr->ref)
11121 return true;
11122
11123 /* All that can be left are allocatable components. However, we do
11124 not check for allocatable components here because the expression
11125 could be an allocatable component of a pointer component. */
11126 if (expr->symtree->n.sym->ts.type != BT_DERIVED
11127 && expr->symtree->n.sym->ts.type != BT_CLASS)
11128 return false;
11129
11130 /* Find an allocatable component ref last. */
11131 for (ref = expr->ref; ref; ref = ref->next)
11132 if (ref->type == REF_COMPONENT
11133 && !ref->next
11134 && ref->u.c.component->attr.allocatable)
11135 return true;
11136
11137 return false;
11138 }
11139
11140
11141 /* Allocate or reallocate scalar lhs, as necessary. */
11142
11143 static void
alloc_scalar_allocatable_for_assignment(stmtblock_t * block,tree string_length,gfc_expr * expr1,gfc_expr * expr2)11144 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
11145 tree string_length,
11146 gfc_expr *expr1,
11147 gfc_expr *expr2)
11148
11149 {
11150 tree cond;
11151 tree tmp;
11152 tree size;
11153 tree size_in_bytes;
11154 tree jump_label1;
11155 tree jump_label2;
11156 gfc_se lse;
11157 gfc_ref *ref;
11158
11159 if (!expr1 || expr1->rank)
11160 return;
11161
11162 if (!expr2 || expr2->rank)
11163 return;
11164
11165 for (ref = expr1->ref; ref; ref = ref->next)
11166 if (ref->type == REF_SUBSTRING)
11167 return;
11168
11169 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
11170
11171 /* Since this is a scalar lhs, we can afford to do this. That is,
11172 there is no risk of side effects being repeated. */
11173 gfc_init_se (&lse, NULL);
11174 lse.want_pointer = 1;
11175 gfc_conv_expr (&lse, expr1);
11176
11177 jump_label1 = gfc_build_label_decl (NULL_TREE);
11178 jump_label2 = gfc_build_label_decl (NULL_TREE);
11179
11180 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
11181 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
11182 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11183 lse.expr, tmp);
11184 tmp = build3_v (COND_EXPR, cond,
11185 build1_v (GOTO_EXPR, jump_label1),
11186 build_empty_stmt (input_location));
11187 gfc_add_expr_to_block (block, tmp);
11188
11189 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11190 {
11191 /* Use the rhs string length and the lhs element size. */
11192 size = string_length;
11193 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
11194 tmp = TYPE_SIZE_UNIT (tmp);
11195 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
11196 TREE_TYPE (tmp), tmp,
11197 fold_convert (TREE_TYPE (tmp), size));
11198 }
11199 else
11200 {
11201 /* Otherwise use the length in bytes of the rhs. */
11202 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
11203 size_in_bytes = size;
11204 }
11205
11206 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11207 size_in_bytes, size_one_node);
11208
11209 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
11210 {
11211 tree caf_decl, token;
11212 gfc_se caf_se;
11213 symbol_attribute attr;
11214
11215 gfc_clear_attr (&attr);
11216 gfc_init_se (&caf_se, NULL);
11217
11218 caf_decl = gfc_get_tree_for_caf_expr (expr1);
11219 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
11220 NULL);
11221 gfc_add_block_to_block (block, &caf_se.pre);
11222 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
11223 gfc_build_addr_expr (NULL_TREE, token),
11224 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
11225 expr1, 1);
11226 }
11227 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
11228 {
11229 tmp = build_call_expr_loc (input_location,
11230 builtin_decl_explicit (BUILT_IN_CALLOC),
11231 2, build_one_cst (size_type_node),
11232 size_in_bytes);
11233 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11234 gfc_add_modify (block, lse.expr, tmp);
11235 }
11236 else
11237 {
11238 tmp = build_call_expr_loc (input_location,
11239 builtin_decl_explicit (BUILT_IN_MALLOC),
11240 1, size_in_bytes);
11241 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11242 gfc_add_modify (block, lse.expr, tmp);
11243 }
11244
11245 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11246 {
11247 /* Deferred characters need checking for lhs and rhs string
11248 length. Other deferred parameter variables will have to
11249 come here too. */
11250 tmp = build1_v (GOTO_EXPR, jump_label2);
11251 gfc_add_expr_to_block (block, tmp);
11252 }
11253 tmp = build1_v (LABEL_EXPR, jump_label1);
11254 gfc_add_expr_to_block (block, tmp);
11255
11256 /* For a deferred length character, reallocate if lengths of lhs and
11257 rhs are different. */
11258 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11259 {
11260 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11261 lse.string_length,
11262 fold_convert (TREE_TYPE (lse.string_length),
11263 size));
11264 /* Jump past the realloc if the lengths are the same. */
11265 tmp = build3_v (COND_EXPR, cond,
11266 build1_v (GOTO_EXPR, jump_label2),
11267 build_empty_stmt (input_location));
11268 gfc_add_expr_to_block (block, tmp);
11269 tmp = build_call_expr_loc (input_location,
11270 builtin_decl_explicit (BUILT_IN_REALLOC),
11271 2, fold_convert (pvoid_type_node, lse.expr),
11272 size_in_bytes);
11273 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11274 gfc_add_modify (block, lse.expr, tmp);
11275 tmp = build1_v (LABEL_EXPR, jump_label2);
11276 gfc_add_expr_to_block (block, tmp);
11277
11278 /* Update the lhs character length. */
11279 size = string_length;
11280 gfc_add_modify (block, lse.string_length,
11281 fold_convert (TREE_TYPE (lse.string_length), size));
11282 }
11283 }
11284
11285 /* Check for assignments of the type
11286
11287 a = a + 4
11288
11289 to make sure we do not check for reallocation unneccessarily. */
11290
11291
11292 static bool
is_runtime_conformable(gfc_expr * expr1,gfc_expr * expr2)11293 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
11294 {
11295 gfc_actual_arglist *a;
11296 gfc_expr *e1, *e2;
11297
11298 switch (expr2->expr_type)
11299 {
11300 case EXPR_VARIABLE:
11301 return gfc_dep_compare_expr (expr1, expr2) == 0;
11302
11303 case EXPR_FUNCTION:
11304 if (expr2->value.function.esym
11305 && expr2->value.function.esym->attr.elemental)
11306 {
11307 for (a = expr2->value.function.actual; a != NULL; a = a->next)
11308 {
11309 e1 = a->expr;
11310 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
11311 return false;
11312 }
11313 return true;
11314 }
11315 else if (expr2->value.function.isym
11316 && expr2->value.function.isym->elemental)
11317 {
11318 for (a = expr2->value.function.actual; a != NULL; a = a->next)
11319 {
11320 e1 = a->expr;
11321 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
11322 return false;
11323 }
11324 return true;
11325 }
11326
11327 break;
11328
11329 case EXPR_OP:
11330 switch (expr2->value.op.op)
11331 {
11332 case INTRINSIC_NOT:
11333 case INTRINSIC_UPLUS:
11334 case INTRINSIC_UMINUS:
11335 case INTRINSIC_PARENTHESES:
11336 return is_runtime_conformable (expr1, expr2->value.op.op1);
11337
11338 case INTRINSIC_PLUS:
11339 case INTRINSIC_MINUS:
11340 case INTRINSIC_TIMES:
11341 case INTRINSIC_DIVIDE:
11342 case INTRINSIC_POWER:
11343 case INTRINSIC_AND:
11344 case INTRINSIC_OR:
11345 case INTRINSIC_EQV:
11346 case INTRINSIC_NEQV:
11347 case INTRINSIC_EQ:
11348 case INTRINSIC_NE:
11349 case INTRINSIC_GT:
11350 case INTRINSIC_GE:
11351 case INTRINSIC_LT:
11352 case INTRINSIC_LE:
11353 case INTRINSIC_EQ_OS:
11354 case INTRINSIC_NE_OS:
11355 case INTRINSIC_GT_OS:
11356 case INTRINSIC_GE_OS:
11357 case INTRINSIC_LT_OS:
11358 case INTRINSIC_LE_OS:
11359
11360 e1 = expr2->value.op.op1;
11361 e2 = expr2->value.op.op2;
11362
11363 if (e1->rank == 0 && e2->rank > 0)
11364 return is_runtime_conformable (expr1, e2);
11365 else if (e1->rank > 0 && e2->rank == 0)
11366 return is_runtime_conformable (expr1, e1);
11367 else if (e1->rank > 0 && e2->rank > 0)
11368 return is_runtime_conformable (expr1, e1)
11369 && is_runtime_conformable (expr1, e2);
11370 break;
11371
11372 default:
11373 break;
11374
11375 }
11376
11377 break;
11378
11379 default:
11380 break;
11381 }
11382 return false;
11383 }
11384
11385
11386 static tree
trans_class_assignment(stmtblock_t * block,gfc_expr * lhs,gfc_expr * rhs,gfc_se * lse,gfc_se * rse,bool use_vptr_copy,bool class_realloc)11387 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
11388 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
11389 bool class_realloc)
11390 {
11391 tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
11392 vec<tree, va_gc> *args = NULL;
11393
11394 /* Store the old vptr so that dynamic types can be compared for
11395 reallocation to occur or not. */
11396 if (class_realloc)
11397 {
11398 tmp = lse->expr;
11399 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
11400 tmp = gfc_get_class_from_expr (tmp);
11401 }
11402
11403 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
11404 &from_len);
11405
11406 /* Generate (re)allocation of the lhs. */
11407 if (class_realloc)
11408 {
11409 stmtblock_t alloc, re_alloc;
11410 tree class_han, re, size;
11411
11412 if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
11413 old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
11414 else
11415 old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
11416
11417 size = gfc_vptr_size_get (vptr);
11418 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11419 ? gfc_class_data_get (lse->expr) : lse->expr;
11420
11421 /* Allocate block. */
11422 gfc_init_block (&alloc);
11423 gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
11424
11425 /* Reallocate if dynamic types are different. */
11426 gfc_init_block (&re_alloc);
11427 re = build_call_expr_loc (input_location,
11428 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
11429 fold_convert (pvoid_type_node, class_han),
11430 size);
11431 tmp = fold_build2_loc (input_location, NE_EXPR,
11432 logical_type_node, vptr, old_vptr);
11433 re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
11434 tmp, re, build_empty_stmt (input_location));
11435 gfc_add_expr_to_block (&re_alloc, re);
11436
11437 /* Allocate if _data is NULL, reallocate otherwise. */
11438 tmp = fold_build2_loc (input_location, EQ_EXPR,
11439 logical_type_node, class_han,
11440 build_int_cst (prvoid_type_node, 0));
11441 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
11442 gfc_unlikely (tmp,
11443 PRED_FORTRAN_FAIL_ALLOC),
11444 gfc_finish_block (&alloc),
11445 gfc_finish_block (&re_alloc));
11446 gfc_add_expr_to_block (&lse->pre, tmp);
11447 }
11448
11449 fcn = gfc_vptr_copy_get (vptr);
11450
11451 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
11452 ? gfc_class_data_get (rse->expr) : rse->expr;
11453 if (use_vptr_copy)
11454 {
11455 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
11456 || INDIRECT_REF_P (tmp)
11457 || (rhs->ts.type == BT_DERIVED
11458 && rhs->ts.u.derived->attr.unlimited_polymorphic
11459 && !rhs->ts.u.derived->attr.pointer
11460 && !rhs->ts.u.derived->attr.allocatable)
11461 || (UNLIMITED_POLY (rhs)
11462 && !CLASS_DATA (rhs)->attr.pointer
11463 && !CLASS_DATA (rhs)->attr.allocatable))
11464 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
11465 else
11466 vec_safe_push (args, tmp);
11467 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11468 ? gfc_class_data_get (lse->expr) : lse->expr;
11469 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
11470 || INDIRECT_REF_P (tmp)
11471 || (lhs->ts.type == BT_DERIVED
11472 && lhs->ts.u.derived->attr.unlimited_polymorphic
11473 && !lhs->ts.u.derived->attr.pointer
11474 && !lhs->ts.u.derived->attr.allocatable)
11475 || (UNLIMITED_POLY (lhs)
11476 && !CLASS_DATA (lhs)->attr.pointer
11477 && !CLASS_DATA (lhs)->attr.allocatable))
11478 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
11479 else
11480 vec_safe_push (args, tmp);
11481
11482 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
11483
11484 if (to_len != NULL_TREE && !integer_zerop (from_len))
11485 {
11486 tree extcopy;
11487 vec_safe_push (args, from_len);
11488 vec_safe_push (args, to_len);
11489 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
11490
11491 tmp = fold_build2_loc (input_location, GT_EXPR,
11492 logical_type_node, from_len,
11493 build_zero_cst (TREE_TYPE (from_len)));
11494 return fold_build3_loc (input_location, COND_EXPR,
11495 void_type_node, tmp,
11496 extcopy, stdcopy);
11497 }
11498 else
11499 return stdcopy;
11500 }
11501 else
11502 {
11503 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11504 ? gfc_class_data_get (lse->expr) : lse->expr;
11505 stmtblock_t tblock;
11506 gfc_init_block (&tblock);
11507 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
11508 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
11509 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
11510 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
11511 /* When coming from a ptr_copy lhs and rhs are swapped. */
11512 gfc_add_modify_loc (input_location, &tblock, rhst,
11513 fold_convert (TREE_TYPE (rhst), tmp));
11514 return gfc_finish_block (&tblock);
11515 }
11516 }
11517
11518 /* Subroutine of gfc_trans_assignment that actually scalarizes the
11519 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
11520 init_flag indicates initialization expressions and dealloc that no
11521 deallocate prior assignment is needed (if in doubt, set true).
11522 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
11523 routine instead of a pointer assignment. Alias resolution is only done,
11524 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
11525 where it is known, that newly allocated memory on the lhs can never be
11526 an alias of the rhs. */
11527
11528 static tree
gfc_trans_assignment_1(gfc_expr * expr1,gfc_expr * expr2,bool init_flag,bool dealloc,bool use_vptr_copy,bool may_alias)11529 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11530 bool dealloc, bool use_vptr_copy, bool may_alias)
11531 {
11532 gfc_se lse;
11533 gfc_se rse;
11534 gfc_ss *lss;
11535 gfc_ss *lss_section;
11536 gfc_ss *rss;
11537 gfc_loopinfo loop;
11538 tree tmp;
11539 stmtblock_t block;
11540 stmtblock_t body;
11541 bool l_is_temp;
11542 bool scalar_to_array;
11543 tree string_length;
11544 int n;
11545 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
11546 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
11547 bool is_poly_assign;
11548 bool realloc_flag;
11549
11550 /* Assignment of the form lhs = rhs. */
11551 gfc_start_block (&block);
11552
11553 gfc_init_se (&lse, NULL);
11554 gfc_init_se (&rse, NULL);
11555
11556 /* Walk the lhs. */
11557 lss = gfc_walk_expr (expr1);
11558 if (gfc_is_reallocatable_lhs (expr1))
11559 {
11560 lss->no_bounds_check = 1;
11561 if (!(expr2->expr_type == EXPR_FUNCTION
11562 && expr2->value.function.isym != NULL
11563 && !(expr2->value.function.isym->elemental
11564 || expr2->value.function.isym->conversion)))
11565 lss->is_alloc_lhs = 1;
11566 }
11567 else
11568 lss->no_bounds_check = expr1->no_bounds_check;
11569
11570 rss = NULL;
11571
11572 if ((expr1->ts.type == BT_DERIVED)
11573 && (gfc_is_class_array_function (expr2)
11574 || gfc_is_alloc_class_scalar_function (expr2)))
11575 expr2->must_finalize = 1;
11576
11577 /* Checking whether a class assignment is desired is quite complicated and
11578 needed at two locations, so do it once only before the information is
11579 needed. */
11580 lhs_attr = gfc_expr_attr (expr1);
11581 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
11582 || (lhs_attr.allocatable && !lhs_attr.dimension))
11583 && (expr1->ts.type == BT_CLASS
11584 || gfc_is_class_array_ref (expr1, NULL)
11585 || gfc_is_class_scalar_expr (expr1)
11586 || gfc_is_class_array_ref (expr2, NULL)
11587 || gfc_is_class_scalar_expr (expr2))
11588 && lhs_attr.flavor != FL_PROCEDURE;
11589
11590 realloc_flag = flag_realloc_lhs
11591 && gfc_is_reallocatable_lhs (expr1)
11592 && expr2->rank
11593 && !is_runtime_conformable (expr1, expr2);
11594
11595 /* Only analyze the expressions for coarray properties, when in coarray-lib
11596 mode. */
11597 if (flag_coarray == GFC_FCOARRAY_LIB)
11598 {
11599 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
11600 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
11601 }
11602
11603 if (lss != gfc_ss_terminator)
11604 {
11605 /* The assignment needs scalarization. */
11606 lss_section = lss;
11607
11608 /* Find a non-scalar SS from the lhs. */
11609 while (lss_section != gfc_ss_terminator
11610 && lss_section->info->type != GFC_SS_SECTION)
11611 lss_section = lss_section->next;
11612
11613 gcc_assert (lss_section != gfc_ss_terminator);
11614
11615 /* Initialize the scalarizer. */
11616 gfc_init_loopinfo (&loop);
11617
11618 /* Walk the rhs. */
11619 rss = gfc_walk_expr (expr2);
11620 if (rss == gfc_ss_terminator)
11621 /* The rhs is scalar. Add a ss for the expression. */
11622 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
11623 /* When doing a class assign, then the handle to the rhs needs to be a
11624 pointer to allow for polymorphism. */
11625 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
11626 rss->info->type = GFC_SS_REFERENCE;
11627
11628 rss->no_bounds_check = expr2->no_bounds_check;
11629 /* Associate the SS with the loop. */
11630 gfc_add_ss_to_loop (&loop, lss);
11631 gfc_add_ss_to_loop (&loop, rss);
11632
11633 /* Calculate the bounds of the scalarization. */
11634 gfc_conv_ss_startstride (&loop);
11635 /* Enable loop reversal. */
11636 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
11637 loop.reverse[n] = GFC_ENABLE_REVERSE;
11638 /* Resolve any data dependencies in the statement. */
11639 if (may_alias)
11640 gfc_conv_resolve_dependencies (&loop, lss, rss);
11641 /* Setup the scalarizing loops. */
11642 gfc_conv_loop_setup (&loop, &expr2->where);
11643
11644 /* Setup the gfc_se structures. */
11645 gfc_copy_loopinfo_to_se (&lse, &loop);
11646 gfc_copy_loopinfo_to_se (&rse, &loop);
11647
11648 rse.ss = rss;
11649 gfc_mark_ss_chain_used (rss, 1);
11650 if (loop.temp_ss == NULL)
11651 {
11652 lse.ss = lss;
11653 gfc_mark_ss_chain_used (lss, 1);
11654 }
11655 else
11656 {
11657 lse.ss = loop.temp_ss;
11658 gfc_mark_ss_chain_used (lss, 3);
11659 gfc_mark_ss_chain_used (loop.temp_ss, 3);
11660 }
11661
11662 /* Allow the scalarizer to workshare array assignments. */
11663 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
11664 == OMPWS_WORKSHARE_FLAG
11665 && loop.temp_ss == NULL)
11666 {
11667 maybe_workshare = true;
11668 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
11669 }
11670
11671 /* Start the scalarized loop body. */
11672 gfc_start_scalarized_body (&loop, &body);
11673 }
11674 else
11675 gfc_init_block (&body);
11676
11677 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
11678
11679 /* Translate the expression. */
11680 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
11681 && lhs_caf_attr.codimension;
11682 gfc_conv_expr (&rse, expr2);
11683
11684 /* Deal with the case of a scalar class function assigned to a derived type. */
11685 if (gfc_is_alloc_class_scalar_function (expr2)
11686 && expr1->ts.type == BT_DERIVED)
11687 {
11688 rse.expr = gfc_class_data_get (rse.expr);
11689 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
11690 }
11691
11692 /* Stabilize a string length for temporaries. */
11693 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
11694 && !(VAR_P (rse.string_length)
11695 || TREE_CODE (rse.string_length) == PARM_DECL
11696 || TREE_CODE (rse.string_length) == INDIRECT_REF))
11697 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
11698 else if (expr2->ts.type == BT_CHARACTER)
11699 {
11700 if (expr1->ts.deferred
11701 && gfc_expr_attr (expr1).allocatable
11702 && gfc_check_dependency (expr1, expr2, true))
11703 rse.string_length =
11704 gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
11705 string_length = rse.string_length;
11706 }
11707 else
11708 string_length = NULL_TREE;
11709
11710 if (l_is_temp)
11711 {
11712 gfc_conv_tmp_array_ref (&lse);
11713 if (expr2->ts.type == BT_CHARACTER)
11714 lse.string_length = string_length;
11715 }
11716 else
11717 {
11718 gfc_conv_expr (&lse, expr1);
11719 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
11720 && !init_flag
11721 && gfc_expr_attr (expr1).allocatable
11722 && expr1->rank
11723 && !expr2->rank)
11724 {
11725 tree cond;
11726 const char* msg;
11727
11728 tmp = INDIRECT_REF_P (lse.expr)
11729 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
11730 STRIP_NOPS (tmp);
11731
11732 /* We should only get array references here. */
11733 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
11734 || TREE_CODE (tmp) == ARRAY_REF);
11735
11736 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
11737 or the array itself(ARRAY_REF). */
11738 tmp = TREE_OPERAND (tmp, 0);
11739
11740 /* Provide the address of the array. */
11741 if (TREE_CODE (lse.expr) == ARRAY_REF)
11742 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
11743
11744 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11745 tmp, build_int_cst (TREE_TYPE (tmp), 0));
11746 msg = _("Assignment of scalar to unallocated array");
11747 gfc_trans_runtime_check (true, false, cond, &loop.pre,
11748 &expr1->where, msg);
11749 }
11750
11751 /* Deallocate the lhs parameterized components if required. */
11752 if (dealloc && expr2->expr_type == EXPR_FUNCTION
11753 && !expr1->symtree->n.sym->attr.associate_var)
11754 {
11755 if (expr1->ts.type == BT_DERIVED
11756 && expr1->ts.u.derived
11757 && expr1->ts.u.derived->attr.pdt_type)
11758 {
11759 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
11760 expr1->rank);
11761 gfc_add_expr_to_block (&lse.pre, tmp);
11762 }
11763 else if (expr1->ts.type == BT_CLASS
11764 && CLASS_DATA (expr1)->ts.u.derived
11765 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
11766 {
11767 tmp = gfc_class_data_get (lse.expr);
11768 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
11769 tmp, expr1->rank);
11770 gfc_add_expr_to_block (&lse.pre, tmp);
11771 }
11772 }
11773 }
11774
11775 /* Assignments of scalar derived types with allocatable components
11776 to arrays must be done with a deep copy and the rhs temporary
11777 must have its components deallocated afterwards. */
11778 scalar_to_array = (expr2->ts.type == BT_DERIVED
11779 && expr2->ts.u.derived->attr.alloc_comp
11780 && !gfc_expr_is_variable (expr2)
11781 && expr1->rank && !expr2->rank);
11782 scalar_to_array |= (expr1->ts.type == BT_DERIVED
11783 && expr1->rank
11784 && expr1->ts.u.derived->attr.alloc_comp
11785 && gfc_is_alloc_class_scalar_function (expr2));
11786 if (scalar_to_array && dealloc)
11787 {
11788 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
11789 gfc_prepend_expr_to_block (&loop.post, tmp);
11790 }
11791
11792 /* When assigning a character function result to a deferred-length variable,
11793 the function call must happen before the (re)allocation of the lhs -
11794 otherwise the character length of the result is not known.
11795 NOTE 1: This relies on having the exact dependence of the length type
11796 parameter available to the caller; gfortran saves it in the .mod files.
11797 NOTE 2: Vector array references generate an index temporary that must
11798 not go outside the loop. Otherwise, variables should not generate
11799 a pre block.
11800 NOTE 3: The concatenation operation generates a temporary pointer,
11801 whose allocation must go to the innermost loop.
11802 NOTE 4: Elemental functions may generate a temporary, too. */
11803 if (flag_realloc_lhs
11804 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
11805 && !(lss != gfc_ss_terminator
11806 && rss != gfc_ss_terminator
11807 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
11808 || (expr2->expr_type == EXPR_FUNCTION
11809 && expr2->value.function.esym != NULL
11810 && expr2->value.function.esym->attr.elemental)
11811 || (expr2->expr_type == EXPR_FUNCTION
11812 && expr2->value.function.isym != NULL
11813 && expr2->value.function.isym->elemental)
11814 || (expr2->expr_type == EXPR_OP
11815 && expr2->value.op.op == INTRINSIC_CONCAT))))
11816 gfc_add_block_to_block (&block, &rse.pre);
11817
11818 /* Nullify the allocatable components corresponding to those of the lhs
11819 derived type, so that the finalization of the function result does not
11820 affect the lhs of the assignment. Prepend is used to ensure that the
11821 nullification occurs before the call to the finalizer. In the case of
11822 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11823 as part of the deep copy. */
11824 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
11825 && (gfc_is_class_array_function (expr2)
11826 || gfc_is_alloc_class_scalar_function (expr2)))
11827 {
11828 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
11829 gfc_prepend_expr_to_block (&rse.post, tmp);
11830 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
11831 gfc_add_block_to_block (&loop.post, &rse.post);
11832 }
11833
11834 tmp = NULL_TREE;
11835
11836 if (is_poly_assign)
11837 {
11838 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
11839 use_vptr_copy || (lhs_attr.allocatable
11840 && !lhs_attr.dimension),
11841 !realloc_flag && flag_realloc_lhs
11842 && !lhs_attr.pointer);
11843 if (expr2->expr_type == EXPR_FUNCTION
11844 && expr2->ts.type == BT_DERIVED
11845 && expr2->ts.u.derived->attr.alloc_comp)
11846 {
11847 tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
11848 rse.expr, expr2->rank);
11849 if (lss == gfc_ss_terminator)
11850 gfc_add_expr_to_block (&rse.post, tmp2);
11851 else
11852 gfc_add_expr_to_block (&loop.post, tmp2);
11853 }
11854 }
11855 else if (flag_coarray == GFC_FCOARRAY_LIB
11856 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
11857 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
11858 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
11859 {
11860 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11861 allocatable component, because those need to be accessed via the
11862 caf-runtime. No need to check for coindexes here, because resolve
11863 has rewritten those already. */
11864 gfc_code code;
11865 gfc_actual_arglist a1, a2;
11866 /* Clear the structures to prevent accessing garbage. */
11867 memset (&code, '\0', sizeof (gfc_code));
11868 memset (&a1, '\0', sizeof (gfc_actual_arglist));
11869 memset (&a2, '\0', sizeof (gfc_actual_arglist));
11870 a1.expr = expr1;
11871 a1.next = &a2;
11872 a2.expr = expr2;
11873 a2.next = NULL;
11874 code.ext.actual = &a1;
11875 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
11876 tmp = gfc_conv_intrinsic_subroutine (&code);
11877 }
11878 else if (!is_poly_assign && expr2->must_finalize
11879 && expr1->ts.type == BT_CLASS
11880 && expr2->ts.type == BT_CLASS)
11881 {
11882 /* This case comes about when the scalarizer provides array element
11883 references. Use the vptr copy function, since this does a deep
11884 copy of allocatable components, without which the finalizer call
11885 will deallocate the components. */
11886 tmp = gfc_get_vptr_from_expr (rse.expr);
11887 if (tmp != NULL_TREE)
11888 {
11889 tree fcn = gfc_vptr_copy_get (tmp);
11890 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
11891 fcn = build_fold_indirect_ref_loc (input_location, fcn);
11892 tmp = build_call_expr_loc (input_location,
11893 fcn, 2,
11894 gfc_build_addr_expr (NULL, rse.expr),
11895 gfc_build_addr_expr (NULL, lse.expr));
11896 }
11897 }
11898
11899 /* If nothing else works, do it the old fashioned way! */
11900 if (tmp == NULL_TREE)
11901 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11902 gfc_expr_is_variable (expr2)
11903 || scalar_to_array
11904 || expr2->expr_type == EXPR_ARRAY,
11905 !(l_is_temp || init_flag) && dealloc,
11906 expr1->symtree->n.sym->attr.codimension);
11907
11908 /* Add the pre blocks to the body. */
11909 gfc_add_block_to_block (&body, &rse.pre);
11910 gfc_add_block_to_block (&body, &lse.pre);
11911 gfc_add_expr_to_block (&body, tmp);
11912 /* Add the post blocks to the body. */
11913 gfc_add_block_to_block (&body, &rse.post);
11914 gfc_add_block_to_block (&body, &lse.post);
11915
11916 if (lss == gfc_ss_terminator)
11917 {
11918 /* F2003: Add the code for reallocation on assignment. */
11919 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
11920 && !is_poly_assign)
11921 alloc_scalar_allocatable_for_assignment (&block, string_length,
11922 expr1, expr2);
11923
11924 /* Use the scalar assignment as is. */
11925 gfc_add_block_to_block (&block, &body);
11926 }
11927 else
11928 {
11929 gcc_assert (lse.ss == gfc_ss_terminator
11930 && rse.ss == gfc_ss_terminator);
11931
11932 if (l_is_temp)
11933 {
11934 gfc_trans_scalarized_loop_boundary (&loop, &body);
11935
11936 /* We need to copy the temporary to the actual lhs. */
11937 gfc_init_se (&lse, NULL);
11938 gfc_init_se (&rse, NULL);
11939 gfc_copy_loopinfo_to_se (&lse, &loop);
11940 gfc_copy_loopinfo_to_se (&rse, &loop);
11941
11942 rse.ss = loop.temp_ss;
11943 lse.ss = lss;
11944
11945 gfc_conv_tmp_array_ref (&rse);
11946 gfc_conv_expr (&lse, expr1);
11947
11948 gcc_assert (lse.ss == gfc_ss_terminator
11949 && rse.ss == gfc_ss_terminator);
11950
11951 if (expr2->ts.type == BT_CHARACTER)
11952 rse.string_length = string_length;
11953
11954 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11955 false, dealloc);
11956 gfc_add_expr_to_block (&body, tmp);
11957 }
11958
11959 /* F2003: Allocate or reallocate lhs of allocatable array. */
11960 if (realloc_flag)
11961 {
11962 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
11963 ompws_flags &= ~OMPWS_SCALARIZER_WS;
11964 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
11965 if (tmp != NULL_TREE)
11966 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
11967 }
11968
11969 if (maybe_workshare)
11970 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
11971
11972 /* Generate the copying loops. */
11973 gfc_trans_scalarizing_loops (&loop, &body);
11974
11975 /* Wrap the whole thing up. */
11976 gfc_add_block_to_block (&block, &loop.pre);
11977 gfc_add_block_to_block (&block, &loop.post);
11978
11979 gfc_cleanup_loop (&loop);
11980 }
11981
11982 return gfc_finish_block (&block);
11983 }
11984
11985
11986 /* Check whether EXPR is a copyable array. */
11987
11988 static bool
copyable_array_p(gfc_expr * expr)11989 copyable_array_p (gfc_expr * expr)
11990 {
11991 if (expr->expr_type != EXPR_VARIABLE)
11992 return false;
11993
11994 /* First check it's an array. */
11995 if (expr->rank < 1 || !expr->ref || expr->ref->next)
11996 return false;
11997
11998 if (!gfc_full_array_ref_p (expr->ref, NULL))
11999 return false;
12000
12001 /* Next check that it's of a simple enough type. */
12002 switch (expr->ts.type)
12003 {
12004 case BT_INTEGER:
12005 case BT_REAL:
12006 case BT_COMPLEX:
12007 case BT_LOGICAL:
12008 return true;
12009
12010 case BT_CHARACTER:
12011 return false;
12012
12013 case_bt_struct:
12014 return !expr->ts.u.derived->attr.alloc_comp;
12015
12016 default:
12017 break;
12018 }
12019
12020 return false;
12021 }
12022
12023 /* Translate an assignment. */
12024
12025 tree
gfc_trans_assignment(gfc_expr * expr1,gfc_expr * expr2,bool init_flag,bool dealloc,bool use_vptr_copy,bool may_alias)12026 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
12027 bool dealloc, bool use_vptr_copy, bool may_alias)
12028 {
12029 tree tmp;
12030
12031 /* Special case a single function returning an array. */
12032 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
12033 {
12034 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
12035 if (tmp)
12036 return tmp;
12037 }
12038
12039 /* Special case assigning an array to zero. */
12040 if (copyable_array_p (expr1)
12041 && is_zero_initializer_p (expr2))
12042 {
12043 tmp = gfc_trans_zero_assign (expr1);
12044 if (tmp)
12045 return tmp;
12046 }
12047
12048 /* Special case copying one array to another. */
12049 if (copyable_array_p (expr1)
12050 && copyable_array_p (expr2)
12051 && gfc_compare_types (&expr1->ts, &expr2->ts)
12052 && !gfc_check_dependency (expr1, expr2, 0))
12053 {
12054 tmp = gfc_trans_array_copy (expr1, expr2);
12055 if (tmp)
12056 return tmp;
12057 }
12058
12059 /* Special case initializing an array from a constant array constructor. */
12060 if (copyable_array_p (expr1)
12061 && expr2->expr_type == EXPR_ARRAY
12062 && gfc_compare_types (&expr1->ts, &expr2->ts))
12063 {
12064 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
12065 if (tmp)
12066 return tmp;
12067 }
12068
12069 if (UNLIMITED_POLY (expr1) && expr1->rank)
12070 use_vptr_copy = true;
12071
12072 /* Fallback to the scalarizer to generate explicit loops. */
12073 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
12074 use_vptr_copy, may_alias);
12075 }
12076
12077 tree
gfc_trans_init_assign(gfc_code * code)12078 gfc_trans_init_assign (gfc_code * code)
12079 {
12080 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
12081 }
12082
12083 tree
gfc_trans_assign(gfc_code * code)12084 gfc_trans_assign (gfc_code * code)
12085 {
12086 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
12087 }
12088
12089 /* Generate a simple loop for internal use of the form
12090 for (var = begin; var <cond> end; var += step)
12091 body; */
12092 void
gfc_simple_for_loop(stmtblock_t * block,tree var,tree begin,tree end,enum tree_code cond,tree step,tree body)12093 gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
12094 enum tree_code cond, tree step, tree body)
12095 {
12096 tree tmp;
12097
12098 /* var = begin. */
12099 gfc_add_modify (block, var, begin);
12100
12101 /* Loop: for (var = begin; var <cond> end; var += step). */
12102 tree label_loop = gfc_build_label_decl (NULL_TREE);
12103 tree label_cond = gfc_build_label_decl (NULL_TREE);
12104 TREE_USED (label_loop) = 1;
12105 TREE_USED (label_cond) = 1;
12106
12107 gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
12108 gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
12109
12110 /* Loop body. */
12111 gfc_add_expr_to_block (block, body);
12112
12113 /* End of loop body. */
12114 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
12115 gfc_add_modify (block, var, tmp);
12116 gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
12117 tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
12118 tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
12119 build_empty_stmt (input_location));
12120 gfc_add_expr_to_block (block, tmp);
12121 }
12122