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