1 /* Expression translation
2 Copyright (C) 2002-2013 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 "tree.h"
28 #include "diagnostic-core.h" /* For fatal_error. */
29 #include "langhooks.h"
30 #include "flags.h"
31 #include "gfortran.h"
32 #include "arith.h"
33 #include "constructor.h"
34 #include "trans.h"
35 #include "trans-const.h"
36 #include "trans-types.h"
37 #include "trans-array.h"
38 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
39 #include "trans-stmt.h"
40 #include "dependency.h"
41
42
43 /* Convert a scalar to an array descriptor. To be used for assumed-rank
44 arrays. */
45
46 static tree
get_scalar_to_descriptor_type(tree scalar,symbol_attribute attr)47 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
48 {
49 enum gfc_array_kind akind;
50
51 if (attr.pointer)
52 akind = GFC_ARRAY_POINTER_CONT;
53 else if (attr.allocatable)
54 akind = GFC_ARRAY_ALLOCATABLE;
55 else
56 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
57
58 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
59 akind, !(attr.pointer || attr.target));
60 }
61
62 tree
gfc_conv_scalar_to_descriptor(gfc_se * se,tree scalar,symbol_attribute attr)63 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
64 {
65 tree desc, type;
66
67 type = get_scalar_to_descriptor_type (scalar, attr);
68 desc = gfc_create_var (type, "desc");
69 DECL_ARTIFICIAL (desc) = 1;
70 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
71 gfc_get_dtype (type));
72 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
73
74 /* Copy pointer address back - but only if it could have changed and
75 if the actual argument is a pointer and not, e.g., NULL(). */
76 if ((attr.pointer || attr.allocatable)
77 && attr.intent != INTENT_IN && POINTER_TYPE_P (TREE_TYPE (scalar)))
78 gfc_add_modify (&se->post, scalar,
79 fold_convert (TREE_TYPE (scalar),
80 gfc_conv_descriptor_data_get (desc)));
81 return desc;
82 }
83
84
85 /* This is the seed for an eventual trans-class.c
86
87 The following parameters should not be used directly since they might
88 in future implementations. Use the corresponding APIs. */
89 #define CLASS_DATA_FIELD 0
90 #define CLASS_VPTR_FIELD 1
91 #define VTABLE_HASH_FIELD 0
92 #define VTABLE_SIZE_FIELD 1
93 #define VTABLE_EXTENDS_FIELD 2
94 #define VTABLE_DEF_INIT_FIELD 3
95 #define VTABLE_COPY_FIELD 4
96 #define VTABLE_FINAL_FIELD 5
97
98
99 tree
gfc_class_data_get(tree decl)100 gfc_class_data_get (tree decl)
101 {
102 tree data;
103 if (POINTER_TYPE_P (TREE_TYPE (decl)))
104 decl = build_fold_indirect_ref_loc (input_location, decl);
105 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
106 CLASS_DATA_FIELD);
107 return fold_build3_loc (input_location, COMPONENT_REF,
108 TREE_TYPE (data), decl, data,
109 NULL_TREE);
110 }
111
112
113 tree
gfc_class_vptr_get(tree decl)114 gfc_class_vptr_get (tree decl)
115 {
116 tree vptr;
117 if (POINTER_TYPE_P (TREE_TYPE (decl)))
118 decl = build_fold_indirect_ref_loc (input_location, decl);
119 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
120 CLASS_VPTR_FIELD);
121 return fold_build3_loc (input_location, COMPONENT_REF,
122 TREE_TYPE (vptr), decl, vptr,
123 NULL_TREE);
124 }
125
126
127 static tree
gfc_vtable_field_get(tree decl,int field)128 gfc_vtable_field_get (tree decl, int field)
129 {
130 tree size;
131 tree vptr;
132 vptr = gfc_class_vptr_get (decl);
133 vptr = build_fold_indirect_ref_loc (input_location, vptr);
134 size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
135 field);
136 size = fold_build3_loc (input_location, COMPONENT_REF,
137 TREE_TYPE (size), vptr, size,
138 NULL_TREE);
139 /* Always return size as an array index type. */
140 if (field == VTABLE_SIZE_FIELD)
141 size = fold_convert (gfc_array_index_type, size);
142 gcc_assert (size);
143 return size;
144 }
145
146
147 tree
gfc_vtable_hash_get(tree decl)148 gfc_vtable_hash_get (tree decl)
149 {
150 return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
151 }
152
153
154 tree
gfc_vtable_size_get(tree decl)155 gfc_vtable_size_get (tree decl)
156 {
157 return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
158 }
159
160
161 tree
gfc_vtable_extends_get(tree decl)162 gfc_vtable_extends_get (tree decl)
163 {
164 return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
165 }
166
167
168 tree
gfc_vtable_def_init_get(tree decl)169 gfc_vtable_def_init_get (tree decl)
170 {
171 return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
172 }
173
174
175 tree
gfc_vtable_copy_get(tree decl)176 gfc_vtable_copy_get (tree decl)
177 {
178 return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
179 }
180
181
182 tree
gfc_vtable_final_get(tree decl)183 gfc_vtable_final_get (tree decl)
184 {
185 return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
186 }
187
188
189 #undef CLASS_DATA_FIELD
190 #undef CLASS_VPTR_FIELD
191 #undef VTABLE_HASH_FIELD
192 #undef VTABLE_SIZE_FIELD
193 #undef VTABLE_EXTENDS_FIELD
194 #undef VTABLE_DEF_INIT_FIELD
195 #undef VTABLE_COPY_FIELD
196 #undef VTABLE_FINAL_FIELD
197
198
199 /* Obtain the vptr of the last class reference in an expression.
200 Return NULL_TREE if no class reference is found. */
201
202 tree
gfc_get_vptr_from_expr(tree expr)203 gfc_get_vptr_from_expr (tree expr)
204 {
205 tree tmp;
206 tree type;
207
208 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
209 {
210 type = TREE_TYPE (tmp);
211 while (type)
212 {
213 if (GFC_CLASS_TYPE_P (type))
214 return gfc_class_vptr_get (tmp);
215 if (type != TYPE_CANONICAL (type))
216 type = TYPE_CANONICAL (type);
217 else
218 type = NULL_TREE;
219 }
220 if (TREE_CODE (tmp) == VAR_DECL)
221 break;
222 }
223 return NULL_TREE;
224 }
225
226
227 static void
class_array_data_assign(stmtblock_t * block,tree lhs_desc,tree rhs_desc,bool lhs_type)228 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
229 bool lhs_type)
230 {
231 tree tmp, tmp2, type;
232
233 gfc_conv_descriptor_data_set (block, lhs_desc,
234 gfc_conv_descriptor_data_get (rhs_desc));
235 gfc_conv_descriptor_offset_set (block, lhs_desc,
236 gfc_conv_descriptor_offset_get (rhs_desc));
237
238 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
239 gfc_conv_descriptor_dtype (rhs_desc));
240
241 /* Assign the dimension as range-ref. */
242 tmp = gfc_get_descriptor_dimension (lhs_desc);
243 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
244
245 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
246 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
247 gfc_index_zero_node, NULL_TREE, NULL_TREE);
248 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
249 gfc_index_zero_node, NULL_TREE, NULL_TREE);
250 gfc_add_modify (block, tmp, tmp2);
251 }
252
253
254 /* Takes a derived type expression and returns the address of a temporary
255 class object of the 'declared' type. If vptr is not NULL, this is
256 used for the temporary class object.
257 optional_alloc_ptr is false when the dummy is neither allocatable
258 nor a pointer; that's only relevant for the optional handling. */
259 void
gfc_conv_derived_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,tree vptr,bool optional,bool optional_alloc_ptr)260 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
261 gfc_typespec class_ts, tree vptr, bool optional,
262 bool optional_alloc_ptr)
263 {
264 gfc_symbol *vtab;
265 tree cond_optional = NULL_TREE;
266 gfc_ss *ss;
267 tree ctree;
268 tree var;
269 tree tmp;
270
271 /* The derived type needs to be converted to a temporary
272 CLASS object. */
273 tmp = gfc_typenode_for_spec (&class_ts);
274 var = gfc_create_var (tmp, "class");
275
276 /* Set the vptr. */
277 ctree = gfc_class_vptr_get (var);
278
279 if (vptr != NULL_TREE)
280 {
281 /* Use the dynamic vptr. */
282 tmp = vptr;
283 }
284 else
285 {
286 /* In this case the vtab corresponds to the derived type and the
287 vptr must point to it. */
288 vtab = gfc_find_derived_vtab (e->ts.u.derived);
289 gcc_assert (vtab);
290 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
291 }
292 gfc_add_modify (&parmse->pre, ctree,
293 fold_convert (TREE_TYPE (ctree), tmp));
294
295 /* Now set the data field. */
296 ctree = gfc_class_data_get (var);
297
298 if (optional)
299 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
300
301 if (parmse->ss && parmse->ss->info->useflags)
302 {
303 /* For an array reference in an elemental procedure call we need
304 to retain the ss to provide the scalarized array reference. */
305 gfc_conv_expr_reference (parmse, e);
306 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
307 if (optional)
308 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
309 cond_optional, tmp,
310 fold_convert (TREE_TYPE (tmp), null_pointer_node));
311 gfc_add_modify (&parmse->pre, ctree, tmp);
312
313 }
314 else
315 {
316 ss = gfc_walk_expr (e);
317 if (ss == gfc_ss_terminator)
318 {
319 parmse->ss = NULL;
320 gfc_conv_expr_reference (parmse, e);
321
322 /* Scalar to an assumed-rank array. */
323 if (class_ts.u.derived->components->as)
324 {
325 tree type;
326 type = get_scalar_to_descriptor_type (parmse->expr,
327 gfc_expr_attr (e));
328 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
329 gfc_get_dtype (type));
330 if (optional)
331 parmse->expr = build3_loc (input_location, COND_EXPR,
332 TREE_TYPE (parmse->expr),
333 cond_optional, parmse->expr,
334 fold_convert (TREE_TYPE (parmse->expr),
335 null_pointer_node));
336 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
337 }
338 else
339 {
340 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
341 if (optional)
342 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
343 cond_optional, tmp,
344 fold_convert (TREE_TYPE (tmp),
345 null_pointer_node));
346 gfc_add_modify (&parmse->pre, ctree, tmp);
347 }
348 }
349 else
350 {
351 stmtblock_t block;
352 gfc_init_block (&block);
353
354 parmse->ss = ss;
355 gfc_conv_expr_descriptor (parmse, e);
356
357 if (e->rank != class_ts.u.derived->components->as->rank)
358 class_array_data_assign (&block, ctree, parmse->expr, true);
359 else
360 {
361 if (gfc_expr_attr (e).codimension)
362 parmse->expr = fold_build1_loc (input_location,
363 VIEW_CONVERT_EXPR,
364 TREE_TYPE (ctree),
365 parmse->expr);
366 gfc_add_modify (&block, ctree, parmse->expr);
367 }
368
369 if (optional)
370 {
371 tmp = gfc_finish_block (&block);
372
373 gfc_init_block (&block);
374 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
375
376 tmp = build3_v (COND_EXPR, cond_optional, tmp,
377 gfc_finish_block (&block));
378 gfc_add_expr_to_block (&parmse->pre, tmp);
379 }
380 else
381 gfc_add_block_to_block (&parmse->pre, &block);
382 }
383 }
384
385 /* Pass the address of the class object. */
386 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
387
388 if (optional && optional_alloc_ptr)
389 parmse->expr = build3_loc (input_location, COND_EXPR,
390 TREE_TYPE (parmse->expr),
391 cond_optional, parmse->expr,
392 fold_convert (TREE_TYPE (parmse->expr),
393 null_pointer_node));
394 }
395
396
397 /* Create a new class container, which is required as scalar coarrays
398 have an array descriptor while normal scalars haven't. Optionally,
399 NULL pointer checks are added if the argument is OPTIONAL. */
400
401 static void
class_scalar_coarray_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,bool optional)402 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
403 gfc_typespec class_ts, bool optional)
404 {
405 tree var, ctree, tmp;
406 stmtblock_t block;
407 gfc_ref *ref;
408 gfc_ref *class_ref;
409
410 gfc_init_block (&block);
411
412 class_ref = NULL;
413 for (ref = e->ref; ref; ref = ref->next)
414 {
415 if (ref->type == REF_COMPONENT
416 && ref->u.c.component->ts.type == BT_CLASS)
417 class_ref = ref;
418 }
419
420 if (class_ref == NULL
421 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
422 tmp = e->symtree->n.sym->backend_decl;
423 else
424 {
425 /* Remove everything after the last class reference, convert the
426 expression and then recover its tailend once more. */
427 gfc_se tmpse;
428 ref = class_ref->next;
429 class_ref->next = NULL;
430 gfc_init_se (&tmpse, NULL);
431 gfc_conv_expr (&tmpse, e);
432 class_ref->next = ref;
433 tmp = tmpse.expr;
434 }
435
436 var = gfc_typenode_for_spec (&class_ts);
437 var = gfc_create_var (var, "class");
438
439 ctree = gfc_class_vptr_get (var);
440 gfc_add_modify (&block, ctree,
441 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
442
443 ctree = gfc_class_data_get (var);
444 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
445 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
446
447 /* Pass the address of the class object. */
448 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
449
450 if (optional)
451 {
452 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
453 tree tmp2;
454
455 tmp = gfc_finish_block (&block);
456
457 gfc_init_block (&block);
458 tmp2 = gfc_class_data_get (var);
459 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
460 null_pointer_node));
461 tmp2 = gfc_finish_block (&block);
462
463 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
464 cond, tmp, tmp2);
465 gfc_add_expr_to_block (&parmse->pre, tmp);
466 }
467 else
468 gfc_add_block_to_block (&parmse->pre, &block);
469 }
470
471
472 /* Takes an intrinsic type expression and returns the address of a temporary
473 class object of the 'declared' type. */
474 void
gfc_conv_intrinsic_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts)475 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
476 gfc_typespec class_ts)
477 {
478 gfc_symbol *vtab;
479 gfc_ss *ss;
480 tree ctree;
481 tree var;
482 tree tmp;
483
484 /* The intrinsic type needs to be converted to a temporary
485 CLASS object. */
486 tmp = gfc_typenode_for_spec (&class_ts);
487 var = gfc_create_var (tmp, "class");
488
489 /* Set the vptr. */
490 ctree = gfc_class_vptr_get (var);
491
492 vtab = gfc_find_intrinsic_vtab (&e->ts);
493 gcc_assert (vtab);
494 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
495 gfc_add_modify (&parmse->pre, ctree,
496 fold_convert (TREE_TYPE (ctree), tmp));
497
498 /* Now set the data field. */
499 ctree = gfc_class_data_get (var);
500 if (parmse->ss && parmse->ss->info->useflags)
501 {
502 /* For an array reference in an elemental procedure call we need
503 to retain the ss to provide the scalarized array reference. */
504 gfc_conv_expr_reference (parmse, e);
505 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
506 gfc_add_modify (&parmse->pre, ctree, tmp);
507 }
508 else
509 {
510 ss = gfc_walk_expr (e);
511 if (ss == gfc_ss_terminator)
512 {
513 parmse->ss = NULL;
514 gfc_conv_expr_reference (parmse, e);
515 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
516 gfc_add_modify (&parmse->pre, ctree, tmp);
517 }
518 else
519 {
520 parmse->ss = ss;
521 gfc_conv_expr_descriptor (parmse, e);
522 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
523 }
524 }
525
526 /* Pass the address of the class object. */
527 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
528 }
529
530
531 /* Takes a scalarized class array expression and returns the
532 address of a temporary scalar class object of the 'declared'
533 type.
534 OOP-TODO: This could be improved by adding code that branched on
535 the dynamic type being the same as the declared type. In this case
536 the original class expression can be passed directly.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's relevant for the optional handling.
539 Set copyback to true if class container's _data and _vtab pointers
540 might get modified. */
541
542 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)543 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
544 bool elemental, bool copyback, bool optional,
545 bool optional_alloc_ptr)
546 {
547 tree ctree;
548 tree var;
549 tree tmp;
550 tree vptr;
551 tree cond = NULL_TREE;
552 gfc_ref *ref;
553 gfc_ref *class_ref;
554 stmtblock_t block;
555 bool full_array = false;
556
557 gfc_init_block (&block);
558
559 class_ref = NULL;
560 for (ref = e->ref; ref; ref = ref->next)
561 {
562 if (ref->type == REF_COMPONENT
563 && ref->u.c.component->ts.type == BT_CLASS)
564 class_ref = ref;
565
566 if (ref->next == NULL)
567 break;
568 }
569
570 if ((ref == NULL || class_ref == ref)
571 && (!class_ts.u.derived->components->as
572 || class_ts.u.derived->components->as->rank != -1))
573 return;
574
575 /* Test for FULL_ARRAY. */
576 if (e->rank == 0 && gfc_expr_attr (e).codimension
577 && gfc_expr_attr (e).dimension)
578 full_array = true;
579 else
580 gfc_is_class_array_ref (e, &full_array);
581
582 /* The derived type needs to be converted to a temporary
583 CLASS object. */
584 tmp = gfc_typenode_for_spec (&class_ts);
585 var = gfc_create_var (tmp, "class");
586
587 /* Set the data. */
588 ctree = gfc_class_data_get (var);
589 if (class_ts.u.derived->components->as
590 && e->rank != class_ts.u.derived->components->as->rank)
591 {
592 if (e->rank == 0)
593 {
594 tree type = get_scalar_to_descriptor_type (parmse->expr,
595 gfc_expr_attr (e));
596 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
597 gfc_get_dtype (type));
598
599 tmp = gfc_class_data_get (parmse->expr);
600 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
601 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
602
603 gfc_conv_descriptor_data_set (&block, ctree, tmp);
604 }
605 else
606 class_array_data_assign (&block, ctree, parmse->expr, false);
607 }
608 else
609 {
610 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
611 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
612 TREE_TYPE (ctree), parmse->expr);
613 gfc_add_modify (&block, ctree, parmse->expr);
614 }
615
616 /* Return the data component, except in the case of scalarized array
617 references, where nullification of the cannot occur and so there
618 is no need. */
619 if (!elemental && full_array && copyback)
620 {
621 if (class_ts.u.derived->components->as
622 && e->rank != class_ts.u.derived->components->as->rank)
623 {
624 if (e->rank == 0)
625 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
626 gfc_conv_descriptor_data_get (ctree));
627 else
628 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
629 }
630 else
631 gfc_add_modify (&parmse->post, parmse->expr, ctree);
632 }
633
634 /* Set the vptr. */
635 ctree = gfc_class_vptr_get (var);
636
637 /* The vptr is the second field of the actual argument.
638 First we have to find the corresponding class reference. */
639
640 tmp = NULL_TREE;
641 if (class_ref == NULL
642 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
643 tmp = e->symtree->n.sym->backend_decl;
644 else
645 {
646 /* Remove everything after the last class reference, convert the
647 expression and then recover its tailend once more. */
648 gfc_se tmpse;
649 ref = class_ref->next;
650 class_ref->next = NULL;
651 gfc_init_se (&tmpse, NULL);
652 gfc_conv_expr (&tmpse, e);
653 class_ref->next = ref;
654 tmp = tmpse.expr;
655 }
656
657 gcc_assert (tmp != NULL_TREE);
658
659 /* Dereference if needs be. */
660 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
661 tmp = build_fold_indirect_ref_loc (input_location, tmp);
662
663 vptr = gfc_class_vptr_get (tmp);
664 gfc_add_modify (&block, ctree,
665 fold_convert (TREE_TYPE (ctree), vptr));
666
667 /* Return the vptr component, except in the case of scalarized array
668 references, where the dynamic type cannot change. */
669 if (!elemental && full_array && copyback)
670 gfc_add_modify (&parmse->post, vptr,
671 fold_convert (TREE_TYPE (vptr), ctree));
672
673 gcc_assert (!optional || (optional && !copyback));
674 if (optional)
675 {
676 tree tmp2;
677
678 cond = gfc_conv_expr_present (e->symtree->n.sym);
679 tmp = gfc_finish_block (&block);
680
681 if (optional_alloc_ptr)
682 tmp2 = build_empty_stmt (input_location);
683 else
684 {
685 gfc_init_block (&block);
686
687 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
688 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
689 null_pointer_node));
690 tmp2 = gfc_finish_block (&block);
691 }
692
693 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
694 cond, tmp, tmp2);
695 gfc_add_expr_to_block (&parmse->pre, tmp);
696 }
697 else
698 gfc_add_block_to_block (&parmse->pre, &block);
699
700 /* Pass the address of the class object. */
701 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
702
703 if (optional && optional_alloc_ptr)
704 parmse->expr = build3_loc (input_location, COND_EXPR,
705 TREE_TYPE (parmse->expr),
706 cond, parmse->expr,
707 fold_convert (TREE_TYPE (parmse->expr),
708 null_pointer_node));
709 }
710
711
712 /* Given a class array declaration and an index, returns the address
713 of the referenced element. */
714
715 tree
gfc_get_class_array_ref(tree index,tree class_decl)716 gfc_get_class_array_ref (tree index, tree class_decl)
717 {
718 tree data = gfc_class_data_get (class_decl);
719 tree size = gfc_vtable_size_get (class_decl);
720 tree offset = fold_build2_loc (input_location, MULT_EXPR,
721 gfc_array_index_type,
722 index, size);
723 tree ptr;
724 data = gfc_conv_descriptor_data_get (data);
725 ptr = fold_convert (pvoid_type_node, data);
726 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
727 return fold_convert (TREE_TYPE (data), ptr);
728 }
729
730
731 /* Copies one class expression to another, assuming that if either
732 'to' or 'from' are arrays they are packed. Should 'from' be
733 NULL_TREE, the initialization expression for 'to' is used, assuming
734 that the _vptr is set. */
735
736 tree
gfc_copy_class_to_class(tree from,tree to,tree nelems)737 gfc_copy_class_to_class (tree from, tree to, tree nelems)
738 {
739 tree fcn;
740 tree fcn_type;
741 tree from_data;
742 tree to_data;
743 tree to_ref;
744 tree from_ref;
745 vec<tree, va_gc> *args;
746 tree tmp;
747 tree index;
748 stmtblock_t loopbody;
749 stmtblock_t body;
750 gfc_loopinfo loop;
751
752 args = NULL;
753
754 if (from != NULL_TREE)
755 fcn = gfc_vtable_copy_get (from);
756 else
757 fcn = gfc_vtable_copy_get (to);
758
759 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
760
761 if (from != NULL_TREE)
762 from_data = gfc_class_data_get (from);
763 else
764 from_data = gfc_vtable_def_init_get (to);
765
766 to_data = gfc_class_data_get (to);
767
768 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
769 {
770 gfc_init_block (&body);
771 tmp = fold_build2_loc (input_location, MINUS_EXPR,
772 gfc_array_index_type, nelems,
773 gfc_index_one_node);
774 nelems = gfc_evaluate_now (tmp, &body);
775 index = gfc_create_var (gfc_array_index_type, "S");
776
777 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
778 {
779 from_ref = gfc_get_class_array_ref (index, from);
780 vec_safe_push (args, from_ref);
781 }
782 else
783 vec_safe_push (args, from_data);
784
785 to_ref = gfc_get_class_array_ref (index, to);
786 vec_safe_push (args, to_ref);
787
788 tmp = build_call_vec (fcn_type, fcn, args);
789
790 /* Build the body of the loop. */
791 gfc_init_block (&loopbody);
792 gfc_add_expr_to_block (&loopbody, tmp);
793
794 /* Build the loop and return. */
795 gfc_init_loopinfo (&loop);
796 loop.dimen = 1;
797 loop.from[0] = gfc_index_zero_node;
798 loop.loopvar[0] = index;
799 loop.to[0] = nelems;
800 gfc_trans_scalarizing_loops (&loop, &loopbody);
801 gfc_add_block_to_block (&body, &loop.pre);
802 tmp = gfc_finish_block (&body);
803 gfc_cleanup_loop (&loop);
804 }
805 else
806 {
807 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
808 vec_safe_push (args, from_data);
809 vec_safe_push (args, to_data);
810 tmp = build_call_vec (fcn_type, fcn, args);
811 }
812
813 return tmp;
814 }
815
816 static tree
gfc_trans_class_array_init_assign(gfc_expr * rhs,gfc_expr * lhs,gfc_expr * obj)817 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
818 {
819 gfc_actual_arglist *actual;
820 gfc_expr *ppc;
821 gfc_code *ppc_code;
822 tree res;
823
824 actual = gfc_get_actual_arglist ();
825 actual->expr = gfc_copy_expr (rhs);
826 actual->next = gfc_get_actual_arglist ();
827 actual->next->expr = gfc_copy_expr (lhs);
828 ppc = gfc_copy_expr (obj);
829 gfc_add_vptr_component (ppc);
830 gfc_add_component_ref (ppc, "_copy");
831 ppc_code = gfc_get_code ();
832 ppc_code->resolved_sym = ppc->symtree->n.sym;
833 /* Although '_copy' is set to be elemental in class.c, it is
834 not staying that way. Find out why, sometime.... */
835 ppc_code->resolved_sym->attr.elemental = 1;
836 ppc_code->ext.actual = actual;
837 ppc_code->expr1 = ppc;
838 ppc_code->op = EXEC_CALL;
839 /* Since '_copy' is elemental, the scalarizer will take care
840 of arrays in gfc_trans_call. */
841 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
842 gfc_free_statements (ppc_code);
843 return res;
844 }
845
846 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
847 A MEMCPY is needed to copy the full data from the default initializer
848 of the dynamic type. */
849
850 tree
gfc_trans_class_init_assign(gfc_code * code)851 gfc_trans_class_init_assign (gfc_code *code)
852 {
853 stmtblock_t block;
854 tree tmp;
855 gfc_se dst,src,memsz;
856 gfc_expr *lhs, *rhs, *sz;
857
858 gfc_start_block (&block);
859
860 lhs = gfc_copy_expr (code->expr1);
861 gfc_add_data_component (lhs);
862
863 rhs = gfc_copy_expr (code->expr1);
864 gfc_add_vptr_component (rhs);
865
866 /* Make sure that the component backend_decls have been built, which
867 will not have happened if the derived types concerned have not
868 been referenced. */
869 gfc_get_derived_type (rhs->ts.u.derived);
870 gfc_add_def_init_component (rhs);
871
872 if (code->expr1->ts.type == BT_CLASS
873 && CLASS_DATA (code->expr1)->attr.dimension)
874 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
875 else
876 {
877 sz = gfc_copy_expr (code->expr1);
878 gfc_add_vptr_component (sz);
879 gfc_add_size_component (sz);
880
881 gfc_init_se (&dst, NULL);
882 gfc_init_se (&src, NULL);
883 gfc_init_se (&memsz, NULL);
884 gfc_conv_expr (&dst, lhs);
885 gfc_conv_expr (&src, rhs);
886 gfc_conv_expr (&memsz, sz);
887 gfc_add_block_to_block (&block, &src.pre);
888 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
889
890 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
891 }
892
893 if (code->expr1->symtree->n.sym->attr.optional
894 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
895 {
896 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
897 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
898 present, tmp,
899 build_empty_stmt (input_location));
900 }
901
902 gfc_add_expr_to_block (&block, tmp);
903
904 return gfc_finish_block (&block);
905 }
906
907
908 /* Translate an assignment to a CLASS object
909 (pointer or ordinary assignment). */
910
911 tree
gfc_trans_class_assign(gfc_expr * expr1,gfc_expr * expr2,gfc_exec_op op)912 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
913 {
914 stmtblock_t block;
915 tree tmp;
916 gfc_expr *lhs;
917 gfc_expr *rhs;
918 gfc_ref *ref;
919
920 gfc_start_block (&block);
921
922 ref = expr1->ref;
923 while (ref && ref->next)
924 ref = ref->next;
925
926 /* Class valued proc_pointer assignments do not need any further
927 preparation. */
928 if (ref && ref->type == REF_COMPONENT
929 && ref->u.c.component->attr.proc_pointer
930 && expr2->expr_type == EXPR_VARIABLE
931 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
932 && op == EXEC_POINTER_ASSIGN)
933 goto assign;
934
935 if (expr2->ts.type != BT_CLASS)
936 {
937 /* Insert an additional assignment which sets the '_vptr' field. */
938 gfc_symbol *vtab = NULL;
939 gfc_symtree *st;
940
941 lhs = gfc_copy_expr (expr1);
942 gfc_add_vptr_component (lhs);
943
944 if (UNLIMITED_POLY (expr1)
945 && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
946 {
947 rhs = gfc_get_null_expr (&expr2->where);
948 goto assign_vptr;
949 }
950
951 if (expr2->ts.type == BT_DERIVED)
952 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
953 else if (expr2->expr_type == EXPR_NULL)
954 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
955 else
956 vtab = gfc_find_intrinsic_vtab (&expr2->ts);
957 gcc_assert (vtab);
958
959 rhs = gfc_get_expr ();
960 rhs->expr_type = EXPR_VARIABLE;
961 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
962 rhs->symtree = st;
963 rhs->ts = vtab->ts;
964 assign_vptr:
965 tmp = gfc_trans_pointer_assignment (lhs, rhs);
966 gfc_add_expr_to_block (&block, tmp);
967
968 gfc_free_expr (lhs);
969 gfc_free_expr (rhs);
970 }
971 else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
972 {
973 /* F2003:C717 only sequence and bind-C types can come here. */
974 gcc_assert (expr1->ts.u.derived->attr.sequence
975 || expr1->ts.u.derived->attr.is_bind_c);
976 gfc_add_data_component (expr2);
977 goto assign;
978 }
979 else if (CLASS_DATA (expr2)->attr.dimension)
980 {
981 /* Insert an additional assignment which sets the '_vptr' field. */
982 lhs = gfc_copy_expr (expr1);
983 gfc_add_vptr_component (lhs);
984
985 rhs = gfc_copy_expr (expr2);
986 gfc_add_vptr_component (rhs);
987
988 tmp = gfc_trans_pointer_assignment (lhs, rhs);
989 gfc_add_expr_to_block (&block, tmp);
990
991 gfc_free_expr (lhs);
992 gfc_free_expr (rhs);
993 }
994
995 /* Do the actual CLASS assignment. */
996 if (expr2->ts.type == BT_CLASS
997 && !CLASS_DATA (expr2)->attr.dimension)
998 op = EXEC_ASSIGN;
999 else
1000 gfc_add_data_component (expr1);
1001
1002 assign:
1003
1004 if (op == EXEC_ASSIGN)
1005 tmp = gfc_trans_assignment (expr1, expr2, false, true);
1006 else if (op == EXEC_POINTER_ASSIGN)
1007 tmp = gfc_trans_pointer_assignment (expr1, expr2);
1008 else
1009 gcc_unreachable();
1010
1011 gfc_add_expr_to_block (&block, tmp);
1012
1013 return gfc_finish_block (&block);
1014 }
1015
1016
1017 /* End of prototype trans-class.c */
1018
1019
1020 static void
realloc_lhs_warning(bt type,bool array,locus * where)1021 realloc_lhs_warning (bt type, bool array, locus *where)
1022 {
1023 if (array && type != BT_CLASS && type != BT_DERIVED
1024 && gfc_option.warn_realloc_lhs)
1025 gfc_warning ("Code for reallocating the allocatable array at %L will "
1026 "be added", where);
1027 else if (gfc_option.warn_realloc_lhs_all)
1028 gfc_warning ("Code for reallocating the allocatable variable at %L "
1029 "will be added", where);
1030 }
1031
1032
1033 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
1034 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1035 gfc_expr *);
1036
1037 /* Copy the scalarization loop variables. */
1038
1039 static void
gfc_copy_se_loopvars(gfc_se * dest,gfc_se * src)1040 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1041 {
1042 dest->ss = src->ss;
1043 dest->loop = src->loop;
1044 }
1045
1046
1047 /* Initialize a simple expression holder.
1048
1049 Care must be taken when multiple se are created with the same parent.
1050 The child se must be kept in sync. The easiest way is to delay creation
1051 of a child se until after after the previous se has been translated. */
1052
1053 void
gfc_init_se(gfc_se * se,gfc_se * parent)1054 gfc_init_se (gfc_se * se, gfc_se * parent)
1055 {
1056 memset (se, 0, sizeof (gfc_se));
1057 gfc_init_block (&se->pre);
1058 gfc_init_block (&se->post);
1059
1060 se->parent = parent;
1061
1062 if (parent)
1063 gfc_copy_se_loopvars (se, parent);
1064 }
1065
1066
1067 /* Advances to the next SS in the chain. Use this rather than setting
1068 se->ss = se->ss->next because all the parents needs to be kept in sync.
1069 See gfc_init_se. */
1070
1071 void
gfc_advance_se_ss_chain(gfc_se * se)1072 gfc_advance_se_ss_chain (gfc_se * se)
1073 {
1074 gfc_se *p;
1075 gfc_ss *ss;
1076
1077 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1078
1079 p = se;
1080 /* Walk down the parent chain. */
1081 while (p != NULL)
1082 {
1083 /* Simple consistency check. */
1084 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1085 || p->parent->ss->nested_ss == p->ss);
1086
1087 /* If we were in a nested loop, the next scalarized expression can be
1088 on the parent ss' next pointer. Thus we should not take the next
1089 pointer blindly, but rather go up one nest level as long as next
1090 is the end of chain. */
1091 ss = p->ss;
1092 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1093 ss = ss->parent;
1094
1095 p->ss = ss->next;
1096
1097 p = p->parent;
1098 }
1099 }
1100
1101
1102 /* Ensures the result of the expression as either a temporary variable
1103 or a constant so that it can be used repeatedly. */
1104
1105 void
gfc_make_safe_expr(gfc_se * se)1106 gfc_make_safe_expr (gfc_se * se)
1107 {
1108 tree var;
1109
1110 if (CONSTANT_CLASS_P (se->expr))
1111 return;
1112
1113 /* We need a temporary for this result. */
1114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1115 gfc_add_modify (&se->pre, var, se->expr);
1116 se->expr = var;
1117 }
1118
1119
1120 /* Return an expression which determines if a dummy parameter is present.
1121 Also used for arguments to procedures with multiple entry points. */
1122
1123 tree
gfc_conv_expr_present(gfc_symbol * sym)1124 gfc_conv_expr_present (gfc_symbol * sym)
1125 {
1126 tree decl, cond;
1127
1128 gcc_assert (sym->attr.dummy);
1129
1130 decl = gfc_get_symbol_decl (sym);
1131 if (TREE_CODE (decl) != PARM_DECL)
1132 {
1133 /* Array parameters use a temporary descriptor, we want the real
1134 parameter. */
1135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1138 }
1139
1140 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
1141 fold_convert (TREE_TYPE (decl), null_pointer_node));
1142
1143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1144 as actual argument to denote absent dummies. For array descriptors,
1145 we thus also need to check the array descriptor. For BT_CLASS, it
1146 can also occur for scalars and F2003 due to type->class wrapping and
1147 class->class wrapping. Note futher that BT_CLASS always uses an
1148 array descriptor for arrays, also for explicit-shape/assumed-size. */
1149
1150 if (!sym->attr.allocatable
1151 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1152 || (sym->ts.type == BT_CLASS
1153 && !CLASS_DATA (sym)->attr.allocatable
1154 && !CLASS_DATA (sym)->attr.class_pointer))
1155 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1156 || sym->ts.type == BT_CLASS))
1157 {
1158 tree tmp;
1159
1160 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1161 || sym->as->type == AS_ASSUMED_RANK
1162 || sym->attr.codimension))
1163 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1164 {
1165 tmp = build_fold_indirect_ref_loc (input_location, decl);
1166 if (sym->ts.type == BT_CLASS)
1167 tmp = gfc_class_data_get (tmp);
1168 tmp = gfc_conv_array_data (tmp);
1169 }
1170 else if (sym->ts.type == BT_CLASS)
1171 tmp = gfc_class_data_get (decl);
1172 else
1173 tmp = NULL_TREE;
1174
1175 if (tmp != NULL_TREE)
1176 {
1177 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
1178 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1179 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1180 boolean_type_node, cond, tmp);
1181 }
1182 }
1183
1184 return cond;
1185 }
1186
1187
1188 /* Converts a missing, dummy argument into a null or zero. */
1189
1190 void
gfc_conv_missing_dummy(gfc_se * se,gfc_expr * arg,gfc_typespec ts,int kind)1191 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1192 {
1193 tree present;
1194 tree tmp;
1195
1196 present = gfc_conv_expr_present (arg->symtree->n.sym);
1197
1198 if (kind > 0)
1199 {
1200 /* Create a temporary and convert it to the correct type. */
1201 tmp = gfc_get_int_type (kind);
1202 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1203 se->expr));
1204
1205 /* Test for a NULL value. */
1206 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1207 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1208 tmp = gfc_evaluate_now (tmp, &se->pre);
1209 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1210 }
1211 else
1212 {
1213 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1214 present, se->expr,
1215 build_zero_cst (TREE_TYPE (se->expr)));
1216 tmp = gfc_evaluate_now (tmp, &se->pre);
1217 se->expr = tmp;
1218 }
1219
1220 if (ts.type == BT_CHARACTER)
1221 {
1222 tmp = build_int_cst (gfc_charlen_type_node, 0);
1223 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1224 present, se->string_length, tmp);
1225 tmp = gfc_evaluate_now (tmp, &se->pre);
1226 se->string_length = tmp;
1227 }
1228 return;
1229 }
1230
1231
1232 /* Get the character length of an expression, looking through gfc_refs
1233 if necessary. */
1234
1235 tree
gfc_get_expr_charlen(gfc_expr * e)1236 gfc_get_expr_charlen (gfc_expr *e)
1237 {
1238 gfc_ref *r;
1239 tree length;
1240
1241 gcc_assert (e->expr_type == EXPR_VARIABLE
1242 && e->ts.type == BT_CHARACTER);
1243
1244 length = NULL; /* To silence compiler warning. */
1245
1246 if (is_subref_array (e) && e->ts.u.cl->length)
1247 {
1248 gfc_se tmpse;
1249 gfc_init_se (&tmpse, NULL);
1250 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1251 e->ts.u.cl->backend_decl = tmpse.expr;
1252 return tmpse.expr;
1253 }
1254
1255 /* First candidate: if the variable is of type CHARACTER, the
1256 expression's length could be the length of the character
1257 variable. */
1258 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1259 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1260
1261 /* Look through the reference chain for component references. */
1262 for (r = e->ref; r; r = r->next)
1263 {
1264 switch (r->type)
1265 {
1266 case REF_COMPONENT:
1267 if (r->u.c.component->ts.type == BT_CHARACTER)
1268 length = r->u.c.component->ts.u.cl->backend_decl;
1269 break;
1270
1271 case REF_ARRAY:
1272 /* Do nothing. */
1273 break;
1274
1275 default:
1276 /* We should never got substring references here. These will be
1277 broken down by the scalarizer. */
1278 gcc_unreachable ();
1279 break;
1280 }
1281 }
1282
1283 gcc_assert (length != NULL);
1284 return length;
1285 }
1286
1287
1288 /* Return for an expression the backend decl of the coarray. */
1289
1290 static tree
get_tree_for_caf_expr(gfc_expr * expr)1291 get_tree_for_caf_expr (gfc_expr *expr)
1292 {
1293 tree caf_decl = NULL_TREE;
1294 gfc_ref *ref;
1295
1296 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1297 if (expr->symtree->n.sym->attr.codimension)
1298 caf_decl = expr->symtree->n.sym->backend_decl;
1299
1300 for (ref = expr->ref; ref; ref = ref->next)
1301 if (ref->type == REF_COMPONENT)
1302 {
1303 gfc_component *comp = ref->u.c.component;
1304 if (comp->attr.pointer || comp->attr.allocatable)
1305 caf_decl = NULL_TREE;
1306 if (comp->attr.codimension)
1307 caf_decl = comp->backend_decl;
1308 }
1309
1310 gcc_assert (caf_decl != NULL_TREE);
1311 return caf_decl;
1312 }
1313
1314
1315 /* For each character array constructor subexpression without a ts.u.cl->length,
1316 replace it by its first element (if there aren't any elements, the length
1317 should already be set to zero). */
1318
1319 static void
flatten_array_ctors_without_strlen(gfc_expr * e)1320 flatten_array_ctors_without_strlen (gfc_expr* e)
1321 {
1322 gfc_actual_arglist* arg;
1323 gfc_constructor* c;
1324
1325 if (!e)
1326 return;
1327
1328 switch (e->expr_type)
1329 {
1330
1331 case EXPR_OP:
1332 flatten_array_ctors_without_strlen (e->value.op.op1);
1333 flatten_array_ctors_without_strlen (e->value.op.op2);
1334 break;
1335
1336 case EXPR_COMPCALL:
1337 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1338 gcc_unreachable ();
1339
1340 case EXPR_FUNCTION:
1341 for (arg = e->value.function.actual; arg; arg = arg->next)
1342 flatten_array_ctors_without_strlen (arg->expr);
1343 break;
1344
1345 case EXPR_ARRAY:
1346
1347 /* We've found what we're looking for. */
1348 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
1349 {
1350 gfc_constructor *c;
1351 gfc_expr* new_expr;
1352
1353 gcc_assert (e->value.constructor);
1354
1355 c = gfc_constructor_first (e->value.constructor);
1356 new_expr = c->expr;
1357 c->expr = NULL;
1358
1359 flatten_array_ctors_without_strlen (new_expr);
1360 gfc_replace_expr (e, new_expr);
1361 break;
1362 }
1363
1364 /* Otherwise, fall through to handle constructor elements. */
1365 case EXPR_STRUCTURE:
1366 for (c = gfc_constructor_first (e->value.constructor);
1367 c; c = gfc_constructor_next (c))
1368 flatten_array_ctors_without_strlen (c->expr);
1369 break;
1370
1371 default:
1372 break;
1373
1374 }
1375 }
1376
1377
1378 /* Generate code to initialize a string length variable. Returns the
1379 value. For array constructors, cl->length might be NULL and in this case,
1380 the first element of the constructor is needed. expr is the original
1381 expression so we can access it but can be NULL if this is not needed. */
1382
1383 void
gfc_conv_string_length(gfc_charlen * cl,gfc_expr * expr,stmtblock_t * pblock)1384 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
1385 {
1386 gfc_se se;
1387
1388 gfc_init_se (&se, NULL);
1389
1390 if (!cl->length
1391 && cl->backend_decl
1392 && TREE_CODE (cl->backend_decl) == VAR_DECL)
1393 return;
1394
1395 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1396 "flatten" array constructors by taking their first element; all elements
1397 should be the same length or a cl->length should be present. */
1398 if (!cl->length)
1399 {
1400 gfc_expr* expr_flat;
1401 gcc_assert (expr);
1402 expr_flat = gfc_copy_expr (expr);
1403 flatten_array_ctors_without_strlen (expr_flat);
1404 gfc_resolve_expr (expr_flat);
1405
1406 gfc_conv_expr (&se, expr_flat);
1407 gfc_add_block_to_block (pblock, &se.pre);
1408 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
1409
1410 gfc_free_expr (expr_flat);
1411 return;
1412 }
1413
1414 /* Convert cl->length. */
1415
1416 gcc_assert (cl->length);
1417
1418 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
1419 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
1420 se.expr, build_int_cst (gfc_charlen_type_node, 0));
1421 gfc_add_block_to_block (pblock, &se.pre);
1422
1423 if (cl->backend_decl)
1424 gfc_add_modify (pblock, cl->backend_decl, se.expr);
1425 else
1426 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
1427 }
1428
1429
1430 static void
gfc_conv_substring(gfc_se * se,gfc_ref * ref,int kind,const char * name,locus * where)1431 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
1432 const char *name, locus *where)
1433 {
1434 tree tmp;
1435 tree type;
1436 tree fault;
1437 gfc_se start;
1438 gfc_se end;
1439 char *msg;
1440
1441 type = gfc_get_character_type (kind, ref->u.ss.length);
1442 type = build_pointer_type (type);
1443
1444 gfc_init_se (&start, se);
1445 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
1446 gfc_add_block_to_block (&se->pre, &start.pre);
1447
1448 if (integer_onep (start.expr))
1449 gfc_conv_string_parameter (se);
1450 else
1451 {
1452 tmp = start.expr;
1453 STRIP_NOPS (tmp);
1454 /* Avoid multiple evaluation of substring start. */
1455 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
1456 start.expr = gfc_evaluate_now (start.expr, &se->pre);
1457
1458 /* Change the start of the string. */
1459 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
1460 tmp = se->expr;
1461 else
1462 tmp = build_fold_indirect_ref_loc (input_location,
1463 se->expr);
1464 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
1465 se->expr = gfc_build_addr_expr (type, tmp);
1466 }
1467
1468 /* Length = end + 1 - start. */
1469 gfc_init_se (&end, se);
1470 if (ref->u.ss.end == NULL)
1471 end.expr = se->string_length;
1472 else
1473 {
1474 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
1475 gfc_add_block_to_block (&se->pre, &end.pre);
1476 }
1477 tmp = end.expr;
1478 STRIP_NOPS (tmp);
1479 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
1480 end.expr = gfc_evaluate_now (end.expr, &se->pre);
1481
1482 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1483 {
1484 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
1485 boolean_type_node, start.expr,
1486 end.expr);
1487
1488 /* Check lower bound. */
1489 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1490 start.expr,
1491 build_int_cst (gfc_charlen_type_node, 1));
1492 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1493 boolean_type_node, nonempty, fault);
1494 if (name)
1495 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
1496 "is less than one", name);
1497 else
1498 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
1499 "is less than one");
1500 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
1501 fold_convert (long_integer_type_node,
1502 start.expr));
1503 free (msg);
1504
1505 /* Check upper bound. */
1506 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1507 end.expr, se->string_length);
1508 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1509 boolean_type_node, nonempty, fault);
1510 if (name)
1511 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
1512 "exceeds string length (%%ld)", name);
1513 else
1514 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
1515 "exceeds string length (%%ld)");
1516 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
1517 fold_convert (long_integer_type_node, end.expr),
1518 fold_convert (long_integer_type_node,
1519 se->string_length));
1520 free (msg);
1521 }
1522
1523 /* If the start and end expressions are equal, the length is one. */
1524 if (ref->u.ss.end
1525 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
1526 tmp = build_int_cst (gfc_charlen_type_node, 1);
1527 else
1528 {
1529 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
1530 end.expr, start.expr);
1531 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
1532 build_int_cst (gfc_charlen_type_node, 1), tmp);
1533 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
1534 tmp, build_int_cst (gfc_charlen_type_node, 0));
1535 }
1536
1537 se->string_length = tmp;
1538 }
1539
1540
1541 /* Convert a derived type component reference. */
1542
1543 static void
gfc_conv_component_ref(gfc_se * se,gfc_ref * ref)1544 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
1545 {
1546 gfc_component *c;
1547 tree tmp;
1548 tree decl;
1549 tree field;
1550
1551 c = ref->u.c.component;
1552
1553 gcc_assert (c->backend_decl);
1554
1555 field = c->backend_decl;
1556 gcc_assert (TREE_CODE (field) == FIELD_DECL);
1557 decl = se->expr;
1558
1559 /* Components can correspond to fields of different containing
1560 types, as components are created without context, whereas
1561 a concrete use of a component has the type of decl as context.
1562 So, if the type doesn't match, we search the corresponding
1563 FIELD_DECL in the parent type. To not waste too much time
1564 we cache this result in norestrict_decl. */
1565
1566 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
1567 {
1568 tree f2 = c->norestrict_decl;
1569 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
1570 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
1571 if (TREE_CODE (f2) == FIELD_DECL
1572 && DECL_NAME (f2) == DECL_NAME (field))
1573 break;
1574 gcc_assert (f2);
1575 c->norestrict_decl = f2;
1576 field = f2;
1577 }
1578
1579 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1580 decl, field, NULL_TREE);
1581
1582 se->expr = tmp;
1583
1584 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
1585 {
1586 tmp = c->ts.u.cl->backend_decl;
1587 /* Components must always be constant length. */
1588 gcc_assert (tmp && INTEGER_CST_P (tmp));
1589 se->string_length = tmp;
1590 }
1591
1592 if (((c->attr.pointer || c->attr.allocatable)
1593 && (!c->attr.dimension && !c->attr.codimension)
1594 && c->ts.type != BT_CHARACTER)
1595 || c->attr.proc_pointer)
1596 se->expr = build_fold_indirect_ref_loc (input_location,
1597 se->expr);
1598 }
1599
1600
1601 /* This function deals with component references to components of the
1602 parent type for derived type extensions. */
1603 static void
conv_parent_component_references(gfc_se * se,gfc_ref * ref)1604 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
1605 {
1606 gfc_component *c;
1607 gfc_component *cmp;
1608 gfc_symbol *dt;
1609 gfc_ref parent;
1610
1611 dt = ref->u.c.sym;
1612 c = ref->u.c.component;
1613
1614 /* Return if the component is in the parent type. */
1615 for (cmp = dt->components; cmp; cmp = cmp->next)
1616 if (strcmp (c->name, cmp->name) == 0)
1617 return;
1618
1619 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1620 parent.type = REF_COMPONENT;
1621 parent.next = NULL;
1622 parent.u.c.sym = dt;
1623 parent.u.c.component = dt->components;
1624
1625 if (dt->backend_decl == NULL)
1626 gfc_get_derived_type (dt);
1627
1628 /* Build the reference and call self. */
1629 gfc_conv_component_ref (se, &parent);
1630 parent.u.c.sym = dt->components->ts.u.derived;
1631 parent.u.c.component = c;
1632 conv_parent_component_references (se, &parent);
1633 }
1634
1635 /* Return the contents of a variable. Also handles reference/pointer
1636 variables (all Fortran pointer references are implicit). */
1637
1638 static void
gfc_conv_variable(gfc_se * se,gfc_expr * expr)1639 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
1640 {
1641 gfc_ss *ss;
1642 gfc_ref *ref;
1643 gfc_symbol *sym;
1644 tree parent_decl = NULL_TREE;
1645 int parent_flag;
1646 bool return_value;
1647 bool alternate_entry;
1648 bool entry_master;
1649
1650 sym = expr->symtree->n.sym;
1651 ss = se->ss;
1652 if (ss != NULL)
1653 {
1654 gfc_ss_info *ss_info = ss->info;
1655
1656 /* Check that something hasn't gone horribly wrong. */
1657 gcc_assert (ss != gfc_ss_terminator);
1658 gcc_assert (ss_info->expr == expr);
1659
1660 /* A scalarized term. We already know the descriptor. */
1661 se->expr = ss_info->data.array.descriptor;
1662 se->string_length = ss_info->string_length;
1663 for (ref = ss_info->data.array.ref; ref; ref = ref->next)
1664 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
1665 break;
1666 }
1667 else
1668 {
1669 tree se_expr = NULL_TREE;
1670
1671 se->expr = gfc_get_symbol_decl (sym);
1672
1673 /* Deal with references to a parent results or entries by storing
1674 the current_function_decl and moving to the parent_decl. */
1675 return_value = sym->attr.function && sym->result == sym;
1676 alternate_entry = sym->attr.function && sym->attr.entry
1677 && sym->result == sym;
1678 entry_master = sym->attr.result
1679 && sym->ns->proc_name->attr.entry_master
1680 && !gfc_return_by_reference (sym->ns->proc_name);
1681 if (current_function_decl)
1682 parent_decl = DECL_CONTEXT (current_function_decl);
1683
1684 if ((se->expr == parent_decl && return_value)
1685 || (sym->ns && sym->ns->proc_name
1686 && parent_decl
1687 && sym->ns->proc_name->backend_decl == parent_decl
1688 && (alternate_entry || entry_master)))
1689 parent_flag = 1;
1690 else
1691 parent_flag = 0;
1692
1693 /* Special case for assigning the return value of a function.
1694 Self recursive functions must have an explicit return value. */
1695 if (return_value && (se->expr == current_function_decl || parent_flag))
1696 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1697
1698 /* Similarly for alternate entry points. */
1699 else if (alternate_entry
1700 && (sym->ns->proc_name->backend_decl == current_function_decl
1701 || parent_flag))
1702 {
1703 gfc_entry_list *el = NULL;
1704
1705 for (el = sym->ns->entries; el; el = el->next)
1706 if (sym == el->sym)
1707 {
1708 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1709 break;
1710 }
1711 }
1712
1713 else if (entry_master
1714 && (sym->ns->proc_name->backend_decl == current_function_decl
1715 || parent_flag))
1716 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1717
1718 if (se_expr)
1719 se->expr = se_expr;
1720
1721 /* Procedure actual arguments. */
1722 else if (sym->attr.flavor == FL_PROCEDURE
1723 && se->expr != current_function_decl)
1724 {
1725 if (!sym->attr.dummy && !sym->attr.proc_pointer)
1726 {
1727 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
1728 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1729 }
1730 return;
1731 }
1732
1733
1734 /* Dereference the expression, where needed. Since characters
1735 are entirely different from other types, they are treated
1736 separately. */
1737 if (sym->ts.type == BT_CHARACTER)
1738 {
1739 /* Dereference character pointer dummy arguments
1740 or results. */
1741 if ((sym->attr.pointer || sym->attr.allocatable)
1742 && (sym->attr.dummy
1743 || sym->attr.function
1744 || sym->attr.result))
1745 se->expr = build_fold_indirect_ref_loc (input_location,
1746 se->expr);
1747
1748 }
1749 else if (!sym->attr.value)
1750 {
1751 /* Dereference non-character scalar dummy arguments. */
1752 if (sym->attr.dummy && !sym->attr.dimension
1753 && !(sym->attr.codimension && sym->attr.allocatable))
1754 se->expr = build_fold_indirect_ref_loc (input_location,
1755 se->expr);
1756
1757 /* Dereference scalar hidden result. */
1758 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
1759 && (sym->attr.function || sym->attr.result)
1760 && !sym->attr.dimension && !sym->attr.pointer
1761 && !sym->attr.always_explicit)
1762 se->expr = build_fold_indirect_ref_loc (input_location,
1763 se->expr);
1764
1765 /* Dereference non-character pointer variables.
1766 These must be dummies, results, or scalars. */
1767 if ((sym->attr.pointer || sym->attr.allocatable
1768 || gfc_is_associate_pointer (sym)
1769 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
1770 && (sym->attr.dummy
1771 || sym->attr.function
1772 || sym->attr.result
1773 || (!sym->attr.dimension
1774 && (!sym->attr.codimension || !sym->attr.allocatable))))
1775 se->expr = build_fold_indirect_ref_loc (input_location,
1776 se->expr);
1777 }
1778
1779 ref = expr->ref;
1780 }
1781
1782 /* For character variables, also get the length. */
1783 if (sym->ts.type == BT_CHARACTER)
1784 {
1785 /* If the character length of an entry isn't set, get the length from
1786 the master function instead. */
1787 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
1788 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
1789 else
1790 se->string_length = sym->ts.u.cl->backend_decl;
1791 gcc_assert (se->string_length);
1792 }
1793
1794 while (ref)
1795 {
1796 switch (ref->type)
1797 {
1798 case REF_ARRAY:
1799 /* Return the descriptor if that's what we want and this is an array
1800 section reference. */
1801 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
1802 return;
1803 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1804 /* Return the descriptor for array pointers and allocations. */
1805 if (se->want_pointer
1806 && ref->next == NULL && (se->descriptor_only))
1807 return;
1808
1809 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
1810 /* Return a pointer to an element. */
1811 break;
1812
1813 case REF_COMPONENT:
1814 if (ref->u.c.sym->attr.extension)
1815 conv_parent_component_references (se, ref);
1816
1817 gfc_conv_component_ref (se, ref);
1818 if (!ref->next && ref->u.c.sym->attr.codimension
1819 && se->want_pointer && se->descriptor_only)
1820 return;
1821
1822 break;
1823
1824 case REF_SUBSTRING:
1825 gfc_conv_substring (se, ref, expr->ts.kind,
1826 expr->symtree->name, &expr->where);
1827 break;
1828
1829 default:
1830 gcc_unreachable ();
1831 break;
1832 }
1833 ref = ref->next;
1834 }
1835 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1836 separately. */
1837 if (se->want_pointer)
1838 {
1839 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
1840 gfc_conv_string_parameter (se);
1841 else
1842 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1843 }
1844 }
1845
1846
1847 /* Unary ops are easy... Or they would be if ! was a valid op. */
1848
1849 static void
gfc_conv_unary_op(enum tree_code code,gfc_se * se,gfc_expr * expr)1850 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
1851 {
1852 gfc_se operand;
1853 tree type;
1854
1855 gcc_assert (expr->ts.type != BT_CHARACTER);
1856 /* Initialize the operand. */
1857 gfc_init_se (&operand, se);
1858 gfc_conv_expr_val (&operand, expr->value.op.op1);
1859 gfc_add_block_to_block (&se->pre, &operand.pre);
1860
1861 type = gfc_typenode_for_spec (&expr->ts);
1862
1863 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1864 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1865 All other unary operators have an equivalent GIMPLE unary operator. */
1866 if (code == TRUTH_NOT_EXPR)
1867 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
1868 build_int_cst (type, 0));
1869 else
1870 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
1871
1872 }
1873
1874 /* Expand power operator to optimal multiplications when a value is raised
1875 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1876 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1877 Programming", 3rd Edition, 1998. */
1878
1879 /* This code is mostly duplicated from expand_powi in the backend.
1880 We establish the "optimal power tree" lookup table with the defined size.
1881 The items in the table are the exponents used to calculate the index
1882 exponents. Any integer n less than the value can get an "addition chain",
1883 with the first node being one. */
1884 #define POWI_TABLE_SIZE 256
1885
1886 /* The table is from builtins.c. */
1887 static const unsigned char powi_table[POWI_TABLE_SIZE] =
1888 {
1889 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1890 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1891 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1892 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1893 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1894 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1895 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1896 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1897 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1898 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1899 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1900 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1901 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1902 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1903 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1904 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1905 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1906 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1907 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1908 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1909 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1910 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1911 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1912 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1913 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1914 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1915 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1916 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1917 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1918 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1919 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1920 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1921 };
1922
1923 /* If n is larger than lookup table's max index, we use the "window
1924 method". */
1925 #define POWI_WINDOW_SIZE 3
1926
1927 /* Recursive function to expand the power operator. The temporary
1928 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1929 static tree
gfc_conv_powi(gfc_se * se,unsigned HOST_WIDE_INT n,tree * tmpvar)1930 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
1931 {
1932 tree op0;
1933 tree op1;
1934 tree tmp;
1935 int digit;
1936
1937 if (n < POWI_TABLE_SIZE)
1938 {
1939 if (tmpvar[n])
1940 return tmpvar[n];
1941
1942 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
1943 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
1944 }
1945 else if (n & 1)
1946 {
1947 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
1948 op0 = gfc_conv_powi (se, n - digit, tmpvar);
1949 op1 = gfc_conv_powi (se, digit, tmpvar);
1950 }
1951 else
1952 {
1953 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
1954 op1 = op0;
1955 }
1956
1957 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
1958 tmp = gfc_evaluate_now (tmp, &se->pre);
1959
1960 if (n < POWI_TABLE_SIZE)
1961 tmpvar[n] = tmp;
1962
1963 return tmp;
1964 }
1965
1966
1967 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1968 return 1. Else return 0 and a call to runtime library functions
1969 will have to be built. */
1970 static int
gfc_conv_cst_int_power(gfc_se * se,tree lhs,tree rhs)1971 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
1972 {
1973 tree cond;
1974 tree tmp;
1975 tree type;
1976 tree vartmp[POWI_TABLE_SIZE];
1977 HOST_WIDE_INT m;
1978 unsigned HOST_WIDE_INT n;
1979 int sgn;
1980
1981 /* If exponent is too large, we won't expand it anyway, so don't bother
1982 with large integer values. */
1983 if (!TREE_INT_CST (rhs).fits_shwi ())
1984 return 0;
1985
1986 m = TREE_INT_CST (rhs).to_shwi ();
1987 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1988 of the asymmetric range of the integer type. */
1989 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
1990
1991 type = TREE_TYPE (lhs);
1992 sgn = tree_int_cst_sgn (rhs);
1993
1994 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
1995 || optimize_size) && (m > 2 || m < -1))
1996 return 0;
1997
1998 /* rhs == 0 */
1999 if (sgn == 0)
2000 {
2001 se->expr = gfc_build_const (type, integer_one_node);
2002 return 1;
2003 }
2004
2005 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2006 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2007 {
2008 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2009 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2010 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2011 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2012
2013 /* If rhs is even,
2014 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2015 if ((n & 1) == 0)
2016 {
2017 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2018 boolean_type_node, tmp, cond);
2019 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2020 tmp, build_int_cst (type, 1),
2021 build_int_cst (type, 0));
2022 return 1;
2023 }
2024 /* If rhs is odd,
2025 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2026 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
2027 build_int_cst (type, -1),
2028 build_int_cst (type, 0));
2029 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2030 cond, build_int_cst (type, 1), tmp);
2031 return 1;
2032 }
2033
2034 memset (vartmp, 0, sizeof (vartmp));
2035 vartmp[1] = lhs;
2036 if (sgn == -1)
2037 {
2038 tmp = gfc_build_const (type, integer_one_node);
2039 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
2040 vartmp[1]);
2041 }
2042
2043 se->expr = gfc_conv_powi (se, n, vartmp);
2044
2045 return 1;
2046 }
2047
2048
2049 /* Power op (**). Constant integer exponent has special handling. */
2050
2051 static void
gfc_conv_power_op(gfc_se * se,gfc_expr * expr)2052 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
2053 {
2054 tree gfc_int4_type_node;
2055 int kind;
2056 int ikind;
2057 int res_ikind_1, res_ikind_2;
2058 gfc_se lse;
2059 gfc_se rse;
2060 tree fndecl = NULL;
2061
2062 gfc_init_se (&lse, se);
2063 gfc_conv_expr_val (&lse, expr->value.op.op1);
2064 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
2065 gfc_add_block_to_block (&se->pre, &lse.pre);
2066
2067 gfc_init_se (&rse, se);
2068 gfc_conv_expr_val (&rse, expr->value.op.op2);
2069 gfc_add_block_to_block (&se->pre, &rse.pre);
2070
2071 if (expr->value.op.op2->ts.type == BT_INTEGER
2072 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
2073 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
2074 return;
2075
2076 gfc_int4_type_node = gfc_get_int_type (4);
2077
2078 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2079 library routine. But in the end, we have to convert the result back
2080 if this case applies -- with res_ikind_K, we keep track whether operand K
2081 falls into this case. */
2082 res_ikind_1 = -1;
2083 res_ikind_2 = -1;
2084
2085 kind = expr->value.op.op1->ts.kind;
2086 switch (expr->value.op.op2->ts.type)
2087 {
2088 case BT_INTEGER:
2089 ikind = expr->value.op.op2->ts.kind;
2090 switch (ikind)
2091 {
2092 case 1:
2093 case 2:
2094 rse.expr = convert (gfc_int4_type_node, rse.expr);
2095 res_ikind_2 = ikind;
2096 /* Fall through. */
2097
2098 case 4:
2099 ikind = 0;
2100 break;
2101
2102 case 8:
2103 ikind = 1;
2104 break;
2105
2106 case 16:
2107 ikind = 2;
2108 break;
2109
2110 default:
2111 gcc_unreachable ();
2112 }
2113 switch (kind)
2114 {
2115 case 1:
2116 case 2:
2117 if (expr->value.op.op1->ts.type == BT_INTEGER)
2118 {
2119 lse.expr = convert (gfc_int4_type_node, lse.expr);
2120 res_ikind_1 = kind;
2121 }
2122 else
2123 gcc_unreachable ();
2124 /* Fall through. */
2125
2126 case 4:
2127 kind = 0;
2128 break;
2129
2130 case 8:
2131 kind = 1;
2132 break;
2133
2134 case 10:
2135 kind = 2;
2136 break;
2137
2138 case 16:
2139 kind = 3;
2140 break;
2141
2142 default:
2143 gcc_unreachable ();
2144 }
2145
2146 switch (expr->value.op.op1->ts.type)
2147 {
2148 case BT_INTEGER:
2149 if (kind == 3) /* Case 16 was not handled properly above. */
2150 kind = 2;
2151 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
2152 break;
2153
2154 case BT_REAL:
2155 /* Use builtins for real ** int4. */
2156 if (ikind == 0)
2157 {
2158 switch (kind)
2159 {
2160 case 0:
2161 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
2162 break;
2163
2164 case 1:
2165 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
2166 break;
2167
2168 case 2:
2169 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
2170 break;
2171
2172 case 3:
2173 /* Use the __builtin_powil() only if real(kind=16) is
2174 actually the C long double type. */
2175 if (!gfc_real16_is_float128)
2176 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
2177 break;
2178
2179 default:
2180 gcc_unreachable ();
2181 }
2182 }
2183
2184 /* If we don't have a good builtin for this, go for the
2185 library function. */
2186 if (!fndecl)
2187 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
2188 break;
2189
2190 case BT_COMPLEX:
2191 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
2192 break;
2193
2194 default:
2195 gcc_unreachable ();
2196 }
2197 break;
2198
2199 case BT_REAL:
2200 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
2201 break;
2202
2203 case BT_COMPLEX:
2204 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
2205 break;
2206
2207 default:
2208 gcc_unreachable ();
2209 break;
2210 }
2211
2212 se->expr = build_call_expr_loc (input_location,
2213 fndecl, 2, lse.expr, rse.expr);
2214
2215 /* Convert the result back if it is of wrong integer kind. */
2216 if (res_ikind_1 != -1 && res_ikind_2 != -1)
2217 {
2218 /* We want the maximum of both operand kinds as result. */
2219 if (res_ikind_1 < res_ikind_2)
2220 res_ikind_1 = res_ikind_2;
2221 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
2222 }
2223 }
2224
2225
2226 /* Generate code to allocate a string temporary. */
2227
2228 tree
gfc_conv_string_tmp(gfc_se * se,tree type,tree len)2229 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
2230 {
2231 tree var;
2232 tree tmp;
2233
2234 if (gfc_can_put_var_on_stack (len))
2235 {
2236 /* Create a temporary variable to hold the result. */
2237 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2238 gfc_charlen_type_node, len,
2239 build_int_cst (gfc_charlen_type_node, 1));
2240 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2241
2242 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
2243 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
2244 else
2245 tmp = build_array_type (TREE_TYPE (type), tmp);
2246
2247 var = gfc_create_var (tmp, "str");
2248 var = gfc_build_addr_expr (type, var);
2249 }
2250 else
2251 {
2252 /* Allocate a temporary to hold the result. */
2253 var = gfc_create_var (type, "pstr");
2254 tmp = gfc_call_malloc (&se->pre, type,
2255 fold_build2_loc (input_location, MULT_EXPR,
2256 TREE_TYPE (len), len,
2257 fold_convert (TREE_TYPE (len),
2258 TYPE_SIZE (type))));
2259 gfc_add_modify (&se->pre, var, tmp);
2260
2261 /* Free the temporary afterwards. */
2262 tmp = gfc_call_free (convert (pvoid_type_node, var));
2263 gfc_add_expr_to_block (&se->post, tmp);
2264 }
2265
2266 return var;
2267 }
2268
2269
2270 /* Handle a string concatenation operation. A temporary will be allocated to
2271 hold the result. */
2272
2273 static void
gfc_conv_concat_op(gfc_se * se,gfc_expr * expr)2274 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
2275 {
2276 gfc_se lse, rse;
2277 tree len, type, var, tmp, fndecl;
2278
2279 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
2280 && expr->value.op.op2->ts.type == BT_CHARACTER);
2281 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
2282
2283 gfc_init_se (&lse, se);
2284 gfc_conv_expr (&lse, expr->value.op.op1);
2285 gfc_conv_string_parameter (&lse);
2286 gfc_init_se (&rse, se);
2287 gfc_conv_expr (&rse, expr->value.op.op2);
2288 gfc_conv_string_parameter (&rse);
2289
2290 gfc_add_block_to_block (&se->pre, &lse.pre);
2291 gfc_add_block_to_block (&se->pre, &rse.pre);
2292
2293 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
2294 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2295 if (len == NULL_TREE)
2296 {
2297 len = fold_build2_loc (input_location, PLUS_EXPR,
2298 TREE_TYPE (lse.string_length),
2299 lse.string_length, rse.string_length);
2300 }
2301
2302 type = build_pointer_type (type);
2303
2304 var = gfc_conv_string_tmp (se, type, len);
2305
2306 /* Do the actual concatenation. */
2307 if (expr->ts.kind == 1)
2308 fndecl = gfor_fndecl_concat_string;
2309 else if (expr->ts.kind == 4)
2310 fndecl = gfor_fndecl_concat_string_char4;
2311 else
2312 gcc_unreachable ();
2313
2314 tmp = build_call_expr_loc (input_location,
2315 fndecl, 6, len, var, lse.string_length, lse.expr,
2316 rse.string_length, rse.expr);
2317 gfc_add_expr_to_block (&se->pre, tmp);
2318
2319 /* Add the cleanup for the operands. */
2320 gfc_add_block_to_block (&se->pre, &rse.post);
2321 gfc_add_block_to_block (&se->pre, &lse.post);
2322
2323 se->expr = var;
2324 se->string_length = len;
2325 }
2326
2327 /* Translates an op expression. Common (binary) cases are handled by this
2328 function, others are passed on. Recursion is used in either case.
2329 We use the fact that (op1.ts == op2.ts) (except for the power
2330 operator **).
2331 Operators need no special handling for scalarized expressions as long as
2332 they call gfc_conv_simple_val to get their operands.
2333 Character strings get special handling. */
2334
2335 static void
gfc_conv_expr_op(gfc_se * se,gfc_expr * expr)2336 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
2337 {
2338 enum tree_code code;
2339 gfc_se lse;
2340 gfc_se rse;
2341 tree tmp, type;
2342 int lop;
2343 int checkstring;
2344
2345 checkstring = 0;
2346 lop = 0;
2347 switch (expr->value.op.op)
2348 {
2349 case INTRINSIC_PARENTHESES:
2350 if ((expr->ts.type == BT_REAL
2351 || expr->ts.type == BT_COMPLEX)
2352 && gfc_option.flag_protect_parens)
2353 {
2354 gfc_conv_unary_op (PAREN_EXPR, se, expr);
2355 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
2356 return;
2357 }
2358
2359 /* Fallthrough. */
2360 case INTRINSIC_UPLUS:
2361 gfc_conv_expr (se, expr->value.op.op1);
2362 return;
2363
2364 case INTRINSIC_UMINUS:
2365 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
2366 return;
2367
2368 case INTRINSIC_NOT:
2369 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
2370 return;
2371
2372 case INTRINSIC_PLUS:
2373 code = PLUS_EXPR;
2374 break;
2375
2376 case INTRINSIC_MINUS:
2377 code = MINUS_EXPR;
2378 break;
2379
2380 case INTRINSIC_TIMES:
2381 code = MULT_EXPR;
2382 break;
2383
2384 case INTRINSIC_DIVIDE:
2385 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2386 an integer, we must round towards zero, so we use a
2387 TRUNC_DIV_EXPR. */
2388 if (expr->ts.type == BT_INTEGER)
2389 code = TRUNC_DIV_EXPR;
2390 else
2391 code = RDIV_EXPR;
2392 break;
2393
2394 case INTRINSIC_POWER:
2395 gfc_conv_power_op (se, expr);
2396 return;
2397
2398 case INTRINSIC_CONCAT:
2399 gfc_conv_concat_op (se, expr);
2400 return;
2401
2402 case INTRINSIC_AND:
2403 code = TRUTH_ANDIF_EXPR;
2404 lop = 1;
2405 break;
2406
2407 case INTRINSIC_OR:
2408 code = TRUTH_ORIF_EXPR;
2409 lop = 1;
2410 break;
2411
2412 /* EQV and NEQV only work on logicals, but since we represent them
2413 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2414 case INTRINSIC_EQ:
2415 case INTRINSIC_EQ_OS:
2416 case INTRINSIC_EQV:
2417 code = EQ_EXPR;
2418 checkstring = 1;
2419 lop = 1;
2420 break;
2421
2422 case INTRINSIC_NE:
2423 case INTRINSIC_NE_OS:
2424 case INTRINSIC_NEQV:
2425 code = NE_EXPR;
2426 checkstring = 1;
2427 lop = 1;
2428 break;
2429
2430 case INTRINSIC_GT:
2431 case INTRINSIC_GT_OS:
2432 code = GT_EXPR;
2433 checkstring = 1;
2434 lop = 1;
2435 break;
2436
2437 case INTRINSIC_GE:
2438 case INTRINSIC_GE_OS:
2439 code = GE_EXPR;
2440 checkstring = 1;
2441 lop = 1;
2442 break;
2443
2444 case INTRINSIC_LT:
2445 case INTRINSIC_LT_OS:
2446 code = LT_EXPR;
2447 checkstring = 1;
2448 lop = 1;
2449 break;
2450
2451 case INTRINSIC_LE:
2452 case INTRINSIC_LE_OS:
2453 code = LE_EXPR;
2454 checkstring = 1;
2455 lop = 1;
2456 break;
2457
2458 case INTRINSIC_USER:
2459 case INTRINSIC_ASSIGN:
2460 /* These should be converted into function calls by the frontend. */
2461 gcc_unreachable ();
2462
2463 default:
2464 fatal_error ("Unknown intrinsic op");
2465 return;
2466 }
2467
2468 /* The only exception to this is **, which is handled separately anyway. */
2469 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
2470
2471 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
2472 checkstring = 0;
2473
2474 /* lhs */
2475 gfc_init_se (&lse, se);
2476 gfc_conv_expr (&lse, expr->value.op.op1);
2477 gfc_add_block_to_block (&se->pre, &lse.pre);
2478
2479 /* rhs */
2480 gfc_init_se (&rse, se);
2481 gfc_conv_expr (&rse, expr->value.op.op2);
2482 gfc_add_block_to_block (&se->pre, &rse.pre);
2483
2484 if (checkstring)
2485 {
2486 gfc_conv_string_parameter (&lse);
2487 gfc_conv_string_parameter (&rse);
2488
2489 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
2490 rse.string_length, rse.expr,
2491 expr->value.op.op1->ts.kind,
2492 code);
2493 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
2494 gfc_add_block_to_block (&lse.post, &rse.post);
2495 }
2496
2497 type = gfc_typenode_for_spec (&expr->ts);
2498
2499 if (lop)
2500 {
2501 /* The result of logical ops is always boolean_type_node. */
2502 tmp = fold_build2_loc (input_location, code, boolean_type_node,
2503 lse.expr, rse.expr);
2504 se->expr = convert (type, tmp);
2505 }
2506 else
2507 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
2508
2509 /* Add the post blocks. */
2510 gfc_add_block_to_block (&se->post, &rse.post);
2511 gfc_add_block_to_block (&se->post, &lse.post);
2512 }
2513
2514 /* If a string's length is one, we convert it to a single character. */
2515
2516 tree
gfc_string_to_single_character(tree len,tree str,int kind)2517 gfc_string_to_single_character (tree len, tree str, int kind)
2518 {
2519
2520 if (len == NULL
2521 || !INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
2522 || !POINTER_TYPE_P (TREE_TYPE (str)))
2523 return NULL_TREE;
2524
2525 if (TREE_INT_CST_LOW (len) == 1)
2526 {
2527 str = fold_convert (gfc_get_pchar_type (kind), str);
2528 return build_fold_indirect_ref_loc (input_location, str);
2529 }
2530
2531 if (kind == 1
2532 && TREE_CODE (str) == ADDR_EXPR
2533 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2534 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2535 && array_ref_low_bound (TREE_OPERAND (str, 0))
2536 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2537 && TREE_INT_CST_LOW (len) > 1
2538 && TREE_INT_CST_LOW (len)
2539 == (unsigned HOST_WIDE_INT)
2540 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2541 {
2542 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
2543 ret = build_fold_indirect_ref_loc (input_location, ret);
2544 if (TREE_CODE (ret) == INTEGER_CST)
2545 {
2546 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2547 int i, length = TREE_STRING_LENGTH (string_cst);
2548 const char *ptr = TREE_STRING_POINTER (string_cst);
2549
2550 for (i = 1; i < length; i++)
2551 if (ptr[i] != ' ')
2552 return NULL_TREE;
2553
2554 return ret;
2555 }
2556 }
2557
2558 return NULL_TREE;
2559 }
2560
2561
2562 void
gfc_conv_scalar_char_value(gfc_symbol * sym,gfc_se * se,gfc_expr ** expr)2563 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
2564 {
2565
2566 if (sym->backend_decl)
2567 {
2568 /* This becomes the nominal_type in
2569 function.c:assign_parm_find_data_types. */
2570 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
2571 /* This becomes the passed_type in
2572 function.c:assign_parm_find_data_types. C promotes char to
2573 integer for argument passing. */
2574 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
2575
2576 DECL_BY_REFERENCE (sym->backend_decl) = 0;
2577 }
2578
2579 if (expr != NULL)
2580 {
2581 /* If we have a constant character expression, make it into an
2582 integer. */
2583 if ((*expr)->expr_type == EXPR_CONSTANT)
2584 {
2585 gfc_typespec ts;
2586 gfc_clear_ts (&ts);
2587
2588 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
2589 (int)(*expr)->value.character.string[0]);
2590 if ((*expr)->ts.kind != gfc_c_int_kind)
2591 {
2592 /* The expr needs to be compatible with a C int. If the
2593 conversion fails, then the 2 causes an ICE. */
2594 ts.type = BT_INTEGER;
2595 ts.kind = gfc_c_int_kind;
2596 gfc_convert_type (*expr, &ts, 2);
2597 }
2598 }
2599 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
2600 {
2601 if ((*expr)->ref == NULL)
2602 {
2603 se->expr = gfc_string_to_single_character
2604 (build_int_cst (integer_type_node, 1),
2605 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2606 gfc_get_symbol_decl
2607 ((*expr)->symtree->n.sym)),
2608 (*expr)->ts.kind);
2609 }
2610 else
2611 {
2612 gfc_conv_variable (se, *expr);
2613 se->expr = gfc_string_to_single_character
2614 (build_int_cst (integer_type_node, 1),
2615 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2616 se->expr),
2617 (*expr)->ts.kind);
2618 }
2619 }
2620 }
2621 }
2622
2623 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2624 if STR is a string literal, otherwise return -1. */
2625
2626 static int
gfc_optimize_len_trim(tree len,tree str,int kind)2627 gfc_optimize_len_trim (tree len, tree str, int kind)
2628 {
2629 if (kind == 1
2630 && TREE_CODE (str) == ADDR_EXPR
2631 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2632 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2633 && array_ref_low_bound (TREE_OPERAND (str, 0))
2634 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2635 && TREE_INT_CST_LOW (len) >= 1
2636 && TREE_INT_CST_LOW (len)
2637 == (unsigned HOST_WIDE_INT)
2638 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2639 {
2640 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
2641 folded = build_fold_indirect_ref_loc (input_location, folded);
2642 if (TREE_CODE (folded) == INTEGER_CST)
2643 {
2644 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2645 int length = TREE_STRING_LENGTH (string_cst);
2646 const char *ptr = TREE_STRING_POINTER (string_cst);
2647
2648 for (; length > 0; length--)
2649 if (ptr[length - 1] != ' ')
2650 break;
2651
2652 return length;
2653 }
2654 }
2655 return -1;
2656 }
2657
2658 /* Compare two strings. If they are all single characters, the result is the
2659 subtraction of them. Otherwise, we build a library call. */
2660
2661 tree
gfc_build_compare_string(tree len1,tree str1,tree len2,tree str2,int kind,enum tree_code code)2662 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
2663 enum tree_code code)
2664 {
2665 tree sc1;
2666 tree sc2;
2667 tree fndecl;
2668
2669 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
2670 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
2671
2672 sc1 = gfc_string_to_single_character (len1, str1, kind);
2673 sc2 = gfc_string_to_single_character (len2, str2, kind);
2674
2675 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
2676 {
2677 /* Deal with single character specially. */
2678 sc1 = fold_convert (integer_type_node, sc1);
2679 sc2 = fold_convert (integer_type_node, sc2);
2680 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
2681 sc1, sc2);
2682 }
2683
2684 if ((code == EQ_EXPR || code == NE_EXPR)
2685 && optimize
2686 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
2687 {
2688 /* If one string is a string literal with LEN_TRIM longer
2689 than the length of the second string, the strings
2690 compare unequal. */
2691 int len = gfc_optimize_len_trim (len1, str1, kind);
2692 if (len > 0 && compare_tree_int (len2, len) < 0)
2693 return integer_one_node;
2694 len = gfc_optimize_len_trim (len2, str2, kind);
2695 if (len > 0 && compare_tree_int (len1, len) < 0)
2696 return integer_one_node;
2697 }
2698
2699 /* Build a call for the comparison. */
2700 if (kind == 1)
2701 fndecl = gfor_fndecl_compare_string;
2702 else if (kind == 4)
2703 fndecl = gfor_fndecl_compare_string_char4;
2704 else
2705 gcc_unreachable ();
2706
2707 return build_call_expr_loc (input_location, fndecl, 4,
2708 len1, str1, len2, str2);
2709 }
2710
2711
2712 /* Return the backend_decl for a procedure pointer component. */
2713
2714 static tree
get_proc_ptr_comp(gfc_expr * e)2715 get_proc_ptr_comp (gfc_expr *e)
2716 {
2717 gfc_se comp_se;
2718 gfc_expr *e2;
2719 expr_t old_type;
2720
2721 gfc_init_se (&comp_se, NULL);
2722 e2 = gfc_copy_expr (e);
2723 /* We have to restore the expr type later so that gfc_free_expr frees
2724 the exact same thing that was allocated.
2725 TODO: This is ugly. */
2726 old_type = e2->expr_type;
2727 e2->expr_type = EXPR_VARIABLE;
2728 gfc_conv_expr (&comp_se, e2);
2729 e2->expr_type = old_type;
2730 gfc_free_expr (e2);
2731 return build_fold_addr_expr_loc (input_location, comp_se.expr);
2732 }
2733
2734
2735 /* Convert a typebound function reference from a class object. */
2736 static void
conv_base_obj_fcn_val(gfc_se * se,tree base_object,gfc_expr * expr)2737 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
2738 {
2739 gfc_ref *ref;
2740 tree var;
2741
2742 if (TREE_CODE (base_object) != VAR_DECL)
2743 {
2744 var = gfc_create_var (TREE_TYPE (base_object), NULL);
2745 gfc_add_modify (&se->pre, var, base_object);
2746 }
2747 se->expr = gfc_class_vptr_get (base_object);
2748 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2749 ref = expr->ref;
2750 while (ref && ref->next)
2751 ref = ref->next;
2752 gcc_assert (ref && ref->type == REF_COMPONENT);
2753 if (ref->u.c.sym->attr.extension)
2754 conv_parent_component_references (se, ref);
2755 gfc_conv_component_ref (se, ref);
2756 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
2757 }
2758
2759
2760 static void
conv_function_val(gfc_se * se,gfc_symbol * sym,gfc_expr * expr)2761 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
2762 {
2763 tree tmp;
2764
2765 if (gfc_is_proc_ptr_comp (expr))
2766 tmp = get_proc_ptr_comp (expr);
2767 else if (sym->attr.dummy)
2768 {
2769 tmp = gfc_get_symbol_decl (sym);
2770 if (sym->attr.proc_pointer)
2771 tmp = build_fold_indirect_ref_loc (input_location,
2772 tmp);
2773 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
2774 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
2775 }
2776 else
2777 {
2778 if (!sym->backend_decl)
2779 sym->backend_decl = gfc_get_extern_function_decl (sym);
2780
2781 TREE_USED (sym->backend_decl) = 1;
2782
2783 tmp = sym->backend_decl;
2784
2785 if (sym->attr.cray_pointee)
2786 {
2787 /* TODO - make the cray pointee a pointer to a procedure,
2788 assign the pointer to it and use it for the call. This
2789 will do for now! */
2790 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
2791 gfc_get_symbol_decl (sym->cp_pointer));
2792 tmp = gfc_evaluate_now (tmp, &se->pre);
2793 }
2794
2795 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
2796 {
2797 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
2798 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2799 }
2800 }
2801 se->expr = tmp;
2802 }
2803
2804
2805 /* Initialize MAPPING. */
2806
2807 void
gfc_init_interface_mapping(gfc_interface_mapping * mapping)2808 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
2809 {
2810 mapping->syms = NULL;
2811 mapping->charlens = NULL;
2812 }
2813
2814
2815 /* Free all memory held by MAPPING (but not MAPPING itself). */
2816
2817 void
gfc_free_interface_mapping(gfc_interface_mapping * mapping)2818 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
2819 {
2820 gfc_interface_sym_mapping *sym;
2821 gfc_interface_sym_mapping *nextsym;
2822 gfc_charlen *cl;
2823 gfc_charlen *nextcl;
2824
2825 for (sym = mapping->syms; sym; sym = nextsym)
2826 {
2827 nextsym = sym->next;
2828 sym->new_sym->n.sym->formal = NULL;
2829 gfc_free_symbol (sym->new_sym->n.sym);
2830 gfc_free_expr (sym->expr);
2831 free (sym->new_sym);
2832 free (sym);
2833 }
2834 for (cl = mapping->charlens; cl; cl = nextcl)
2835 {
2836 nextcl = cl->next;
2837 gfc_free_expr (cl->length);
2838 free (cl);
2839 }
2840 }
2841
2842
2843 /* Return a copy of gfc_charlen CL. Add the returned structure to
2844 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2845
2846 static gfc_charlen *
gfc_get_interface_mapping_charlen(gfc_interface_mapping * mapping,gfc_charlen * cl)2847 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
2848 gfc_charlen * cl)
2849 {
2850 gfc_charlen *new_charlen;
2851
2852 new_charlen = gfc_get_charlen ();
2853 new_charlen->next = mapping->charlens;
2854 new_charlen->length = gfc_copy_expr (cl->length);
2855
2856 mapping->charlens = new_charlen;
2857 return new_charlen;
2858 }
2859
2860
2861 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2862 array variable that can be used as the actual argument for dummy
2863 argument SYM. Add any initialization code to BLOCK. PACKED is as
2864 for gfc_get_nodesc_array_type and DATA points to the first element
2865 in the passed array. */
2866
2867 static tree
gfc_get_interface_mapping_array(stmtblock_t * block,gfc_symbol * sym,gfc_packed packed,tree data)2868 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
2869 gfc_packed packed, tree data)
2870 {
2871 tree type;
2872 tree var;
2873
2874 type = gfc_typenode_for_spec (&sym->ts);
2875 type = gfc_get_nodesc_array_type (type, sym->as, packed,
2876 !sym->attr.target && !sym->attr.pointer
2877 && !sym->attr.proc_pointer);
2878
2879 var = gfc_create_var (type, "ifm");
2880 gfc_add_modify (block, var, fold_convert (type, data));
2881
2882 return var;
2883 }
2884
2885
2886 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2887 and offset of descriptorless array type TYPE given that it has the same
2888 size as DESC. Add any set-up code to BLOCK. */
2889
2890 static void
gfc_set_interface_mapping_bounds(stmtblock_t * block,tree type,tree desc)2891 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
2892 {
2893 int n;
2894 tree dim;
2895 tree offset;
2896 tree tmp;
2897
2898 offset = gfc_index_zero_node;
2899 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
2900 {
2901 dim = gfc_rank_cst[n];
2902 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
2903 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
2904 {
2905 GFC_TYPE_ARRAY_LBOUND (type, n)
2906 = gfc_conv_descriptor_lbound_get (desc, dim);
2907 GFC_TYPE_ARRAY_UBOUND (type, n)
2908 = gfc_conv_descriptor_ubound_get (desc, dim);
2909 }
2910 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
2911 {
2912 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2913 gfc_array_index_type,
2914 gfc_conv_descriptor_ubound_get (desc, dim),
2915 gfc_conv_descriptor_lbound_get (desc, dim));
2916 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2917 gfc_array_index_type,
2918 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
2919 tmp = gfc_evaluate_now (tmp, block);
2920 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
2921 }
2922 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2923 GFC_TYPE_ARRAY_LBOUND (type, n),
2924 GFC_TYPE_ARRAY_STRIDE (type, n));
2925 offset = fold_build2_loc (input_location, MINUS_EXPR,
2926 gfc_array_index_type, offset, tmp);
2927 }
2928 offset = gfc_evaluate_now (offset, block);
2929 GFC_TYPE_ARRAY_OFFSET (type) = offset;
2930 }
2931
2932
2933 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2934 in SE. The caller may still use se->expr and se->string_length after
2935 calling this function. */
2936
2937 void
gfc_add_interface_mapping(gfc_interface_mapping * mapping,gfc_symbol * sym,gfc_se * se,gfc_expr * expr)2938 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
2939 gfc_symbol * sym, gfc_se * se,
2940 gfc_expr *expr)
2941 {
2942 gfc_interface_sym_mapping *sm;
2943 tree desc;
2944 tree tmp;
2945 tree value;
2946 gfc_symbol *new_sym;
2947 gfc_symtree *root;
2948 gfc_symtree *new_symtree;
2949
2950 /* Create a new symbol to represent the actual argument. */
2951 new_sym = gfc_new_symbol (sym->name, NULL);
2952 new_sym->ts = sym->ts;
2953 new_sym->as = gfc_copy_array_spec (sym->as);
2954 new_sym->attr.referenced = 1;
2955 new_sym->attr.dimension = sym->attr.dimension;
2956 new_sym->attr.contiguous = sym->attr.contiguous;
2957 new_sym->attr.codimension = sym->attr.codimension;
2958 new_sym->attr.pointer = sym->attr.pointer;
2959 new_sym->attr.allocatable = sym->attr.allocatable;
2960 new_sym->attr.flavor = sym->attr.flavor;
2961 new_sym->attr.function = sym->attr.function;
2962
2963 /* Ensure that the interface is available and that
2964 descriptors are passed for array actual arguments. */
2965 if (sym->attr.flavor == FL_PROCEDURE)
2966 {
2967 new_sym->formal = expr->symtree->n.sym->formal;
2968 new_sym->attr.always_explicit
2969 = expr->symtree->n.sym->attr.always_explicit;
2970 }
2971
2972 /* Create a fake symtree for it. */
2973 root = NULL;
2974 new_symtree = gfc_new_symtree (&root, sym->name);
2975 new_symtree->n.sym = new_sym;
2976 gcc_assert (new_symtree == root);
2977
2978 /* Create a dummy->actual mapping. */
2979 sm = XCNEW (gfc_interface_sym_mapping);
2980 sm->next = mapping->syms;
2981 sm->old = sym;
2982 sm->new_sym = new_symtree;
2983 sm->expr = gfc_copy_expr (expr);
2984 mapping->syms = sm;
2985
2986 /* Stabilize the argument's value. */
2987 if (!sym->attr.function && se)
2988 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2989
2990 if (sym->ts.type == BT_CHARACTER)
2991 {
2992 /* Create a copy of the dummy argument's length. */
2993 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
2994 sm->expr->ts.u.cl = new_sym->ts.u.cl;
2995
2996 /* If the length is specified as "*", record the length that
2997 the caller is passing. We should use the callee's length
2998 in all other cases. */
2999 if (!new_sym->ts.u.cl->length && se)
3000 {
3001 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
3002 new_sym->ts.u.cl->backend_decl = se->string_length;
3003 }
3004 }
3005
3006 if (!se)
3007 return;
3008
3009 /* Use the passed value as-is if the argument is a function. */
3010 if (sym->attr.flavor == FL_PROCEDURE)
3011 value = se->expr;
3012
3013 /* If the argument is either a string or a pointer to a string,
3014 convert it to a boundless character type. */
3015 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
3016 {
3017 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
3018 tmp = build_pointer_type (tmp);
3019 if (sym->attr.pointer)
3020 value = build_fold_indirect_ref_loc (input_location,
3021 se->expr);
3022 else
3023 value = se->expr;
3024 value = fold_convert (tmp, value);
3025 }
3026
3027 /* If the argument is a scalar, a pointer to an array or an allocatable,
3028 dereference it. */
3029 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
3030 value = build_fold_indirect_ref_loc (input_location,
3031 se->expr);
3032
3033 /* For character(*), use the actual argument's descriptor. */
3034 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
3035 value = build_fold_indirect_ref_loc (input_location,
3036 se->expr);
3037
3038 /* If the argument is an array descriptor, use it to determine
3039 information about the actual argument's shape. */
3040 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
3041 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
3042 {
3043 /* Get the actual argument's descriptor. */
3044 desc = build_fold_indirect_ref_loc (input_location,
3045 se->expr);
3046
3047 /* Create the replacement variable. */
3048 tmp = gfc_conv_descriptor_data_get (desc);
3049 value = gfc_get_interface_mapping_array (&se->pre, sym,
3050 PACKED_NO, tmp);
3051
3052 /* Use DESC to work out the upper bounds, strides and offset. */
3053 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
3054 }
3055 else
3056 /* Otherwise we have a packed array. */
3057 value = gfc_get_interface_mapping_array (&se->pre, sym,
3058 PACKED_FULL, se->expr);
3059
3060 new_sym->backend_decl = value;
3061 }
3062
3063
3064 /* Called once all dummy argument mappings have been added to MAPPING,
3065 but before the mapping is used to evaluate expressions. Pre-evaluate
3066 the length of each argument, adding any initialization code to PRE and
3067 any finalization code to POST. */
3068
3069 void
gfc_finish_interface_mapping(gfc_interface_mapping * mapping,stmtblock_t * pre,stmtblock_t * post)3070 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
3071 stmtblock_t * pre, stmtblock_t * post)
3072 {
3073 gfc_interface_sym_mapping *sym;
3074 gfc_expr *expr;
3075 gfc_se se;
3076
3077 for (sym = mapping->syms; sym; sym = sym->next)
3078 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
3079 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
3080 {
3081 expr = sym->new_sym->n.sym->ts.u.cl->length;
3082 gfc_apply_interface_mapping_to_expr (mapping, expr);
3083 gfc_init_se (&se, NULL);
3084 gfc_conv_expr (&se, expr);
3085 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
3086 se.expr = gfc_evaluate_now (se.expr, &se.pre);
3087 gfc_add_block_to_block (pre, &se.pre);
3088 gfc_add_block_to_block (post, &se.post);
3089
3090 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
3091 }
3092 }
3093
3094
3095 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3096 constructor C. */
3097
3098 static void
gfc_apply_interface_mapping_to_cons(gfc_interface_mapping * mapping,gfc_constructor_base base)3099 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
3100 gfc_constructor_base base)
3101 {
3102 gfc_constructor *c;
3103 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
3104 {
3105 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
3106 if (c->iterator)
3107 {
3108 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
3109 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
3110 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
3111 }
3112 }
3113 }
3114
3115
3116 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3117 reference REF. */
3118
3119 static void
gfc_apply_interface_mapping_to_ref(gfc_interface_mapping * mapping,gfc_ref * ref)3120 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
3121 gfc_ref * ref)
3122 {
3123 int n;
3124
3125 for (; ref; ref = ref->next)
3126 switch (ref->type)
3127 {
3128 case REF_ARRAY:
3129 for (n = 0; n < ref->u.ar.dimen; n++)
3130 {
3131 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
3132 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
3133 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
3134 }
3135 break;
3136
3137 case REF_COMPONENT:
3138 break;
3139
3140 case REF_SUBSTRING:
3141 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
3142 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
3143 break;
3144 }
3145 }
3146
3147
3148 /* Convert intrinsic function calls into result expressions. */
3149
3150 static bool
gfc_map_intrinsic_function(gfc_expr * expr,gfc_interface_mapping * mapping)3151 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
3152 {
3153 gfc_symbol *sym;
3154 gfc_expr *new_expr;
3155 gfc_expr *arg1;
3156 gfc_expr *arg2;
3157 int d, dup;
3158
3159 arg1 = expr->value.function.actual->expr;
3160 if (expr->value.function.actual->next)
3161 arg2 = expr->value.function.actual->next->expr;
3162 else
3163 arg2 = NULL;
3164
3165 sym = arg1->symtree->n.sym;
3166
3167 if (sym->attr.dummy)
3168 return false;
3169
3170 new_expr = NULL;
3171
3172 switch (expr->value.function.isym->id)
3173 {
3174 case GFC_ISYM_LEN:
3175 /* TODO figure out why this condition is necessary. */
3176 if (sym->attr.function
3177 && (arg1->ts.u.cl->length == NULL
3178 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
3179 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
3180 return false;
3181
3182 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
3183 break;
3184
3185 case GFC_ISYM_SIZE:
3186 if (!sym->as || sym->as->rank == 0)
3187 return false;
3188
3189 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
3190 {
3191 dup = mpz_get_si (arg2->value.integer);
3192 d = dup - 1;
3193 }
3194 else
3195 {
3196 dup = sym->as->rank;
3197 d = 0;
3198 }
3199
3200 for (; d < dup; d++)
3201 {
3202 gfc_expr *tmp;
3203
3204 if (!sym->as->upper[d] || !sym->as->lower[d])
3205 {
3206 gfc_free_expr (new_expr);
3207 return false;
3208 }
3209
3210 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
3211 gfc_get_int_expr (gfc_default_integer_kind,
3212 NULL, 1));
3213 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
3214 if (new_expr)
3215 new_expr = gfc_multiply (new_expr, tmp);
3216 else
3217 new_expr = tmp;
3218 }
3219 break;
3220
3221 case GFC_ISYM_LBOUND:
3222 case GFC_ISYM_UBOUND:
3223 /* TODO These implementations of lbound and ubound do not limit if
3224 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3225
3226 if (!sym->as || sym->as->rank == 0)
3227 return false;
3228
3229 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
3230 d = mpz_get_si (arg2->value.integer) - 1;
3231 else
3232 /* TODO: If the need arises, this could produce an array of
3233 ubound/lbounds. */
3234 gcc_unreachable ();
3235
3236 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
3237 {
3238 if (sym->as->lower[d])
3239 new_expr = gfc_copy_expr (sym->as->lower[d]);
3240 }
3241 else
3242 {
3243 if (sym->as->upper[d])
3244 new_expr = gfc_copy_expr (sym->as->upper[d]);
3245 }
3246 break;
3247
3248 default:
3249 break;
3250 }
3251
3252 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
3253 if (!new_expr)
3254 return false;
3255
3256 gfc_replace_expr (expr, new_expr);
3257 return true;
3258 }
3259
3260
3261 static void
gfc_map_fcn_formal_to_actual(gfc_expr * expr,gfc_expr * map_expr,gfc_interface_mapping * mapping)3262 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
3263 gfc_interface_mapping * mapping)
3264 {
3265 gfc_formal_arglist *f;
3266 gfc_actual_arglist *actual;
3267
3268 actual = expr->value.function.actual;
3269 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
3270
3271 for (; f && actual; f = f->next, actual = actual->next)
3272 {
3273 if (!actual->expr)
3274 continue;
3275
3276 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
3277 }
3278
3279 if (map_expr->symtree->n.sym->attr.dimension)
3280 {
3281 int d;
3282 gfc_array_spec *as;
3283
3284 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
3285
3286 for (d = 0; d < as->rank; d++)
3287 {
3288 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
3289 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
3290 }
3291
3292 expr->value.function.esym->as = as;
3293 }
3294
3295 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
3296 {
3297 expr->value.function.esym->ts.u.cl->length
3298 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
3299
3300 gfc_apply_interface_mapping_to_expr (mapping,
3301 expr->value.function.esym->ts.u.cl->length);
3302 }
3303 }
3304
3305
3306 /* EXPR is a copy of an expression that appeared in the interface
3307 associated with MAPPING. Walk it recursively looking for references to
3308 dummy arguments that MAPPING maps to actual arguments. Replace each such
3309 reference with a reference to the associated actual argument. */
3310
3311 static void
gfc_apply_interface_mapping_to_expr(gfc_interface_mapping * mapping,gfc_expr * expr)3312 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
3313 gfc_expr * expr)
3314 {
3315 gfc_interface_sym_mapping *sym;
3316 gfc_actual_arglist *actual;
3317
3318 if (!expr)
3319 return;
3320
3321 /* Copying an expression does not copy its length, so do that here. */
3322 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
3323 {
3324 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
3325 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
3326 }
3327
3328 /* Apply the mapping to any references. */
3329 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
3330
3331 /* ...and to the expression's symbol, if it has one. */
3332 /* TODO Find out why the condition on expr->symtree had to be moved into
3333 the loop rather than being outside it, as originally. */
3334 for (sym = mapping->syms; sym; sym = sym->next)
3335 if (expr->symtree && sym->old == expr->symtree->n.sym)
3336 {
3337 if (sym->new_sym->n.sym->backend_decl)
3338 expr->symtree = sym->new_sym;
3339 else if (sym->expr)
3340 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
3341 /* Replace base type for polymorphic arguments. */
3342 if (expr->ref && expr->ref->type == REF_COMPONENT
3343 && sym->expr && sym->expr->ts.type == BT_CLASS)
3344 expr->ref->u.c.sym = sym->expr->ts.u.derived;
3345 }
3346
3347 /* ...and to subexpressions in expr->value. */
3348 switch (expr->expr_type)
3349 {
3350 case EXPR_VARIABLE:
3351 case EXPR_CONSTANT:
3352 case EXPR_NULL:
3353 case EXPR_SUBSTRING:
3354 break;
3355
3356 case EXPR_OP:
3357 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
3358 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
3359 break;
3360
3361 case EXPR_FUNCTION:
3362 for (actual = expr->value.function.actual; actual; actual = actual->next)
3363 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
3364
3365 if (expr->value.function.esym == NULL
3366 && expr->value.function.isym != NULL
3367 && expr->value.function.actual->expr->symtree
3368 && gfc_map_intrinsic_function (expr, mapping))
3369 break;
3370
3371 for (sym = mapping->syms; sym; sym = sym->next)
3372 if (sym->old == expr->value.function.esym)
3373 {
3374 expr->value.function.esym = sym->new_sym->n.sym;
3375 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
3376 expr->value.function.esym->result = sym->new_sym->n.sym;
3377 }
3378 break;
3379
3380 case EXPR_ARRAY:
3381 case EXPR_STRUCTURE:
3382 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
3383 break;
3384
3385 case EXPR_COMPCALL:
3386 case EXPR_PPC:
3387 gcc_unreachable ();
3388 break;
3389 }
3390
3391 return;
3392 }
3393
3394
3395 /* Evaluate interface expression EXPR using MAPPING. Store the result
3396 in SE. */
3397
3398 void
gfc_apply_interface_mapping(gfc_interface_mapping * mapping,gfc_se * se,gfc_expr * expr)3399 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
3400 gfc_se * se, gfc_expr * expr)
3401 {
3402 expr = gfc_copy_expr (expr);
3403 gfc_apply_interface_mapping_to_expr (mapping, expr);
3404 gfc_conv_expr (se, expr);
3405 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3406 gfc_free_expr (expr);
3407 }
3408
3409
3410 /* Returns a reference to a temporary array into which a component of
3411 an actual argument derived type array is copied and then returned
3412 after the function call. */
3413 void
gfc_conv_subref_array_arg(gfc_se * parmse,gfc_expr * expr,int g77,sym_intent intent,bool formal_ptr)3414 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
3415 sym_intent intent, bool formal_ptr)
3416 {
3417 gfc_se lse;
3418 gfc_se rse;
3419 gfc_ss *lss;
3420 gfc_ss *rss;
3421 gfc_loopinfo loop;
3422 gfc_loopinfo loop2;
3423 gfc_array_info *info;
3424 tree offset;
3425 tree tmp_index;
3426 tree tmp;
3427 tree base_type;
3428 tree size;
3429 stmtblock_t body;
3430 int n;
3431 int dimen;
3432
3433 gcc_assert (expr->expr_type == EXPR_VARIABLE);
3434
3435 gfc_init_se (&lse, NULL);
3436 gfc_init_se (&rse, NULL);
3437
3438 /* Walk the argument expression. */
3439 rss = gfc_walk_expr (expr);
3440
3441 gcc_assert (rss != gfc_ss_terminator);
3442
3443 /* Initialize the scalarizer. */
3444 gfc_init_loopinfo (&loop);
3445 gfc_add_ss_to_loop (&loop, rss);
3446
3447 /* Calculate the bounds of the scalarization. */
3448 gfc_conv_ss_startstride (&loop);
3449
3450 /* Build an ss for the temporary. */
3451 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
3452 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
3453
3454 base_type = gfc_typenode_for_spec (&expr->ts);
3455 if (GFC_ARRAY_TYPE_P (base_type)
3456 || GFC_DESCRIPTOR_TYPE_P (base_type))
3457 base_type = gfc_get_element_type (base_type);
3458
3459 if (expr->ts.type == BT_CLASS)
3460 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
3461
3462 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
3463 ? expr->ts.u.cl->backend_decl
3464 : NULL),
3465 loop.dimen);
3466
3467 parmse->string_length = loop.temp_ss->info->string_length;
3468
3469 /* Associate the SS with the loop. */
3470 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3471
3472 /* Setup the scalarizing loops. */
3473 gfc_conv_loop_setup (&loop, &expr->where);
3474
3475 /* Pass the temporary descriptor back to the caller. */
3476 info = &loop.temp_ss->info->data.array;
3477 parmse->expr = info->descriptor;
3478
3479 /* Setup the gfc_se structures. */
3480 gfc_copy_loopinfo_to_se (&lse, &loop);
3481 gfc_copy_loopinfo_to_se (&rse, &loop);
3482
3483 rse.ss = rss;
3484 lse.ss = loop.temp_ss;
3485 gfc_mark_ss_chain_used (rss, 1);
3486 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3487
3488 /* Start the scalarized loop body. */
3489 gfc_start_scalarized_body (&loop, &body);
3490
3491 /* Translate the expression. */
3492 gfc_conv_expr (&rse, expr);
3493
3494 gfc_conv_tmp_array_ref (&lse);
3495
3496 if (intent != INTENT_OUT)
3497 {
3498 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
3499 gfc_add_expr_to_block (&body, tmp);
3500 gcc_assert (rse.ss == gfc_ss_terminator);
3501 gfc_trans_scalarizing_loops (&loop, &body);
3502 }
3503 else
3504 {
3505 /* Make sure that the temporary declaration survives by merging
3506 all the loop declarations into the current context. */
3507 for (n = 0; n < loop.dimen; n++)
3508 {
3509 gfc_merge_block_scope (&body);
3510 body = loop.code[loop.order[n]];
3511 }
3512 gfc_merge_block_scope (&body);
3513 }
3514
3515 /* Add the post block after the second loop, so that any
3516 freeing of allocated memory is done at the right time. */
3517 gfc_add_block_to_block (&parmse->pre, &loop.pre);
3518
3519 /**********Copy the temporary back again.*********/
3520
3521 gfc_init_se (&lse, NULL);
3522 gfc_init_se (&rse, NULL);
3523
3524 /* Walk the argument expression. */
3525 lss = gfc_walk_expr (expr);
3526 rse.ss = loop.temp_ss;
3527 lse.ss = lss;
3528
3529 /* Initialize the scalarizer. */
3530 gfc_init_loopinfo (&loop2);
3531 gfc_add_ss_to_loop (&loop2, lss);
3532
3533 /* Calculate the bounds of the scalarization. */
3534 gfc_conv_ss_startstride (&loop2);
3535
3536 /* Setup the scalarizing loops. */
3537 gfc_conv_loop_setup (&loop2, &expr->where);
3538
3539 gfc_copy_loopinfo_to_se (&lse, &loop2);
3540 gfc_copy_loopinfo_to_se (&rse, &loop2);
3541
3542 gfc_mark_ss_chain_used (lss, 1);
3543 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3544
3545 /* Declare the variable to hold the temporary offset and start the
3546 scalarized loop body. */
3547 offset = gfc_create_var (gfc_array_index_type, NULL);
3548 gfc_start_scalarized_body (&loop2, &body);
3549
3550 /* Build the offsets for the temporary from the loop variables. The
3551 temporary array has lbounds of zero and strides of one in all
3552 dimensions, so this is very simple. The offset is only computed
3553 outside the innermost loop, so the overall transfer could be
3554 optimized further. */
3555 info = &rse.ss->info->data.array;
3556 dimen = rse.ss->dimen;
3557
3558 tmp_index = gfc_index_zero_node;
3559 for (n = dimen - 1; n > 0; n--)
3560 {
3561 tree tmp_str;
3562 tmp = rse.loop->loopvar[n];
3563 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3564 tmp, rse.loop->from[n]);
3565 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3566 tmp, tmp_index);
3567
3568 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
3569 gfc_array_index_type,
3570 rse.loop->to[n-1], rse.loop->from[n-1]);
3571 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
3572 gfc_array_index_type,
3573 tmp_str, gfc_index_one_node);
3574
3575 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
3576 gfc_array_index_type, tmp, tmp_str);
3577 }
3578
3579 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
3580 gfc_array_index_type,
3581 tmp_index, rse.loop->from[0]);
3582 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
3583
3584 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
3585 gfc_array_index_type,
3586 rse.loop->loopvar[0], offset);
3587
3588 /* Now use the offset for the reference. */
3589 tmp = build_fold_indirect_ref_loc (input_location,
3590 info->data);
3591 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
3592
3593 if (expr->ts.type == BT_CHARACTER)
3594 rse.string_length = expr->ts.u.cl->backend_decl;
3595
3596 gfc_conv_expr (&lse, expr);
3597
3598 gcc_assert (lse.ss == gfc_ss_terminator);
3599
3600 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
3601 gfc_add_expr_to_block (&body, tmp);
3602
3603 /* Generate the copying loops. */
3604 gfc_trans_scalarizing_loops (&loop2, &body);
3605
3606 /* Wrap the whole thing up by adding the second loop to the post-block
3607 and following it by the post-block of the first loop. In this way,
3608 if the temporary needs freeing, it is done after use! */
3609 if (intent != INTENT_IN)
3610 {
3611 gfc_add_block_to_block (&parmse->post, &loop2.pre);
3612 gfc_add_block_to_block (&parmse->post, &loop2.post);
3613 }
3614
3615 gfc_add_block_to_block (&parmse->post, &loop.post);
3616
3617 gfc_cleanup_loop (&loop);
3618 gfc_cleanup_loop (&loop2);
3619
3620 /* Pass the string length to the argument expression. */
3621 if (expr->ts.type == BT_CHARACTER)
3622 parmse->string_length = expr->ts.u.cl->backend_decl;
3623
3624 /* Determine the offset for pointer formal arguments and set the
3625 lbounds to one. */
3626 if (formal_ptr)
3627 {
3628 size = gfc_index_one_node;
3629 offset = gfc_index_zero_node;
3630 for (n = 0; n < dimen; n++)
3631 {
3632 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
3633 gfc_rank_cst[n]);
3634 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3635 gfc_array_index_type, tmp,
3636 gfc_index_one_node);
3637 gfc_conv_descriptor_ubound_set (&parmse->pre,
3638 parmse->expr,
3639 gfc_rank_cst[n],
3640 tmp);
3641 gfc_conv_descriptor_lbound_set (&parmse->pre,
3642 parmse->expr,
3643 gfc_rank_cst[n],
3644 gfc_index_one_node);
3645 size = gfc_evaluate_now (size, &parmse->pre);
3646 offset = fold_build2_loc (input_location, MINUS_EXPR,
3647 gfc_array_index_type,
3648 offset, size);
3649 offset = gfc_evaluate_now (offset, &parmse->pre);
3650 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3651 gfc_array_index_type,
3652 rse.loop->to[n], rse.loop->from[n]);
3653 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3654 gfc_array_index_type,
3655 tmp, gfc_index_one_node);
3656 size = fold_build2_loc (input_location, MULT_EXPR,
3657 gfc_array_index_type, size, tmp);
3658 }
3659
3660 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
3661 offset);
3662 }
3663
3664 /* We want either the address for the data or the address of the descriptor,
3665 depending on the mode of passing array arguments. */
3666 if (g77)
3667 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
3668 else
3669 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
3670
3671 return;
3672 }
3673
3674
3675 /* Generate the code for argument list functions. */
3676
3677 static void
conv_arglist_function(gfc_se * se,gfc_expr * expr,const char * name)3678 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
3679 {
3680 /* Pass by value for g77 %VAL(arg), pass the address
3681 indirectly for %LOC, else by reference. Thus %REF
3682 is a "do-nothing" and %LOC is the same as an F95
3683 pointer. */
3684 if (strncmp (name, "%VAL", 4) == 0)
3685 gfc_conv_expr (se, expr);
3686 else if (strncmp (name, "%LOC", 4) == 0)
3687 {
3688 gfc_conv_expr_reference (se, expr);
3689 se->expr = gfc_build_addr_expr (NULL, se->expr);
3690 }
3691 else if (strncmp (name, "%REF", 4) == 0)
3692 gfc_conv_expr_reference (se, expr);
3693 else
3694 gfc_error ("Unknown argument list function at %L", &expr->where);
3695 }
3696
3697
3698 /* The following routine generates code for the intrinsic
3699 procedures from the ISO_C_BINDING module:
3700 * C_LOC (function)
3701 * C_FUNLOC (function)
3702 * C_F_POINTER (subroutine)
3703 * C_F_PROCPOINTER (subroutine)
3704 * C_ASSOCIATED (function)
3705 One exception which is not handled here is C_F_POINTER with non-scalar
3706 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3707
3708 static int
conv_isocbinding_procedure(gfc_se * se,gfc_symbol * sym,gfc_actual_arglist * arg)3709 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
3710 gfc_actual_arglist * arg)
3711 {
3712 gfc_symbol *fsym;
3713
3714 if (sym->intmod_sym_id == ISOCBINDING_LOC)
3715 {
3716 if (arg->expr->rank == 0)
3717 gfc_conv_expr_reference (se, arg->expr);
3718 else
3719 {
3720 int f;
3721 /* This is really the actual arg because no formal arglist is
3722 created for C_LOC. */
3723 fsym = arg->expr->symtree->n.sym;
3724
3725 /* We should want it to do g77 calling convention. */
3726 f = (fsym != NULL)
3727 && !(fsym->attr.pointer || fsym->attr.allocatable)
3728 && fsym->as->type != AS_ASSUMED_SHAPE;
3729 f = f || !sym->attr.always_explicit;
3730
3731 gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
3732 }
3733
3734 /* TODO -- the following two lines shouldn't be necessary, but if
3735 they're removed, a bug is exposed later in the code path.
3736 This workaround was thus introduced, but will have to be
3737 removed; please see PR 35150 for details about the issue. */
3738 se->expr = convert (pvoid_type_node, se->expr);
3739 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3740
3741 return 1;
3742 }
3743 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
3744 {
3745 arg->expr->ts.type = sym->ts.u.derived->ts.type;
3746 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
3747 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
3748 gfc_conv_expr_reference (se, arg->expr);
3749
3750 return 1;
3751 }
3752 else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
3753 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3754 {
3755 /* Convert c_f_pointer and c_f_procpointer. */
3756 gfc_se cptrse;
3757 gfc_se fptrse;
3758 gfc_se shapese;
3759 gfc_ss *shape_ss;
3760 tree desc, dim, tmp, stride, offset;
3761 stmtblock_t body, block;
3762 gfc_loopinfo loop;
3763
3764 gfc_init_se (&cptrse, NULL);
3765 gfc_conv_expr (&cptrse, arg->expr);
3766 gfc_add_block_to_block (&se->pre, &cptrse.pre);
3767 gfc_add_block_to_block (&se->post, &cptrse.post);
3768
3769 gfc_init_se (&fptrse, NULL);
3770 if (arg->next->expr->rank == 0)
3771 {
3772 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
3773 || gfc_is_proc_ptr_comp (arg->next->expr))
3774 fptrse.want_pointer = 1;
3775
3776 gfc_conv_expr (&fptrse, arg->next->expr);
3777 gfc_add_block_to_block (&se->pre, &fptrse.pre);
3778 gfc_add_block_to_block (&se->post, &fptrse.post);
3779 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
3780 && arg->next->expr->symtree->n.sym->attr.dummy)
3781 fptrse.expr = build_fold_indirect_ref_loc (input_location,
3782 fptrse.expr);
3783 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
3784 TREE_TYPE (fptrse.expr),
3785 fptrse.expr,
3786 fold_convert (TREE_TYPE (fptrse.expr),
3787 cptrse.expr));
3788 return 1;
3789 }
3790
3791 gfc_start_block (&block);
3792
3793 /* Get the descriptor of the Fortran pointer. */
3794 fptrse.descriptor_only = 1;
3795 gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
3796 gfc_add_block_to_block (&block, &fptrse.pre);
3797 desc = fptrse.expr;
3798
3799 /* Set data value, dtype, and offset. */
3800 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
3801 gfc_conv_descriptor_data_set (&block, desc,
3802 fold_convert (tmp, cptrse.expr));
3803 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
3804 gfc_get_dtype (TREE_TYPE (desc)));
3805
3806 /* Start scalarization of the bounds, using the shape argument. */
3807
3808 shape_ss = gfc_walk_expr (arg->next->next->expr);
3809 gcc_assert (shape_ss != gfc_ss_terminator);
3810 gfc_init_se (&shapese, NULL);
3811
3812 gfc_init_loopinfo (&loop);
3813 gfc_add_ss_to_loop (&loop, shape_ss);
3814 gfc_conv_ss_startstride (&loop);
3815 gfc_conv_loop_setup (&loop, &arg->next->expr->where);
3816 gfc_mark_ss_chain_used (shape_ss, 1);
3817
3818 gfc_copy_loopinfo_to_se (&shapese, &loop);
3819 shapese.ss = shape_ss;
3820
3821 stride = gfc_create_var (gfc_array_index_type, "stride");
3822 offset = gfc_create_var (gfc_array_index_type, "offset");
3823 gfc_add_modify (&block, stride, gfc_index_one_node);
3824 gfc_add_modify (&block, offset, gfc_index_zero_node);
3825
3826 /* Loop body. */
3827 gfc_start_scalarized_body (&loop, &body);
3828
3829 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3830 loop.loopvar[0], loop.from[0]);
3831
3832 /* Set bounds and stride. */
3833 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
3834 gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
3835
3836 gfc_conv_expr (&shapese, arg->next->next->expr);
3837 gfc_add_block_to_block (&body, &shapese.pre);
3838 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
3839 gfc_add_block_to_block (&body, &shapese.post);
3840
3841 /* Calculate offset. */
3842 gfc_add_modify (&body, offset,
3843 fold_build2_loc (input_location, PLUS_EXPR,
3844 gfc_array_index_type, offset, stride));
3845 /* Update stride. */
3846 gfc_add_modify (&body, stride,
3847 fold_build2_loc (input_location, MULT_EXPR,
3848 gfc_array_index_type, stride,
3849 fold_convert (gfc_array_index_type,
3850 shapese.expr)));
3851 /* Finish scalarization loop. */
3852 gfc_trans_scalarizing_loops (&loop, &body);
3853 gfc_add_block_to_block (&block, &loop.pre);
3854 gfc_add_block_to_block (&block, &loop.post);
3855 gfc_add_block_to_block (&block, &fptrse.post);
3856 gfc_cleanup_loop (&loop);
3857
3858 gfc_add_modify (&block, offset,
3859 fold_build1_loc (input_location, NEGATE_EXPR,
3860 gfc_array_index_type, offset));
3861 gfc_conv_descriptor_offset_set (&block, desc, offset);
3862
3863 se->expr = gfc_finish_block (&block);
3864 return 1;
3865 }
3866 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3867 {
3868 gfc_se arg1se;
3869 gfc_se arg2se;
3870
3871 /* Build the addr_expr for the first argument. The argument is
3872 already an *address* so we don't need to set want_pointer in
3873 the gfc_se. */
3874 gfc_init_se (&arg1se, NULL);
3875 gfc_conv_expr (&arg1se, arg->expr);
3876 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3877 gfc_add_block_to_block (&se->post, &arg1se.post);
3878
3879 /* See if we were given two arguments. */
3880 if (arg->next == NULL)
3881 /* Only given one arg so generate a null and do a
3882 not-equal comparison against the first arg. */
3883 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3884 arg1se.expr,
3885 fold_convert (TREE_TYPE (arg1se.expr),
3886 null_pointer_node));
3887 else
3888 {
3889 tree eq_expr;
3890 tree not_null_expr;
3891
3892 /* Given two arguments so build the arg2se from second arg. */
3893 gfc_init_se (&arg2se, NULL);
3894 gfc_conv_expr (&arg2se, arg->next->expr);
3895 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3896 gfc_add_block_to_block (&se->post, &arg2se.post);
3897
3898 /* Generate test to compare that the two args are equal. */
3899 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3900 arg1se.expr, arg2se.expr);
3901 /* Generate test to ensure that the first arg is not null. */
3902 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
3903 boolean_type_node,
3904 arg1se.expr, null_pointer_node);
3905
3906 /* Finally, the generated test must check that both arg1 is not
3907 NULL and that it is equal to the second arg. */
3908 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3909 boolean_type_node,
3910 not_null_expr, eq_expr);
3911 }
3912
3913 return 1;
3914 }
3915
3916 /* Nothing was done. */
3917 return 0;
3918 }
3919
3920
3921 /* Generate code for a procedure call. Note can return se->post != NULL.
3922 If se->direct_byref is set then se->expr contains the return parameter.
3923 Return nonzero, if the call has alternate specifiers.
3924 'expr' is only needed for procedure pointer components. */
3925
3926 int
gfc_conv_procedure_call(gfc_se * se,gfc_symbol * sym,gfc_actual_arglist * args,gfc_expr * expr,vec<tree,va_gc> * append_args)3927 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
3928 gfc_actual_arglist * args, gfc_expr * expr,
3929 vec<tree, va_gc> *append_args)
3930 {
3931 gfc_interface_mapping mapping;
3932 vec<tree, va_gc> *arglist;
3933 vec<tree, va_gc> *retargs;
3934 tree tmp;
3935 tree fntype;
3936 gfc_se parmse;
3937 gfc_array_info *info;
3938 int byref;
3939 int parm_kind;
3940 tree type;
3941 tree var;
3942 tree len;
3943 tree base_object;
3944 vec<tree, va_gc> *stringargs;
3945 tree result = NULL;
3946 gfc_formal_arglist *formal;
3947 gfc_actual_arglist *arg;
3948 int has_alternate_specifier = 0;
3949 bool need_interface_mapping;
3950 bool callee_alloc;
3951 gfc_typespec ts;
3952 gfc_charlen cl;
3953 gfc_expr *e;
3954 gfc_symbol *fsym;
3955 stmtblock_t post;
3956 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
3957 gfc_component *comp = NULL;
3958 int arglen;
3959
3960 arglist = NULL;
3961 retargs = NULL;
3962 stringargs = NULL;
3963 var = NULL_TREE;
3964 len = NULL_TREE;
3965 gfc_clear_ts (&ts);
3966
3967 if (sym->from_intmod == INTMOD_ISO_C_BINDING
3968 && conv_isocbinding_procedure (se, sym, args))
3969 return 0;
3970
3971 comp = gfc_get_proc_ptr_comp (expr);
3972
3973 if (se->ss != NULL)
3974 {
3975 if (!sym->attr.elemental && !(comp && comp->attr.elemental))
3976 {
3977 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
3978 if (se->ss->info->useflags)
3979 {
3980 gcc_assert ((!comp && gfc_return_by_reference (sym)
3981 && sym->result->attr.dimension)
3982 || (comp && comp->attr.dimension));
3983 gcc_assert (se->loop != NULL);
3984
3985 /* Access the previously obtained result. */
3986 gfc_conv_tmp_array_ref (se);
3987 return 0;
3988 }
3989 }
3990 info = &se->ss->info->data.array;
3991 }
3992 else
3993 info = NULL;
3994
3995 gfc_init_block (&post);
3996 gfc_init_interface_mapping (&mapping);
3997 if (!comp)
3998 {
3999 formal = gfc_sym_get_dummy_args (sym);
4000 need_interface_mapping = sym->attr.dimension ||
4001 (sym->ts.type == BT_CHARACTER
4002 && sym->ts.u.cl->length
4003 && sym->ts.u.cl->length->expr_type
4004 != EXPR_CONSTANT);
4005 }
4006 else
4007 {
4008 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4009 need_interface_mapping = comp->attr.dimension ||
4010 (comp->ts.type == BT_CHARACTER
4011 && comp->ts.u.cl->length
4012 && comp->ts.u.cl->length->expr_type
4013 != EXPR_CONSTANT);
4014 }
4015
4016 base_object = NULL_TREE;
4017
4018 /* Evaluate the arguments. */
4019 for (arg = args; arg != NULL;
4020 arg = arg->next, formal = formal ? formal->next : NULL)
4021 {
4022 e = arg->expr;
4023 fsym = formal ? formal->sym : NULL;
4024 parm_kind = MISSING;
4025
4026 /* Class array expressions are sometimes coming completely unadorned
4027 with either arrayspec or _data component. Correct that here.
4028 OOP-TODO: Move this to the frontend. */
4029 if (e && e->expr_type == EXPR_VARIABLE
4030 && !e->ref
4031 && e->ts.type == BT_CLASS
4032 && (CLASS_DATA (e)->attr.codimension
4033 || CLASS_DATA (e)->attr.dimension))
4034 {
4035 gfc_typespec temp_ts = e->ts;
4036 gfc_add_class_array_ref (e);
4037 e->ts = temp_ts;
4038 }
4039
4040 if (e == NULL)
4041 {
4042 if (se->ignore_optional)
4043 {
4044 /* Some intrinsics have already been resolved to the correct
4045 parameters. */
4046 continue;
4047 }
4048 else if (arg->label)
4049 {
4050 has_alternate_specifier = 1;
4051 continue;
4052 }
4053 else
4054 {
4055 /* Pass a NULL pointer for an absent arg. */
4056 gfc_init_se (&parmse, NULL);
4057 parmse.expr = null_pointer_node;
4058 if (arg->missing_arg_type == BT_CHARACTER)
4059 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4060 }
4061 }
4062 else if (arg->expr->expr_type == EXPR_NULL
4063 && fsym && !fsym->attr.pointer
4064 && (fsym->ts.type != BT_CLASS
4065 || !CLASS_DATA (fsym)->attr.class_pointer))
4066 {
4067 /* Pass a NULL pointer to denote an absent arg. */
4068 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
4069 && (fsym->ts.type != BT_CLASS
4070 || !CLASS_DATA (fsym)->attr.allocatable));
4071 gfc_init_se (&parmse, NULL);
4072 parmse.expr = null_pointer_node;
4073 if (arg->missing_arg_type == BT_CHARACTER)
4074 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4075 }
4076 else if (fsym && fsym->ts.type == BT_CLASS
4077 && e->ts.type == BT_DERIVED)
4078 {
4079 /* The derived type needs to be converted to a temporary
4080 CLASS object. */
4081 gfc_init_se (&parmse, se);
4082 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
4083 fsym->attr.optional
4084 && e->expr_type == EXPR_VARIABLE
4085 && e->symtree->n.sym->attr.optional,
4086 CLASS_DATA (fsym)->attr.class_pointer
4087 || CLASS_DATA (fsym)->attr.allocatable);
4088 }
4089 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
4090 {
4091 /* The intrinsic type needs to be converted to a temporary
4092 CLASS object for the unlimited polymorphic formal. */
4093 gfc_init_se (&parmse, se);
4094 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
4095 }
4096 else if (se->ss && se->ss->info->useflags)
4097 {
4098 gfc_ss *ss;
4099
4100 ss = se->ss;
4101
4102 /* An elemental function inside a scalarized loop. */
4103 gfc_init_se (&parmse, se);
4104 parm_kind = ELEMENTAL;
4105
4106 if (ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
4107 && ss->info->data.array.ref == NULL)
4108 {
4109 gfc_conv_tmp_array_ref (&parmse);
4110 if (e->ts.type == BT_CHARACTER)
4111 gfc_conv_string_parameter (&parmse);
4112 else
4113 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
4114 }
4115 else
4116 {
4117 gfc_conv_expr_reference (&parmse, e);
4118 if (e->ts.type == BT_CHARACTER && !e->rank
4119 && e->expr_type == EXPR_FUNCTION)
4120 parmse.expr = build_fold_indirect_ref_loc (input_location,
4121 parmse.expr);
4122 }
4123
4124 if (fsym && fsym->ts.type == BT_DERIVED
4125 && gfc_is_class_container_ref (e))
4126 {
4127 parmse.expr = gfc_class_data_get (parmse.expr);
4128
4129 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
4130 && e->symtree->n.sym->attr.optional)
4131 {
4132 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
4133 parmse.expr = build3_loc (input_location, COND_EXPR,
4134 TREE_TYPE (parmse.expr),
4135 cond, parmse.expr,
4136 fold_convert (TREE_TYPE (parmse.expr),
4137 null_pointer_node));
4138 }
4139 }
4140
4141 /* If we are passing an absent array as optional dummy to an
4142 elemental procedure, make sure that we pass NULL when the data
4143 pointer is NULL. We need this extra conditional because of
4144 scalarization which passes arrays elements to the procedure,
4145 ignoring the fact that the array can be absent/unallocated/... */
4146 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
4147 {
4148 tree descriptor_data;
4149
4150 descriptor_data = ss->info->data.array.data;
4151 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4152 descriptor_data,
4153 fold_convert (TREE_TYPE (descriptor_data),
4154 null_pointer_node));
4155 parmse.expr
4156 = fold_build3_loc (input_location, COND_EXPR,
4157 TREE_TYPE (parmse.expr),
4158 gfc_unlikely (tmp),
4159 fold_convert (TREE_TYPE (parmse.expr),
4160 null_pointer_node),
4161 parmse.expr);
4162 }
4163
4164 /* The scalarizer does not repackage the reference to a class
4165 array - instead it returns a pointer to the data element. */
4166 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
4167 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
4168 fsym->attr.intent != INTENT_IN
4169 && (CLASS_DATA (fsym)->attr.class_pointer
4170 || CLASS_DATA (fsym)->attr.allocatable),
4171 fsym->attr.optional
4172 && e->expr_type == EXPR_VARIABLE
4173 && e->symtree->n.sym->attr.optional,
4174 CLASS_DATA (fsym)->attr.class_pointer
4175 || CLASS_DATA (fsym)->attr.allocatable);
4176 }
4177 else
4178 {
4179 bool scalar;
4180 gfc_ss *argss;
4181
4182 gfc_init_se (&parmse, NULL);
4183
4184 /* Check whether the expression is a scalar or not; we cannot use
4185 e->rank as it can be nonzero for functions arguments. */
4186 argss = gfc_walk_expr (e);
4187 scalar = argss == gfc_ss_terminator;
4188 if (!scalar)
4189 gfc_free_ss_chain (argss);
4190
4191 /* Special handling for passing scalar polymorphic coarrays;
4192 otherwise one passes "class->_data.data" instead of "&class". */
4193 if (e->rank == 0 && e->ts.type == BT_CLASS
4194 && fsym && fsym->ts.type == BT_CLASS
4195 && CLASS_DATA (fsym)->attr.codimension
4196 && !CLASS_DATA (fsym)->attr.dimension)
4197 {
4198 gfc_add_class_array_ref (e);
4199 parmse.want_coarray = 1;
4200 scalar = false;
4201 }
4202
4203 /* A scalar or transformational function. */
4204 if (scalar)
4205 {
4206 if (e->expr_type == EXPR_VARIABLE
4207 && e->symtree->n.sym->attr.cray_pointee
4208 && fsym && fsym->attr.flavor == FL_PROCEDURE)
4209 {
4210 /* The Cray pointer needs to be converted to a pointer to
4211 a type given by the expression. */
4212 gfc_conv_expr (&parmse, e);
4213 type = build_pointer_type (TREE_TYPE (parmse.expr));
4214 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
4215 parmse.expr = convert (type, tmp);
4216 }
4217 else if (fsym && fsym->attr.value)
4218 {
4219 if (fsym->ts.type == BT_CHARACTER
4220 && fsym->ts.is_c_interop
4221 && fsym->ns->proc_name != NULL
4222 && fsym->ns->proc_name->attr.is_bind_c)
4223 {
4224 parmse.expr = NULL;
4225 gfc_conv_scalar_char_value (fsym, &parmse, &e);
4226 if (parmse.expr == NULL)
4227 gfc_conv_expr (&parmse, e);
4228 }
4229 else
4230 gfc_conv_expr (&parmse, e);
4231 }
4232 else if (arg->name && arg->name[0] == '%')
4233 /* Argument list functions %VAL, %LOC and %REF are signalled
4234 through arg->name. */
4235 conv_arglist_function (&parmse, arg->expr, arg->name);
4236 else if ((e->expr_type == EXPR_FUNCTION)
4237 && ((e->value.function.esym
4238 && e->value.function.esym->result->attr.pointer)
4239 || (!e->value.function.esym
4240 && e->symtree->n.sym->attr.pointer))
4241 && fsym && fsym->attr.target)
4242 {
4243 gfc_conv_expr (&parmse, e);
4244 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
4245 }
4246 else if (e->expr_type == EXPR_FUNCTION
4247 && e->symtree->n.sym->result
4248 && e->symtree->n.sym->result != e->symtree->n.sym
4249 && e->symtree->n.sym->result->attr.proc_pointer)
4250 {
4251 /* Functions returning procedure pointers. */
4252 gfc_conv_expr (&parmse, e);
4253 if (fsym && fsym->attr.proc_pointer)
4254 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
4255 }
4256 else
4257 {
4258 if (e->ts.type == BT_CLASS && fsym
4259 && fsym->ts.type == BT_CLASS
4260 && (!CLASS_DATA (fsym)->as
4261 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
4262 && CLASS_DATA (e)->attr.codimension)
4263 {
4264 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
4265 gcc_assert (!CLASS_DATA (fsym)->as);
4266 gfc_add_class_array_ref (e);
4267 parmse.want_coarray = 1;
4268 gfc_conv_expr_reference (&parmse, e);
4269 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
4270 fsym->attr.optional
4271 && e->expr_type == EXPR_VARIABLE);
4272 }
4273 else
4274 gfc_conv_expr_reference (&parmse, e);
4275
4276 /* Catch base objects that are not variables. */
4277 if (e->ts.type == BT_CLASS
4278 && e->expr_type != EXPR_VARIABLE
4279 && expr && e == expr->base_expr)
4280 base_object = build_fold_indirect_ref_loc (input_location,
4281 parmse.expr);
4282
4283 /* A class array element needs converting back to be a
4284 class object, if the formal argument is a class object. */
4285 if (fsym && fsym->ts.type == BT_CLASS
4286 && e->ts.type == BT_CLASS
4287 && ((CLASS_DATA (fsym)->as
4288 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
4289 || CLASS_DATA (e)->attr.dimension))
4290 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
4291 fsym->attr.intent != INTENT_IN
4292 && (CLASS_DATA (fsym)->attr.class_pointer
4293 || CLASS_DATA (fsym)->attr.allocatable),
4294 fsym->attr.optional
4295 && e->expr_type == EXPR_VARIABLE
4296 && e->symtree->n.sym->attr.optional,
4297 CLASS_DATA (fsym)->attr.class_pointer
4298 || CLASS_DATA (fsym)->attr.allocatable);
4299
4300 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4301 allocated on entry, it must be deallocated. */
4302 if (fsym && fsym->attr.intent == INTENT_OUT
4303 && (fsym->attr.allocatable
4304 || (fsym->ts.type == BT_CLASS
4305 && CLASS_DATA (fsym)->attr.allocatable)))
4306 {
4307 stmtblock_t block;
4308 tree ptr;
4309
4310 gfc_init_block (&block);
4311 ptr = parmse.expr;
4312 if (e->ts.type == BT_CLASS)
4313 ptr = gfc_class_data_get (ptr);
4314
4315 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
4316 NULL_TREE, NULL_TREE,
4317 NULL_TREE, true, NULL,
4318 false);
4319 gfc_add_expr_to_block (&block, tmp);
4320 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4321 void_type_node, ptr,
4322 null_pointer_node);
4323 gfc_add_expr_to_block (&block, tmp);
4324
4325 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
4326 {
4327 gfc_add_modify (&block, ptr,
4328 fold_convert (TREE_TYPE (ptr),
4329 null_pointer_node));
4330 gfc_add_expr_to_block (&block, tmp);
4331 }
4332 else if (fsym->ts.type == BT_CLASS)
4333 {
4334 gfc_symbol *vtab;
4335 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
4336 tmp = gfc_get_symbol_decl (vtab);
4337 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4338 ptr = gfc_class_vptr_get (parmse.expr);
4339 gfc_add_modify (&block, ptr,
4340 fold_convert (TREE_TYPE (ptr), tmp));
4341 gfc_add_expr_to_block (&block, tmp);
4342 }
4343
4344 if (fsym->attr.optional
4345 && e->expr_type == EXPR_VARIABLE
4346 && e->symtree->n.sym->attr.optional)
4347 {
4348 tmp = fold_build3_loc (input_location, COND_EXPR,
4349 void_type_node,
4350 gfc_conv_expr_present (e->symtree->n.sym),
4351 gfc_finish_block (&block),
4352 build_empty_stmt (input_location));
4353 }
4354 else
4355 tmp = gfc_finish_block (&block);
4356
4357 gfc_add_expr_to_block (&se->pre, tmp);
4358 }
4359
4360 if (fsym && (fsym->ts.type == BT_DERIVED
4361 || fsym->ts.type == BT_ASSUMED)
4362 && e->ts.type == BT_CLASS
4363 && !CLASS_DATA (e)->attr.dimension
4364 && !CLASS_DATA (e)->attr.codimension)
4365 parmse.expr = gfc_class_data_get (parmse.expr);
4366
4367 /* Wrap scalar variable in a descriptor. We need to convert
4368 the address of a pointer back to the pointer itself before,
4369 we can assign it to the data field. */
4370
4371 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
4372 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
4373 {
4374 tmp = parmse.expr;
4375 if (TREE_CODE (tmp) == ADDR_EXPR
4376 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
4377 tmp = TREE_OPERAND (tmp, 0);
4378 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
4379 fsym->attr);
4380 parmse.expr = gfc_build_addr_expr (NULL_TREE,
4381 parmse.expr);
4382 }
4383 else if (fsym && e->expr_type != EXPR_NULL
4384 && ((fsym->attr.pointer
4385 && fsym->attr.flavor != FL_PROCEDURE)
4386 || (fsym->attr.proc_pointer
4387 && !(e->expr_type == EXPR_VARIABLE
4388 && e->symtree->n.sym->attr.dummy))
4389 || (fsym->attr.proc_pointer
4390 && e->expr_type == EXPR_VARIABLE
4391 && gfc_is_proc_ptr_comp (e))
4392 || (fsym->attr.allocatable
4393 && fsym->attr.flavor != FL_PROCEDURE)))
4394 {
4395 /* Scalar pointer dummy args require an extra level of
4396 indirection. The null pointer already contains
4397 this level of indirection. */
4398 parm_kind = SCALAR_POINTER;
4399 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
4400 }
4401 }
4402 }
4403 else if (e->ts.type == BT_CLASS
4404 && fsym && fsym->ts.type == BT_CLASS
4405 && (CLASS_DATA (fsym)->attr.dimension
4406 || CLASS_DATA (fsym)->attr.codimension))
4407 {
4408 /* Pass a class array. */
4409 gfc_conv_expr_descriptor (&parmse, e);
4410 /* The conversion does not repackage the reference to a class
4411 array - _data descriptor. */
4412 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
4413 fsym->attr.intent != INTENT_IN
4414 && (CLASS_DATA (fsym)->attr.class_pointer
4415 || CLASS_DATA (fsym)->attr.allocatable),
4416 fsym->attr.optional
4417 && e->expr_type == EXPR_VARIABLE
4418 && e->symtree->n.sym->attr.optional,
4419 CLASS_DATA (fsym)->attr.class_pointer
4420 || CLASS_DATA (fsym)->attr.allocatable);
4421 }
4422 else
4423 {
4424 /* If the procedure requires an explicit interface, the actual
4425 argument is passed according to the corresponding formal
4426 argument. If the corresponding formal argument is a POINTER,
4427 ALLOCATABLE or assumed shape, we do not use g77's calling
4428 convention, and pass the address of the array descriptor
4429 instead. Otherwise we use g77's calling convention. */
4430 bool f;
4431 f = (fsym != NULL)
4432 && !(fsym->attr.pointer || fsym->attr.allocatable)
4433 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
4434 && fsym->as->type != AS_ASSUMED_RANK;
4435 if (comp)
4436 f = f || !comp->attr.always_explicit;
4437 else
4438 f = f || !sym->attr.always_explicit;
4439
4440 /* If the argument is a function call that may not create
4441 a temporary for the result, we have to check that we
4442 can do it, i.e. that there is no alias between this
4443 argument and another one. */
4444 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
4445 {
4446 gfc_expr *iarg;
4447 sym_intent intent;
4448
4449 if (fsym != NULL)
4450 intent = fsym->attr.intent;
4451 else
4452 intent = INTENT_UNKNOWN;
4453
4454 if (gfc_check_fncall_dependency (e, intent, sym, args,
4455 NOT_ELEMENTAL))
4456 parmse.force_tmp = 1;
4457
4458 iarg = e->value.function.actual->expr;
4459
4460 /* Temporary needed if aliasing due to host association. */
4461 if (sym->attr.contained
4462 && !sym->attr.pure
4463 && !sym->attr.implicit_pure
4464 && !sym->attr.use_assoc
4465 && iarg->expr_type == EXPR_VARIABLE
4466 && sym->ns == iarg->symtree->n.sym->ns)
4467 parmse.force_tmp = 1;
4468
4469 /* Ditto within module. */
4470 if (sym->attr.use_assoc
4471 && !sym->attr.pure
4472 && !sym->attr.implicit_pure
4473 && iarg->expr_type == EXPR_VARIABLE
4474 && sym->module == iarg->symtree->n.sym->module)
4475 parmse.force_tmp = 1;
4476 }
4477
4478 if (e->expr_type == EXPR_VARIABLE
4479 && is_subref_array (e))
4480 /* The actual argument is a component reference to an
4481 array of derived types. In this case, the argument
4482 is converted to a temporary, which is passed and then
4483 written back after the procedure call. */
4484 gfc_conv_subref_array_arg (&parmse, e, f,
4485 fsym ? fsym->attr.intent : INTENT_INOUT,
4486 fsym && fsym->attr.pointer);
4487 else if (gfc_is_class_array_ref (e, NULL)
4488 && fsym && fsym->ts.type == BT_DERIVED)
4489 /* The actual argument is a component reference to an
4490 array of derived types. In this case, the argument
4491 is converted to a temporary, which is passed and then
4492 written back after the procedure call.
4493 OOP-TODO: Insert code so that if the dynamic type is
4494 the same as the declared type, copy-in/copy-out does
4495 not occur. */
4496 gfc_conv_subref_array_arg (&parmse, e, f,
4497 fsym ? fsym->attr.intent : INTENT_INOUT,
4498 fsym && fsym->attr.pointer);
4499 else
4500 gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
4501
4502 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4503 allocated on entry, it must be deallocated. */
4504 if (fsym && fsym->attr.allocatable
4505 && fsym->attr.intent == INTENT_OUT)
4506 {
4507 tmp = build_fold_indirect_ref_loc (input_location,
4508 parmse.expr);
4509 tmp = gfc_trans_dealloc_allocated (tmp, false);
4510 if (fsym->attr.optional
4511 && e->expr_type == EXPR_VARIABLE
4512 && e->symtree->n.sym->attr.optional)
4513 tmp = fold_build3_loc (input_location, COND_EXPR,
4514 void_type_node,
4515 gfc_conv_expr_present (e->symtree->n.sym),
4516 tmp, build_empty_stmt (input_location));
4517 gfc_add_expr_to_block (&se->pre, tmp);
4518 }
4519 }
4520 }
4521
4522 /* The case with fsym->attr.optional is that of a user subroutine
4523 with an interface indicating an optional argument. When we call
4524 an intrinsic subroutine, however, fsym is NULL, but we might still
4525 have an optional argument, so we proceed to the substitution
4526 just in case. */
4527 if (e && (fsym == NULL || fsym->attr.optional))
4528 {
4529 /* If an optional argument is itself an optional dummy argument,
4530 check its presence and substitute a null if absent. This is
4531 only needed when passing an array to an elemental procedure
4532 as then array elements are accessed - or no NULL pointer is
4533 allowed and a "1" or "0" should be passed if not present.
4534 When passing a non-array-descriptor full array to a
4535 non-array-descriptor dummy, no check is needed. For
4536 array-descriptor actual to array-descriptor dummy, see
4537 PR 41911 for why a check has to be inserted.
4538 fsym == NULL is checked as intrinsics required the descriptor
4539 but do not always set fsym. */
4540 if (e->expr_type == EXPR_VARIABLE
4541 && e->symtree->n.sym->attr.optional
4542 && ((e->rank != 0 && sym->attr.elemental)
4543 || e->representation.length || e->ts.type == BT_CHARACTER
4544 || (e->rank != 0
4545 && (fsym == NULL
4546 || (fsym-> as
4547 && (fsym->as->type == AS_ASSUMED_SHAPE
4548 || fsym->as->type == AS_ASSUMED_RANK
4549 || fsym->as->type == AS_DEFERRED))))))
4550 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
4551 e->representation.length);
4552 }
4553
4554 if (fsym && e)
4555 {
4556 /* Obtain the character length of an assumed character length
4557 length procedure from the typespec. */
4558 if (fsym->ts.type == BT_CHARACTER
4559 && parmse.string_length == NULL_TREE
4560 && e->ts.type == BT_PROCEDURE
4561 && e->symtree->n.sym->ts.type == BT_CHARACTER
4562 && e->symtree->n.sym->ts.u.cl->length != NULL
4563 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4564 {
4565 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
4566 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
4567 }
4568 }
4569
4570 if (fsym && need_interface_mapping && e)
4571 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
4572
4573 gfc_add_block_to_block (&se->pre, &parmse.pre);
4574 gfc_add_block_to_block (&post, &parmse.post);
4575
4576 /* Allocated allocatable components of derived types must be
4577 deallocated for non-variable scalars. Non-variable arrays are
4578 dealt with in trans-array.c(gfc_conv_array_parameter). */
4579 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
4580 && e->ts.u.derived->attr.alloc_comp
4581 && !(e->symtree && e->symtree->n.sym->attr.pointer)
4582 && (e->expr_type != EXPR_VARIABLE && !e->rank))
4583 {
4584 int parm_rank;
4585 tmp = build_fold_indirect_ref_loc (input_location,
4586 parmse.expr);
4587 parm_rank = e->rank;
4588 switch (parm_kind)
4589 {
4590 case (ELEMENTAL):
4591 case (SCALAR):
4592 parm_rank = 0;
4593 break;
4594
4595 case (SCALAR_POINTER):
4596 tmp = build_fold_indirect_ref_loc (input_location,
4597 tmp);
4598 break;
4599 }
4600
4601 if (e->expr_type == EXPR_OP
4602 && e->value.op.op == INTRINSIC_PARENTHESES
4603 && e->value.op.op1->expr_type == EXPR_VARIABLE)
4604 {
4605 tree local_tmp;
4606 local_tmp = gfc_evaluate_now (tmp, &se->pre);
4607 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
4608 gfc_add_expr_to_block (&se->post, local_tmp);
4609 }
4610
4611 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
4612 {
4613 /* The derived type is passed to gfc_deallocate_alloc_comp.
4614 Therefore, class actuals can handled correctly but derived
4615 types passed to class formals need the _data component. */
4616 tmp = gfc_class_data_get (tmp);
4617 if (!CLASS_DATA (fsym)->attr.dimension)
4618 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4619 }
4620
4621 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
4622
4623 gfc_add_expr_to_block (&se->post, tmp);
4624 }
4625
4626 /* Add argument checking of passing an unallocated/NULL actual to
4627 a nonallocatable/nonpointer dummy. */
4628
4629 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
4630 {
4631 symbol_attribute attr;
4632 char *msg;
4633 tree cond;
4634
4635 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
4636 attr = gfc_expr_attr (e);
4637 else
4638 goto end_pointer_check;
4639
4640 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4641 allocatable to an optional dummy, cf. 12.5.2.12. */
4642 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
4643 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
4644 goto end_pointer_check;
4645
4646 if (attr.optional)
4647 {
4648 /* If the actual argument is an optional pointer/allocatable and
4649 the formal argument takes an nonpointer optional value,
4650 it is invalid to pass a non-present argument on, even
4651 though there is no technical reason for this in gfortran.
4652 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4653 tree present, null_ptr, type;
4654
4655 if (attr.allocatable
4656 && (fsym == NULL || !fsym->attr.allocatable))
4657 asprintf (&msg, "Allocatable actual argument '%s' is not "
4658 "allocated or not present", e->symtree->n.sym->name);
4659 else if (attr.pointer
4660 && (fsym == NULL || !fsym->attr.pointer))
4661 asprintf (&msg, "Pointer actual argument '%s' is not "
4662 "associated or not present",
4663 e->symtree->n.sym->name);
4664 else if (attr.proc_pointer
4665 && (fsym == NULL || !fsym->attr.proc_pointer))
4666 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
4667 "associated or not present",
4668 e->symtree->n.sym->name);
4669 else
4670 goto end_pointer_check;
4671
4672 present = gfc_conv_expr_present (e->symtree->n.sym);
4673 type = TREE_TYPE (present);
4674 present = fold_build2_loc (input_location, EQ_EXPR,
4675 boolean_type_node, present,
4676 fold_convert (type,
4677 null_pointer_node));
4678 type = TREE_TYPE (parmse.expr);
4679 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
4680 boolean_type_node, parmse.expr,
4681 fold_convert (type,
4682 null_pointer_node));
4683 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4684 boolean_type_node, present, null_ptr);
4685 }
4686 else
4687 {
4688 if (attr.allocatable
4689 && (fsym == NULL || !fsym->attr.allocatable))
4690 asprintf (&msg, "Allocatable actual argument '%s' is not "
4691 "allocated", e->symtree->n.sym->name);
4692 else if (attr.pointer
4693 && (fsym == NULL || !fsym->attr.pointer))
4694 asprintf (&msg, "Pointer actual argument '%s' is not "
4695 "associated", e->symtree->n.sym->name);
4696 else if (attr.proc_pointer
4697 && (fsym == NULL || !fsym->attr.proc_pointer))
4698 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
4699 "associated", e->symtree->n.sym->name);
4700 else
4701 goto end_pointer_check;
4702
4703 tmp = parmse.expr;
4704
4705 /* If the argument is passed by value, we need to strip the
4706 INDIRECT_REF. */
4707 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
4708 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4709
4710 cond = fold_build2_loc (input_location, EQ_EXPR,
4711 boolean_type_node, tmp,
4712 fold_convert (TREE_TYPE (tmp),
4713 null_pointer_node));
4714 }
4715
4716 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
4717 msg);
4718 free (msg);
4719 }
4720 end_pointer_check:
4721
4722 /* Deferred length dummies pass the character length by reference
4723 so that the value can be returned. */
4724 if (parmse.string_length && fsym && fsym->ts.deferred)
4725 {
4726 tmp = parmse.string_length;
4727 if (TREE_CODE (tmp) != VAR_DECL)
4728 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
4729 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
4730 }
4731
4732 /* Character strings are passed as two parameters, a length and a
4733 pointer - except for Bind(c) which only passes the pointer.
4734 An unlimited polymorphic formal argument likewise does not
4735 need the length. */
4736 if (parmse.string_length != NULL_TREE
4737 && !sym->attr.is_bind_c
4738 && !(fsym && UNLIMITED_POLY (fsym)))
4739 vec_safe_push (stringargs, parmse.string_length);
4740
4741 /* When calling __copy for character expressions to unlimited
4742 polymorphic entities, the dst argument needs a string length. */
4743 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
4744 && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
4745 && arg->next && arg->next->expr
4746 && arg->next->expr->ts.type == BT_DERIVED
4747 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
4748 vec_safe_push (stringargs, parmse.string_length);
4749
4750 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4751 pass the token and the offset as additional arguments. */
4752 if (fsym && fsym->attr.codimension
4753 && gfc_option.coarray == GFC_FCOARRAY_LIB
4754 && !fsym->attr.allocatable
4755 && e == NULL)
4756 {
4757 /* Token and offset. */
4758 vec_safe_push (stringargs, null_pointer_node);
4759 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
4760 gcc_assert (fsym->attr.optional);
4761 }
4762 else if (fsym && fsym->attr.codimension
4763 && !fsym->attr.allocatable
4764 && gfc_option.coarray == GFC_FCOARRAY_LIB)
4765 {
4766 tree caf_decl, caf_type;
4767 tree offset, tmp2;
4768
4769 caf_decl = get_tree_for_caf_expr (e);
4770 caf_type = TREE_TYPE (caf_decl);
4771
4772 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
4773 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
4774 tmp = gfc_conv_descriptor_token (caf_decl);
4775 else if (DECL_LANG_SPECIFIC (caf_decl)
4776 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
4777 tmp = GFC_DECL_TOKEN (caf_decl);
4778 else
4779 {
4780 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
4781 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
4782 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
4783 }
4784
4785 vec_safe_push (stringargs, tmp);
4786
4787 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
4788 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
4789 offset = build_int_cst (gfc_array_index_type, 0);
4790 else if (DECL_LANG_SPECIFIC (caf_decl)
4791 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
4792 offset = GFC_DECL_CAF_OFFSET (caf_decl);
4793 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
4794 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
4795 else
4796 offset = build_int_cst (gfc_array_index_type, 0);
4797
4798 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
4799 tmp = gfc_conv_descriptor_data_get (caf_decl);
4800 else
4801 {
4802 gcc_assert (POINTER_TYPE_P (caf_type));
4803 tmp = caf_decl;
4804 }
4805
4806 if (fsym->as->type == AS_ASSUMED_SHAPE
4807 || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
4808 && !fsym->attr.allocatable))
4809 {
4810 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
4811 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4812 (TREE_TYPE (parmse.expr))));
4813 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
4814 tmp2 = gfc_conv_descriptor_data_get (tmp2);
4815 }
4816 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
4817 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
4818 else
4819 {
4820 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
4821 tmp2 = parmse.expr;
4822 }
4823
4824 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4825 gfc_array_index_type,
4826 fold_convert (gfc_array_index_type, tmp2),
4827 fold_convert (gfc_array_index_type, tmp));
4828 offset = fold_build2_loc (input_location, PLUS_EXPR,
4829 gfc_array_index_type, offset, tmp);
4830
4831 vec_safe_push (stringargs, offset);
4832 }
4833
4834 vec_safe_push (arglist, parmse.expr);
4835 }
4836 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
4837
4838 if (comp)
4839 ts = comp->ts;
4840 else
4841 ts = sym->ts;
4842
4843 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
4844 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
4845 else if (ts.type == BT_CHARACTER)
4846 {
4847 if (ts.u.cl->length == NULL)
4848 {
4849 /* Assumed character length results are not allowed by 5.1.1.5 of the
4850 standard and are trapped in resolve.c; except in the case of SPREAD
4851 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4852 we take the character length of the first argument for the result.
4853 For dummies, we have to look through the formal argument list for
4854 this function and use the character length found there.*/
4855 if (ts.deferred)
4856 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
4857 else if (!sym->attr.dummy)
4858 cl.backend_decl = (*stringargs)[0];
4859 else
4860 {
4861 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
4862 for (; formal; formal = formal->next)
4863 if (strcmp (formal->sym->name, sym->name) == 0)
4864 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
4865 }
4866 len = cl.backend_decl;
4867 }
4868 else
4869 {
4870 tree tmp;
4871
4872 /* Calculate the length of the returned string. */
4873 gfc_init_se (&parmse, NULL);
4874 if (need_interface_mapping)
4875 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
4876 else
4877 gfc_conv_expr (&parmse, ts.u.cl->length);
4878 gfc_add_block_to_block (&se->pre, &parmse.pre);
4879 gfc_add_block_to_block (&se->post, &parmse.post);
4880
4881 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
4882 tmp = fold_build2_loc (input_location, MAX_EXPR,
4883 gfc_charlen_type_node, tmp,
4884 build_int_cst (gfc_charlen_type_node, 0));
4885 cl.backend_decl = tmp;
4886 }
4887
4888 /* Set up a charlen structure for it. */
4889 cl.next = NULL;
4890 cl.length = NULL;
4891 ts.u.cl = &cl;
4892
4893 len = cl.backend_decl;
4894 }
4895
4896 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
4897 || (!comp && gfc_return_by_reference (sym));
4898 if (byref)
4899 {
4900 if (se->direct_byref)
4901 {
4902 /* Sometimes, too much indirection can be applied; e.g. for
4903 function_result = array_valued_recursive_function. */
4904 if (TREE_TYPE (TREE_TYPE (se->expr))
4905 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
4906 && GFC_DESCRIPTOR_TYPE_P
4907 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
4908 se->expr = build_fold_indirect_ref_loc (input_location,
4909 se->expr);
4910
4911 /* If the lhs of an assignment x = f(..) is allocatable and
4912 f2003 is allowed, we must do the automatic reallocation.
4913 TODO - deal with intrinsics, without using a temporary. */
4914 if (gfc_option.flag_realloc_lhs
4915 && se->ss && se->ss->loop_chain
4916 && se->ss->loop_chain->is_alloc_lhs
4917 && !expr->value.function.isym
4918 && sym->result->as != NULL)
4919 {
4920 /* Evaluate the bounds of the result, if known. */
4921 gfc_set_loop_bounds_from_array_spec (&mapping, se,
4922 sym->result->as);
4923
4924 /* Perform the automatic reallocation. */
4925 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
4926 expr, NULL);
4927 gfc_add_expr_to_block (&se->pre, tmp);
4928
4929 /* Pass the temporary as the first argument. */
4930 result = info->descriptor;
4931 }
4932 else
4933 result = build_fold_indirect_ref_loc (input_location,
4934 se->expr);
4935 vec_safe_push (retargs, se->expr);
4936 }
4937 else if (comp && comp->attr.dimension)
4938 {
4939 gcc_assert (se->loop && info);
4940
4941 /* Set the type of the array. */
4942 tmp = gfc_typenode_for_spec (&comp->ts);
4943 gcc_assert (se->ss->dimen == se->loop->dimen);
4944
4945 /* Evaluate the bounds of the result, if known. */
4946 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
4947
4948 /* If the lhs of an assignment x = f(..) is allocatable and
4949 f2003 is allowed, we must not generate the function call
4950 here but should just send back the results of the mapping.
4951 This is signalled by the function ss being flagged. */
4952 if (gfc_option.flag_realloc_lhs
4953 && se->ss && se->ss->is_alloc_lhs)
4954 {
4955 gfc_free_interface_mapping (&mapping);
4956 return has_alternate_specifier;
4957 }
4958
4959 /* Create a temporary to store the result. In case the function
4960 returns a pointer, the temporary will be a shallow copy and
4961 mustn't be deallocated. */
4962 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
4963 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4964 tmp, NULL_TREE, false,
4965 !comp->attr.pointer, callee_alloc,
4966 &se->ss->info->expr->where);
4967
4968 /* Pass the temporary as the first argument. */
4969 result = info->descriptor;
4970 tmp = gfc_build_addr_expr (NULL_TREE, result);
4971 vec_safe_push (retargs, tmp);
4972 }
4973 else if (!comp && sym->result->attr.dimension)
4974 {
4975 gcc_assert (se->loop && info);
4976
4977 /* Set the type of the array. */
4978 tmp = gfc_typenode_for_spec (&ts);
4979 gcc_assert (se->ss->dimen == se->loop->dimen);
4980
4981 /* Evaluate the bounds of the result, if known. */
4982 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
4983
4984 /* If the lhs of an assignment x = f(..) is allocatable and
4985 f2003 is allowed, we must not generate the function call
4986 here but should just send back the results of the mapping.
4987 This is signalled by the function ss being flagged. */
4988 if (gfc_option.flag_realloc_lhs
4989 && se->ss && se->ss->is_alloc_lhs)
4990 {
4991 gfc_free_interface_mapping (&mapping);
4992 return has_alternate_specifier;
4993 }
4994
4995 /* Create a temporary to store the result. In case the function
4996 returns a pointer, the temporary will be a shallow copy and
4997 mustn't be deallocated. */
4998 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
4999 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
5000 tmp, NULL_TREE, false,
5001 !sym->attr.pointer, callee_alloc,
5002 &se->ss->info->expr->where);
5003
5004 /* Pass the temporary as the first argument. */
5005 result = info->descriptor;
5006 tmp = gfc_build_addr_expr (NULL_TREE, result);
5007 vec_safe_push (retargs, tmp);
5008 }
5009 else if (ts.type == BT_CHARACTER)
5010 {
5011 /* Pass the string length. */
5012 type = gfc_get_character_type (ts.kind, ts.u.cl);
5013 type = build_pointer_type (type);
5014
5015 /* Return an address to a char[0:len-1]* temporary for
5016 character pointers. */
5017 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
5018 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
5019 {
5020 var = gfc_create_var (type, "pstr");
5021
5022 if ((!comp && sym->attr.allocatable)
5023 || (comp && comp->attr.allocatable))
5024 {
5025 gfc_add_modify (&se->pre, var,
5026 fold_convert (TREE_TYPE (var),
5027 null_pointer_node));
5028 tmp = gfc_call_free (convert (pvoid_type_node, var));
5029 gfc_add_expr_to_block (&se->post, tmp);
5030 }
5031
5032 /* Provide an address expression for the function arguments. */
5033 var = gfc_build_addr_expr (NULL_TREE, var);
5034 }
5035 else
5036 var = gfc_conv_string_tmp (se, type, len);
5037
5038 vec_safe_push (retargs, var);
5039 }
5040 else
5041 {
5042 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
5043
5044 type = gfc_get_complex_type (ts.kind);
5045 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
5046 vec_safe_push (retargs, var);
5047 }
5048
5049 /* Add the string length to the argument list. */
5050 if (ts.type == BT_CHARACTER && ts.deferred)
5051 {
5052 tmp = len;
5053 if (TREE_CODE (tmp) != VAR_DECL)
5054 tmp = gfc_evaluate_now (len, &se->pre);
5055 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5056 vec_safe_push (retargs, tmp);
5057 }
5058 else if (ts.type == BT_CHARACTER)
5059 vec_safe_push (retargs, len);
5060 }
5061 gfc_free_interface_mapping (&mapping);
5062
5063 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5064 arglen = (vec_safe_length (arglist) + vec_safe_length (stringargs)
5065 + vec_safe_length (append_args));
5066 vec_safe_reserve (retargs, arglen);
5067
5068 /* Add the return arguments. */
5069 retargs->splice (arglist);
5070
5071 /* Add the hidden string length parameters to the arguments. */
5072 retargs->splice (stringargs);
5073
5074 /* We may want to append extra arguments here. This is used e.g. for
5075 calls to libgfortran_matmul_??, which need extra information. */
5076 if (!vec_safe_is_empty (append_args))
5077 retargs->splice (append_args);
5078 arglist = retargs;
5079
5080 /* Generate the actual call. */
5081 if (base_object == NULL_TREE)
5082 conv_function_val (se, sym, expr);
5083 else
5084 conv_base_obj_fcn_val (se, base_object, expr);
5085
5086 /* If there are alternate return labels, function type should be
5087 integer. Can't modify the type in place though, since it can be shared
5088 with other functions. For dummy arguments, the typing is done to
5089 this result, even if it has to be repeated for each call. */
5090 if (has_alternate_specifier
5091 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
5092 {
5093 if (!sym->attr.dummy)
5094 {
5095 TREE_TYPE (sym->backend_decl)
5096 = build_function_type (integer_type_node,
5097 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
5098 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
5099 }
5100 else
5101 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
5102 }
5103
5104 fntype = TREE_TYPE (TREE_TYPE (se->expr));
5105 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
5106
5107 /* If we have a pointer function, but we don't want a pointer, e.g.
5108 something like
5109 x = f()
5110 where f is pointer valued, we have to dereference the result. */
5111 if (!se->want_pointer && !byref
5112 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
5113 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
5114 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5115
5116 /* f2c calling conventions require a scalar default real function to
5117 return a double precision result. Convert this back to default
5118 real. We only care about the cases that can happen in Fortran 77.
5119 */
5120 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
5121 && sym->ts.kind == gfc_default_real_kind
5122 && !sym->attr.always_explicit)
5123 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
5124
5125 /* A pure function may still have side-effects - it may modify its
5126 parameters. */
5127 TREE_SIDE_EFFECTS (se->expr) = 1;
5128 #if 0
5129 if (!sym->attr.pure)
5130 TREE_SIDE_EFFECTS (se->expr) = 1;
5131 #endif
5132
5133 if (byref)
5134 {
5135 /* Add the function call to the pre chain. There is no expression. */
5136 gfc_add_expr_to_block (&se->pre, se->expr);
5137 se->expr = NULL_TREE;
5138
5139 if (!se->direct_byref)
5140 {
5141 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
5142 {
5143 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
5144 {
5145 /* Check the data pointer hasn't been modified. This would
5146 happen in a function returning a pointer. */
5147 tmp = gfc_conv_descriptor_data_get (info->descriptor);
5148 tmp = fold_build2_loc (input_location, NE_EXPR,
5149 boolean_type_node,
5150 tmp, info->data);
5151 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
5152 gfc_msg_fault);
5153 }
5154 se->expr = info->descriptor;
5155 /* Bundle in the string length. */
5156 se->string_length = len;
5157 }
5158 else if (ts.type == BT_CHARACTER)
5159 {
5160 /* Dereference for character pointer results. */
5161 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
5162 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
5163 se->expr = build_fold_indirect_ref_loc (input_location, var);
5164 else
5165 se->expr = var;
5166
5167 se->string_length = len;
5168 }
5169 else
5170 {
5171 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
5172 se->expr = build_fold_indirect_ref_loc (input_location, var);
5173 }
5174 }
5175 }
5176
5177 /* Follow the function call with the argument post block. */
5178 if (byref)
5179 {
5180 gfc_add_block_to_block (&se->pre, &post);
5181
5182 /* Transformational functions of derived types with allocatable
5183 components must have the result allocatable components copied. */
5184 arg = expr->value.function.actual;
5185 if (result && arg && expr->rank
5186 && expr->value.function.isym
5187 && expr->value.function.isym->transformational
5188 && arg->expr->ts.type == BT_DERIVED
5189 && arg->expr->ts.u.derived->attr.alloc_comp)
5190 {
5191 tree tmp2;
5192 /* Copy the allocatable components. We have to use a
5193 temporary here to prevent source allocatable components
5194 from being corrupted. */
5195 tmp2 = gfc_evaluate_now (result, &se->pre);
5196 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
5197 result, tmp2, expr->rank);
5198 gfc_add_expr_to_block (&se->pre, tmp);
5199 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
5200 expr->rank);
5201 gfc_add_expr_to_block (&se->pre, tmp);
5202
5203 /* Finally free the temporary's data field. */
5204 tmp = gfc_conv_descriptor_data_get (tmp2);
5205 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5206 NULL_TREE, NULL_TREE, true,
5207 NULL, false);
5208 gfc_add_expr_to_block (&se->pre, tmp);
5209 }
5210 }
5211 else
5212 gfc_add_block_to_block (&se->post, &post);
5213
5214 return has_alternate_specifier;
5215 }
5216
5217
5218 /* Fill a character string with spaces. */
5219
5220 static tree
fill_with_spaces(tree start,tree type,tree size)5221 fill_with_spaces (tree start, tree type, tree size)
5222 {
5223 stmtblock_t block, loop;
5224 tree i, el, exit_label, cond, tmp;
5225
5226 /* For a simple char type, we can call memset(). */
5227 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
5228 return build_call_expr_loc (input_location,
5229 builtin_decl_explicit (BUILT_IN_MEMSET),
5230 3, start,
5231 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
5232 lang_hooks.to_target_charset (' ')),
5233 size);
5234
5235 /* Otherwise, we use a loop:
5236 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5237 *el = (type) ' ';
5238 */
5239
5240 /* Initialize variables. */
5241 gfc_init_block (&block);
5242 i = gfc_create_var (sizetype, "i");
5243 gfc_add_modify (&block, i, fold_convert (sizetype, size));
5244 el = gfc_create_var (build_pointer_type (type), "el");
5245 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
5246 exit_label = gfc_build_label_decl (NULL_TREE);
5247 TREE_USED (exit_label) = 1;
5248
5249
5250 /* Loop body. */
5251 gfc_init_block (&loop);
5252
5253 /* Exit condition. */
5254 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
5255 build_zero_cst (sizetype));
5256 tmp = build1_v (GOTO_EXPR, exit_label);
5257 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
5258 build_empty_stmt (input_location));
5259 gfc_add_expr_to_block (&loop, tmp);
5260
5261 /* Assignment. */
5262 gfc_add_modify (&loop,
5263 fold_build1_loc (input_location, INDIRECT_REF, type, el),
5264 build_int_cst (type, lang_hooks.to_target_charset (' ')));
5265
5266 /* Increment loop variables. */
5267 gfc_add_modify (&loop, i,
5268 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
5269 TYPE_SIZE_UNIT (type)));
5270 gfc_add_modify (&loop, el,
5271 fold_build_pointer_plus_loc (input_location,
5272 el, TYPE_SIZE_UNIT (type)));
5273
5274 /* Making the loop... actually loop! */
5275 tmp = gfc_finish_block (&loop);
5276 tmp = build1_v (LOOP_EXPR, tmp);
5277 gfc_add_expr_to_block (&block, tmp);
5278
5279 /* The exit label. */
5280 tmp = build1_v (LABEL_EXPR, exit_label);
5281 gfc_add_expr_to_block (&block, tmp);
5282
5283
5284 return gfc_finish_block (&block);
5285 }
5286
5287
5288 /* Generate code to copy a string. */
5289
5290 void
gfc_trans_string_copy(stmtblock_t * block,tree dlength,tree dest,int dkind,tree slength,tree src,int skind)5291 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
5292 int dkind, tree slength, tree src, int skind)
5293 {
5294 tree tmp, dlen, slen;
5295 tree dsc;
5296 tree ssc;
5297 tree cond;
5298 tree cond2;
5299 tree tmp2;
5300 tree tmp3;
5301 tree tmp4;
5302 tree chartype;
5303 stmtblock_t tempblock;
5304
5305 gcc_assert (dkind == skind);
5306
5307 if (slength != NULL_TREE)
5308 {
5309 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
5310 ssc = gfc_string_to_single_character (slen, src, skind);
5311 }
5312 else
5313 {
5314 slen = build_int_cst (size_type_node, 1);
5315 ssc = src;
5316 }
5317
5318 if (dlength != NULL_TREE)
5319 {
5320 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
5321 dsc = gfc_string_to_single_character (dlen, dest, dkind);
5322 }
5323 else
5324 {
5325 dlen = build_int_cst (size_type_node, 1);
5326 dsc = dest;
5327 }
5328
5329 /* Assign directly if the types are compatible. */
5330 if (dsc != NULL_TREE && ssc != NULL_TREE
5331 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
5332 {
5333 gfc_add_modify (block, dsc, ssc);
5334 return;
5335 }
5336
5337 /* Do nothing if the destination length is zero. */
5338 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
5339 build_int_cst (size_type_node, 0));
5340
5341 /* The following code was previously in _gfortran_copy_string:
5342
5343 // The two strings may overlap so we use memmove.
5344 void
5345 copy_string (GFC_INTEGER_4 destlen, char * dest,
5346 GFC_INTEGER_4 srclen, const char * src)
5347 {
5348 if (srclen >= destlen)
5349 {
5350 // This will truncate if too long.
5351 memmove (dest, src, destlen);
5352 }
5353 else
5354 {
5355 memmove (dest, src, srclen);
5356 // Pad with spaces.
5357 memset (&dest[srclen], ' ', destlen - srclen);
5358 }
5359 }
5360
5361 We're now doing it here for better optimization, but the logic
5362 is the same. */
5363
5364 /* For non-default character kinds, we have to multiply the string
5365 length by the base type size. */
5366 chartype = gfc_get_char_type (dkind);
5367 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5368 fold_convert (size_type_node, slen),
5369 fold_convert (size_type_node,
5370 TYPE_SIZE_UNIT (chartype)));
5371 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5372 fold_convert (size_type_node, dlen),
5373 fold_convert (size_type_node,
5374 TYPE_SIZE_UNIT (chartype)));
5375
5376 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
5377 dest = fold_convert (pvoid_type_node, dest);
5378 else
5379 dest = gfc_build_addr_expr (pvoid_type_node, dest);
5380
5381 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
5382 src = fold_convert (pvoid_type_node, src);
5383 else
5384 src = gfc_build_addr_expr (pvoid_type_node, src);
5385
5386 /* Truncate string if source is too long. */
5387 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
5388 dlen);
5389 tmp2 = build_call_expr_loc (input_location,
5390 builtin_decl_explicit (BUILT_IN_MEMMOVE),
5391 3, dest, src, dlen);
5392
5393 /* Else copy and pad with spaces. */
5394 tmp3 = build_call_expr_loc (input_location,
5395 builtin_decl_explicit (BUILT_IN_MEMMOVE),
5396 3, dest, src, slen);
5397
5398 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
5399 tmp4 = fill_with_spaces (tmp4, chartype,
5400 fold_build2_loc (input_location, MINUS_EXPR,
5401 TREE_TYPE(dlen), dlen, slen));
5402
5403 gfc_init_block (&tempblock);
5404 gfc_add_expr_to_block (&tempblock, tmp3);
5405 gfc_add_expr_to_block (&tempblock, tmp4);
5406 tmp3 = gfc_finish_block (&tempblock);
5407
5408 /* The whole copy_string function is there. */
5409 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
5410 tmp2, tmp3);
5411 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
5412 build_empty_stmt (input_location));
5413 gfc_add_expr_to_block (block, tmp);
5414 }
5415
5416
5417 /* Translate a statement function.
5418 The value of a statement function reference is obtained by evaluating the
5419 expression using the values of the actual arguments for the values of the
5420 corresponding dummy arguments. */
5421
5422 static void
gfc_conv_statement_function(gfc_se * se,gfc_expr * expr)5423 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
5424 {
5425 gfc_symbol *sym;
5426 gfc_symbol *fsym;
5427 gfc_formal_arglist *fargs;
5428 gfc_actual_arglist *args;
5429 gfc_se lse;
5430 gfc_se rse;
5431 gfc_saved_var *saved_vars;
5432 tree *temp_vars;
5433 tree type;
5434 tree tmp;
5435 int n;
5436
5437 sym = expr->symtree->n.sym;
5438 args = expr->value.function.actual;
5439 gfc_init_se (&lse, NULL);
5440 gfc_init_se (&rse, NULL);
5441
5442 n = 0;
5443 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
5444 n++;
5445 saved_vars = XCNEWVEC (gfc_saved_var, n);
5446 temp_vars = XCNEWVEC (tree, n);
5447
5448 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
5449 fargs = fargs->next, n++)
5450 {
5451 /* Each dummy shall be specified, explicitly or implicitly, to be
5452 scalar. */
5453 gcc_assert (fargs->sym->attr.dimension == 0);
5454 fsym = fargs->sym;
5455
5456 if (fsym->ts.type == BT_CHARACTER)
5457 {
5458 /* Copy string arguments. */
5459 tree arglen;
5460
5461 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
5462 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
5463
5464 /* Create a temporary to hold the value. */
5465 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
5466 fsym->ts.u.cl->backend_decl
5467 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
5468
5469 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
5470 temp_vars[n] = gfc_create_var (type, fsym->name);
5471
5472 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
5473
5474 gfc_conv_expr (&rse, args->expr);
5475 gfc_conv_string_parameter (&rse);
5476 gfc_add_block_to_block (&se->pre, &lse.pre);
5477 gfc_add_block_to_block (&se->pre, &rse.pre);
5478
5479 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
5480 rse.string_length, rse.expr, fsym->ts.kind);
5481 gfc_add_block_to_block (&se->pre, &lse.post);
5482 gfc_add_block_to_block (&se->pre, &rse.post);
5483 }
5484 else
5485 {
5486 /* For everything else, just evaluate the expression. */
5487
5488 /* Create a temporary to hold the value. */
5489 type = gfc_typenode_for_spec (&fsym->ts);
5490 temp_vars[n] = gfc_create_var (type, fsym->name);
5491
5492 gfc_conv_expr (&lse, args->expr);
5493
5494 gfc_add_block_to_block (&se->pre, &lse.pre);
5495 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
5496 gfc_add_block_to_block (&se->pre, &lse.post);
5497 }
5498
5499 args = args->next;
5500 }
5501
5502 /* Use the temporary variables in place of the real ones. */
5503 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
5504 fargs = fargs->next, n++)
5505 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
5506
5507 gfc_conv_expr (se, sym->value);
5508
5509 if (sym->ts.type == BT_CHARACTER)
5510 {
5511 gfc_conv_const_charlen (sym->ts.u.cl);
5512
5513 /* Force the expression to the correct length. */
5514 if (!INTEGER_CST_P (se->string_length)
5515 || tree_int_cst_lt (se->string_length,
5516 sym->ts.u.cl->backend_decl))
5517 {
5518 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
5519 tmp = gfc_create_var (type, sym->name);
5520 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
5521 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
5522 sym->ts.kind, se->string_length, se->expr,
5523 sym->ts.kind);
5524 se->expr = tmp;
5525 }
5526 se->string_length = sym->ts.u.cl->backend_decl;
5527 }
5528
5529 /* Restore the original variables. */
5530 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
5531 fargs = fargs->next, n++)
5532 gfc_restore_sym (fargs->sym, &saved_vars[n]);
5533 free (temp_vars);
5534 free (saved_vars);
5535 }
5536
5537
5538 /* Translate a function expression. */
5539
5540 static void
gfc_conv_function_expr(gfc_se * se,gfc_expr * expr)5541 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
5542 {
5543 gfc_symbol *sym;
5544
5545 if (expr->value.function.isym)
5546 {
5547 gfc_conv_intrinsic_function (se, expr);
5548 return;
5549 }
5550
5551 /* expr.value.function.esym is the resolved (specific) function symbol for
5552 most functions. However this isn't set for dummy procedures. */
5553 sym = expr->value.function.esym;
5554 if (!sym)
5555 sym = expr->symtree->n.sym;
5556
5557 /* We distinguish statement functions from general functions to improve
5558 runtime performance. */
5559 if (sym->attr.proc == PROC_ST_FUNCTION)
5560 {
5561 gfc_conv_statement_function (se, expr);
5562 return;
5563 }
5564
5565 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
5566 NULL);
5567 }
5568
5569
5570 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5571
5572 static bool
is_zero_initializer_p(gfc_expr * expr)5573 is_zero_initializer_p (gfc_expr * expr)
5574 {
5575 if (expr->expr_type != EXPR_CONSTANT)
5576 return false;
5577
5578 /* We ignore constants with prescribed memory representations for now. */
5579 if (expr->representation.string)
5580 return false;
5581
5582 switch (expr->ts.type)
5583 {
5584 case BT_INTEGER:
5585 return mpz_cmp_si (expr->value.integer, 0) == 0;
5586
5587 case BT_REAL:
5588 return mpfr_zero_p (expr->value.real)
5589 && MPFR_SIGN (expr->value.real) >= 0;
5590
5591 case BT_LOGICAL:
5592 return expr->value.logical == 0;
5593
5594 case BT_COMPLEX:
5595 return mpfr_zero_p (mpc_realref (expr->value.complex))
5596 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
5597 && mpfr_zero_p (mpc_imagref (expr->value.complex))
5598 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
5599
5600 default:
5601 break;
5602 }
5603 return false;
5604 }
5605
5606
5607 static void
gfc_conv_array_constructor_expr(gfc_se * se,gfc_expr * expr)5608 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
5609 {
5610 gfc_ss *ss;
5611
5612 ss = se->ss;
5613 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
5614 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
5615
5616 gfc_conv_tmp_array_ref (se);
5617 }
5618
5619
5620 /* Build a static initializer. EXPR is the expression for the initial value.
5621 The other parameters describe the variable of the component being
5622 initialized. EXPR may be null. */
5623
5624 tree
gfc_conv_initializer(gfc_expr * expr,gfc_typespec * ts,tree type,bool array,bool pointer,bool procptr)5625 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
5626 bool array, bool pointer, bool procptr)
5627 {
5628 gfc_se se;
5629
5630 if (!(expr || pointer || procptr))
5631 return NULL_TREE;
5632
5633 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5634 (these are the only two iso_c_binding derived types that can be
5635 used as initialization expressions). If so, we need to modify
5636 the 'expr' to be that for a (void *). */
5637 if (expr != NULL && expr->ts.type == BT_DERIVED
5638 && expr->ts.is_iso_c && expr->ts.u.derived)
5639 {
5640 gfc_symbol *derived = expr->ts.u.derived;
5641
5642 /* The derived symbol has already been converted to a (void *). Use
5643 its kind. */
5644 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
5645 expr->ts.f90_type = derived->ts.f90_type;
5646
5647 gfc_init_se (&se, NULL);
5648 gfc_conv_constant (&se, expr);
5649 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
5650 return se.expr;
5651 }
5652
5653 if (array && !procptr)
5654 {
5655 tree ctor;
5656 /* Arrays need special handling. */
5657 if (pointer)
5658 ctor = gfc_build_null_descriptor (type);
5659 /* Special case assigning an array to zero. */
5660 else if (is_zero_initializer_p (expr))
5661 ctor = build_constructor (type, NULL);
5662 else
5663 ctor = gfc_conv_array_initializer (type, expr);
5664 TREE_STATIC (ctor) = 1;
5665 return ctor;
5666 }
5667 else if (pointer || procptr)
5668 {
5669 if (!expr || expr->expr_type == EXPR_NULL)
5670 return fold_convert (type, null_pointer_node);
5671 else
5672 {
5673 gfc_init_se (&se, NULL);
5674 se.want_pointer = 1;
5675 gfc_conv_expr (&se, expr);
5676 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
5677 return se.expr;
5678 }
5679 }
5680 else
5681 {
5682 switch (ts->type)
5683 {
5684 case BT_DERIVED:
5685 case BT_CLASS:
5686 gfc_init_se (&se, NULL);
5687 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
5688 gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
5689 else
5690 gfc_conv_structure (&se, expr, 1);
5691 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
5692 TREE_STATIC (se.expr) = 1;
5693 return se.expr;
5694
5695 case BT_CHARACTER:
5696 {
5697 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
5698 TREE_STATIC (ctor) = 1;
5699 return ctor;
5700 }
5701
5702 default:
5703 gfc_init_se (&se, NULL);
5704 gfc_conv_constant (&se, expr);
5705 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
5706 return se.expr;
5707 }
5708 }
5709 }
5710
5711 static tree
gfc_trans_subarray_assign(tree dest,gfc_component * cm,gfc_expr * expr)5712 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
5713 {
5714 gfc_se rse;
5715 gfc_se lse;
5716 gfc_ss *rss;
5717 gfc_ss *lss;
5718 gfc_array_info *lss_array;
5719 stmtblock_t body;
5720 stmtblock_t block;
5721 gfc_loopinfo loop;
5722 int n;
5723 tree tmp;
5724
5725 gfc_start_block (&block);
5726
5727 /* Initialize the scalarizer. */
5728 gfc_init_loopinfo (&loop);
5729
5730 gfc_init_se (&lse, NULL);
5731 gfc_init_se (&rse, NULL);
5732
5733 /* Walk the rhs. */
5734 rss = gfc_walk_expr (expr);
5735 if (rss == gfc_ss_terminator)
5736 /* The rhs is scalar. Add a ss for the expression. */
5737 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
5738
5739 /* Create a SS for the destination. */
5740 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
5741 GFC_SS_COMPONENT);
5742 lss_array = &lss->info->data.array;
5743 lss_array->shape = gfc_get_shape (cm->as->rank);
5744 lss_array->descriptor = dest;
5745 lss_array->data = gfc_conv_array_data (dest);
5746 lss_array->offset = gfc_conv_array_offset (dest);
5747 for (n = 0; n < cm->as->rank; n++)
5748 {
5749 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
5750 lss_array->stride[n] = gfc_index_one_node;
5751
5752 mpz_init (lss_array->shape[n]);
5753 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
5754 cm->as->lower[n]->value.integer);
5755 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
5756 }
5757
5758 /* Associate the SS with the loop. */
5759 gfc_add_ss_to_loop (&loop, lss);
5760 gfc_add_ss_to_loop (&loop, rss);
5761
5762 /* Calculate the bounds of the scalarization. */
5763 gfc_conv_ss_startstride (&loop);
5764
5765 /* Setup the scalarizing loops. */
5766 gfc_conv_loop_setup (&loop, &expr->where);
5767
5768 /* Setup the gfc_se structures. */
5769 gfc_copy_loopinfo_to_se (&lse, &loop);
5770 gfc_copy_loopinfo_to_se (&rse, &loop);
5771
5772 rse.ss = rss;
5773 gfc_mark_ss_chain_used (rss, 1);
5774 lse.ss = lss;
5775 gfc_mark_ss_chain_used (lss, 1);
5776
5777 /* Start the scalarized loop body. */
5778 gfc_start_scalarized_body (&loop, &body);
5779
5780 gfc_conv_tmp_array_ref (&lse);
5781 if (cm->ts.type == BT_CHARACTER)
5782 lse.string_length = cm->ts.u.cl->backend_decl;
5783
5784 gfc_conv_expr (&rse, expr);
5785
5786 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
5787 gfc_add_expr_to_block (&body, tmp);
5788
5789 gcc_assert (rse.ss == gfc_ss_terminator);
5790
5791 /* Generate the copying loops. */
5792 gfc_trans_scalarizing_loops (&loop, &body);
5793
5794 /* Wrap the whole thing up. */
5795 gfc_add_block_to_block (&block, &loop.pre);
5796 gfc_add_block_to_block (&block, &loop.post);
5797
5798 gcc_assert (lss_array->shape != NULL);
5799 gfc_free_shape (&lss_array->shape, cm->as->rank);
5800 gfc_cleanup_loop (&loop);
5801
5802 return gfc_finish_block (&block);
5803 }
5804
5805
5806 static tree
gfc_trans_alloc_subarray_assign(tree dest,gfc_component * cm,gfc_expr * expr)5807 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
5808 gfc_expr * expr)
5809 {
5810 gfc_se se;
5811 stmtblock_t block;
5812 tree offset;
5813 int n;
5814 tree tmp;
5815 tree tmp2;
5816 gfc_array_spec *as;
5817 gfc_expr *arg = NULL;
5818
5819 gfc_start_block (&block);
5820 gfc_init_se (&se, NULL);
5821
5822 /* Get the descriptor for the expressions. */
5823 se.want_pointer = 0;
5824 gfc_conv_expr_descriptor (&se, expr);
5825 gfc_add_block_to_block (&block, &se.pre);
5826 gfc_add_modify (&block, dest, se.expr);
5827
5828 /* Deal with arrays of derived types with allocatable components. */
5829 if (cm->ts.type == BT_DERIVED
5830 && cm->ts.u.derived->attr.alloc_comp)
5831 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
5832 se.expr, dest,
5833 cm->as->rank);
5834 else
5835 tmp = gfc_duplicate_allocatable (dest, se.expr,
5836 TREE_TYPE(cm->backend_decl),
5837 cm->as->rank);
5838
5839 gfc_add_expr_to_block (&block, tmp);
5840 gfc_add_block_to_block (&block, &se.post);
5841
5842 if (expr->expr_type != EXPR_VARIABLE)
5843 gfc_conv_descriptor_data_set (&block, se.expr,
5844 null_pointer_node);
5845
5846 /* We need to know if the argument of a conversion function is a
5847 variable, so that the correct lower bound can be used. */
5848 if (expr->expr_type == EXPR_FUNCTION
5849 && expr->value.function.isym
5850 && expr->value.function.isym->conversion
5851 && expr->value.function.actual->expr
5852 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
5853 arg = expr->value.function.actual->expr;
5854
5855 /* Obtain the array spec of full array references. */
5856 if (arg)
5857 as = gfc_get_full_arrayspec_from_expr (arg);
5858 else
5859 as = gfc_get_full_arrayspec_from_expr (expr);
5860
5861 /* Shift the lbound and ubound of temporaries to being unity,
5862 rather than zero, based. Always calculate the offset. */
5863 offset = gfc_conv_descriptor_offset_get (dest);
5864 gfc_add_modify (&block, offset, gfc_index_zero_node);
5865 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
5866
5867 for (n = 0; n < expr->rank; n++)
5868 {
5869 tree span;
5870 tree lbound;
5871
5872 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5873 TODO It looks as if gfc_conv_expr_descriptor should return
5874 the correct bounds and that the following should not be
5875 necessary. This would simplify gfc_conv_intrinsic_bound
5876 as well. */
5877 if (as && as->lower[n])
5878 {
5879 gfc_se lbse;
5880 gfc_init_se (&lbse, NULL);
5881 gfc_conv_expr (&lbse, as->lower[n]);
5882 gfc_add_block_to_block (&block, &lbse.pre);
5883 lbound = gfc_evaluate_now (lbse.expr, &block);
5884 }
5885 else if (as && arg)
5886 {
5887 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
5888 lbound = gfc_conv_descriptor_lbound_get (tmp,
5889 gfc_rank_cst[n]);
5890 }
5891 else if (as)
5892 lbound = gfc_conv_descriptor_lbound_get (dest,
5893 gfc_rank_cst[n]);
5894 else
5895 lbound = gfc_index_one_node;
5896
5897 lbound = fold_convert (gfc_array_index_type, lbound);
5898
5899 /* Shift the bounds and set the offset accordingly. */
5900 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
5901 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5902 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
5903 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5904 span, lbound);
5905 gfc_conv_descriptor_ubound_set (&block, dest,
5906 gfc_rank_cst[n], tmp);
5907 gfc_conv_descriptor_lbound_set (&block, dest,
5908 gfc_rank_cst[n], lbound);
5909
5910 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5911 gfc_conv_descriptor_lbound_get (dest,
5912 gfc_rank_cst[n]),
5913 gfc_conv_descriptor_stride_get (dest,
5914 gfc_rank_cst[n]));
5915 gfc_add_modify (&block, tmp2, tmp);
5916 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5917 offset, tmp2);
5918 gfc_conv_descriptor_offset_set (&block, dest, tmp);
5919 }
5920
5921 if (arg)
5922 {
5923 /* If a conversion expression has a null data pointer
5924 argument, nullify the allocatable component. */
5925 tree non_null_expr;
5926 tree null_expr;
5927
5928 if (arg->symtree->n.sym->attr.allocatable
5929 || arg->symtree->n.sym->attr.pointer)
5930 {
5931 non_null_expr = gfc_finish_block (&block);
5932 gfc_start_block (&block);
5933 gfc_conv_descriptor_data_set (&block, dest,
5934 null_pointer_node);
5935 null_expr = gfc_finish_block (&block);
5936 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
5937 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5938 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5939 return build3_v (COND_EXPR, tmp,
5940 null_expr, non_null_expr);
5941 }
5942 }
5943
5944 return gfc_finish_block (&block);
5945 }
5946
5947
5948 /* Assign a single component of a derived type constructor. */
5949
5950 static tree
gfc_trans_subcomponent_assign(tree dest,gfc_component * cm,gfc_expr * expr)5951 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
5952 {
5953 gfc_se se;
5954 gfc_se lse;
5955 stmtblock_t block;
5956 tree tmp;
5957
5958 gfc_start_block (&block);
5959
5960 if (cm->attr.pointer || cm->attr.proc_pointer)
5961 {
5962 gfc_init_se (&se, NULL);
5963 /* Pointer component. */
5964 if (cm->attr.dimension && !cm->attr.proc_pointer)
5965 {
5966 /* Array pointer. */
5967 if (expr->expr_type == EXPR_NULL)
5968 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5969 else
5970 {
5971 se.direct_byref = 1;
5972 se.expr = dest;
5973 gfc_conv_expr_descriptor (&se, expr);
5974 gfc_add_block_to_block (&block, &se.pre);
5975 gfc_add_block_to_block (&block, &se.post);
5976 }
5977 }
5978 else
5979 {
5980 /* Scalar pointers. */
5981 se.want_pointer = 1;
5982 gfc_conv_expr (&se, expr);
5983 gfc_add_block_to_block (&block, &se.pre);
5984
5985 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
5986 && expr->symtree->n.sym->attr.dummy)
5987 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
5988
5989 gfc_add_modify (&block, dest,
5990 fold_convert (TREE_TYPE (dest), se.expr));
5991 gfc_add_block_to_block (&block, &se.post);
5992 }
5993 }
5994 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
5995 {
5996 /* NULL initialization for CLASS components. */
5997 tmp = gfc_trans_structure_assign (dest,
5998 gfc_class_null_initializer (&cm->ts, expr));
5999 gfc_add_expr_to_block (&block, tmp);
6000 }
6001 else if (cm->attr.dimension && !cm->attr.proc_pointer)
6002 {
6003 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
6004 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6005 else if (cm->attr.allocatable)
6006 {
6007 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
6008 gfc_add_expr_to_block (&block, tmp);
6009 }
6010 else
6011 {
6012 tmp = gfc_trans_subarray_assign (dest, cm, expr);
6013 gfc_add_expr_to_block (&block, tmp);
6014 }
6015 }
6016 else if (expr->ts.type == BT_DERIVED)
6017 {
6018 if (expr->expr_type != EXPR_STRUCTURE)
6019 {
6020 gfc_init_se (&se, NULL);
6021 gfc_conv_expr (&se, expr);
6022 gfc_add_block_to_block (&block, &se.pre);
6023 gfc_add_modify (&block, dest,
6024 fold_convert (TREE_TYPE (dest), se.expr));
6025 gfc_add_block_to_block (&block, &se.post);
6026 }
6027 else
6028 {
6029 /* Nested constructors. */
6030 tmp = gfc_trans_structure_assign (dest, expr);
6031 gfc_add_expr_to_block (&block, tmp);
6032 }
6033 }
6034 else
6035 {
6036 /* Scalar component. */
6037 gfc_init_se (&se, NULL);
6038 gfc_init_se (&lse, NULL);
6039
6040 gfc_conv_expr (&se, expr);
6041 if (cm->ts.type == BT_CHARACTER)
6042 lse.string_length = cm->ts.u.cl->backend_decl;
6043 lse.expr = dest;
6044 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
6045 gfc_add_expr_to_block (&block, tmp);
6046 }
6047 return gfc_finish_block (&block);
6048 }
6049
6050 /* Assign a derived type constructor to a variable. */
6051
6052 static tree
gfc_trans_structure_assign(tree dest,gfc_expr * expr)6053 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
6054 {
6055 gfc_constructor *c;
6056 gfc_component *cm;
6057 stmtblock_t block;
6058 tree field;
6059 tree tmp;
6060
6061 gfc_start_block (&block);
6062 cm = expr->ts.u.derived->components;
6063
6064 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
6065 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
6066 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
6067 {
6068 gfc_se se, lse;
6069
6070 gcc_assert (cm->backend_decl == NULL);
6071 gfc_init_se (&se, NULL);
6072 gfc_init_se (&lse, NULL);
6073 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
6074 lse.expr = dest;
6075 gfc_add_modify (&block, lse.expr,
6076 fold_convert (TREE_TYPE (lse.expr), se.expr));
6077
6078 return gfc_finish_block (&block);
6079 }
6080
6081 for (c = gfc_constructor_first (expr->value.constructor);
6082 c; c = gfc_constructor_next (c), cm = cm->next)
6083 {
6084 /* Skip absent members in default initializers. */
6085 if (!c->expr)
6086 continue;
6087
6088 field = cm->backend_decl;
6089 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
6090 dest, field, NULL_TREE);
6091 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
6092 gfc_add_expr_to_block (&block, tmp);
6093 }
6094 return gfc_finish_block (&block);
6095 }
6096
6097 /* Build an expression for a constructor. If init is nonzero then
6098 this is part of a static variable initializer. */
6099
6100 void
gfc_conv_structure(gfc_se * se,gfc_expr * expr,int init)6101 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
6102 {
6103 gfc_constructor *c;
6104 gfc_component *cm;
6105 tree val;
6106 tree type;
6107 tree tmp;
6108 vec<constructor_elt, va_gc> *v = NULL;
6109
6110 gcc_assert (se->ss == NULL);
6111 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
6112 type = gfc_typenode_for_spec (&expr->ts);
6113
6114 if (!init)
6115 {
6116 /* Create a temporary variable and fill it in. */
6117 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
6118 tmp = gfc_trans_structure_assign (se->expr, expr);
6119 gfc_add_expr_to_block (&se->pre, tmp);
6120 return;
6121 }
6122
6123 cm = expr->ts.u.derived->components;
6124
6125 for (c = gfc_constructor_first (expr->value.constructor);
6126 c; c = gfc_constructor_next (c), cm = cm->next)
6127 {
6128 /* Skip absent members in default initializers and allocatable
6129 components. Although the latter have a default initializer
6130 of EXPR_NULL,... by default, the static nullify is not needed
6131 since this is done every time we come into scope. */
6132 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
6133 continue;
6134
6135 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
6136 && strcmp (cm->name, "_extends") == 0
6137 && cm->initializer->symtree)
6138 {
6139 tree vtab;
6140 gfc_symbol *vtabs;
6141 vtabs = cm->initializer->symtree->n.sym;
6142 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
6143 vtab = unshare_expr_without_location (vtab);
6144 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
6145 }
6146 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
6147 {
6148 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
6149 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
6150 }
6151 else
6152 {
6153 val = gfc_conv_initializer (c->expr, &cm->ts,
6154 TREE_TYPE (cm->backend_decl),
6155 cm->attr.dimension, cm->attr.pointer,
6156 cm->attr.proc_pointer);
6157 val = unshare_expr_without_location (val);
6158
6159 /* Append it to the constructor list. */
6160 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
6161 }
6162 }
6163 se->expr = build_constructor (type, v);
6164 if (init)
6165 TREE_CONSTANT (se->expr) = 1;
6166 }
6167
6168
6169 /* Translate a substring expression. */
6170
6171 static void
gfc_conv_substring_expr(gfc_se * se,gfc_expr * expr)6172 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
6173 {
6174 gfc_ref *ref;
6175
6176 ref = expr->ref;
6177
6178 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
6179
6180 se->expr = gfc_build_wide_string_const (expr->ts.kind,
6181 expr->value.character.length,
6182 expr->value.character.string);
6183
6184 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
6185 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
6186
6187 if (ref)
6188 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
6189 }
6190
6191
6192 /* Entry point for expression translation. Evaluates a scalar quantity.
6193 EXPR is the expression to be translated, and SE is the state structure if
6194 called from within the scalarized. */
6195
6196 void
gfc_conv_expr(gfc_se * se,gfc_expr * expr)6197 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
6198 {
6199 gfc_ss *ss;
6200
6201 ss = se->ss;
6202 if (ss && ss->info->expr == expr
6203 && (ss->info->type == GFC_SS_SCALAR
6204 || ss->info->type == GFC_SS_REFERENCE))
6205 {
6206 gfc_ss_info *ss_info;
6207
6208 ss_info = ss->info;
6209 /* Substitute a scalar expression evaluated outside the scalarization
6210 loop. */
6211 se->expr = ss_info->data.scalar.value;
6212 /* If the reference can be NULL, the value field contains the reference,
6213 not the value the reference points to (see gfc_add_loop_ss_code). */
6214 if (ss_info->can_be_null_ref)
6215 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6216
6217 se->string_length = ss_info->string_length;
6218 gfc_advance_se_ss_chain (se);
6219 return;
6220 }
6221
6222 /* We need to convert the expressions for the iso_c_binding derived types.
6223 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6224 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6225 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6226 updated to be an integer with a kind equal to the size of a (void *). */
6227 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
6228 && expr->ts.u.derived->attr.is_iso_c)
6229 {
6230 if (expr->expr_type == EXPR_VARIABLE
6231 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
6232 || expr->symtree->n.sym->intmod_sym_id
6233 == ISOCBINDING_NULL_FUNPTR))
6234 {
6235 /* Set expr_type to EXPR_NULL, which will result in
6236 null_pointer_node being used below. */
6237 expr->expr_type = EXPR_NULL;
6238 }
6239 else
6240 {
6241 /* Update the type/kind of the expression to be what the new
6242 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6243 expr->ts.type = expr->ts.u.derived->ts.type;
6244 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
6245 expr->ts.kind = expr->ts.u.derived->ts.kind;
6246 }
6247 }
6248
6249 gfc_fix_class_refs (expr);
6250
6251 switch (expr->expr_type)
6252 {
6253 case EXPR_OP:
6254 gfc_conv_expr_op (se, expr);
6255 break;
6256
6257 case EXPR_FUNCTION:
6258 gfc_conv_function_expr (se, expr);
6259 break;
6260
6261 case EXPR_CONSTANT:
6262 gfc_conv_constant (se, expr);
6263 break;
6264
6265 case EXPR_VARIABLE:
6266 gfc_conv_variable (se, expr);
6267 break;
6268
6269 case EXPR_NULL:
6270 se->expr = null_pointer_node;
6271 break;
6272
6273 case EXPR_SUBSTRING:
6274 gfc_conv_substring_expr (se, expr);
6275 break;
6276
6277 case EXPR_STRUCTURE:
6278 gfc_conv_structure (se, expr, 0);
6279 break;
6280
6281 case EXPR_ARRAY:
6282 gfc_conv_array_constructor_expr (se, expr);
6283 break;
6284
6285 default:
6286 gcc_unreachable ();
6287 break;
6288 }
6289 }
6290
6291 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6292 of an assignment. */
6293 void
gfc_conv_expr_lhs(gfc_se * se,gfc_expr * expr)6294 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
6295 {
6296 gfc_conv_expr (se, expr);
6297 /* All numeric lvalues should have empty post chains. If not we need to
6298 figure out a way of rewriting an lvalue so that it has no post chain. */
6299 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
6300 }
6301
6302 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6303 numeric expressions. Used for scalar values where inserting cleanup code
6304 is inconvenient. */
6305 void
gfc_conv_expr_val(gfc_se * se,gfc_expr * expr)6306 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
6307 {
6308 tree val;
6309
6310 gcc_assert (expr->ts.type != BT_CHARACTER);
6311 gfc_conv_expr (se, expr);
6312 if (se->post.head)
6313 {
6314 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
6315 gfc_add_modify (&se->pre, val, se->expr);
6316 se->expr = val;
6317 gfc_add_block_to_block (&se->pre, &se->post);
6318 }
6319 }
6320
6321 /* Helper to translate an expression and convert it to a particular type. */
6322 void
gfc_conv_expr_type(gfc_se * se,gfc_expr * expr,tree type)6323 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
6324 {
6325 gfc_conv_expr_val (se, expr);
6326 se->expr = convert (type, se->expr);
6327 }
6328
6329
6330 /* Converts an expression so that it can be passed by reference. Scalar
6331 values only. */
6332
6333 void
gfc_conv_expr_reference(gfc_se * se,gfc_expr * expr)6334 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
6335 {
6336 gfc_ss *ss;
6337 tree var;
6338
6339 ss = se->ss;
6340 if (ss && ss->info->expr == expr
6341 && ss->info->type == GFC_SS_REFERENCE)
6342 {
6343 /* Returns a reference to the scalar evaluated outside the loop
6344 for this case. */
6345 gfc_conv_expr (se, expr);
6346 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6347 return;
6348 }
6349
6350 if (expr->ts.type == BT_CHARACTER)
6351 {
6352 gfc_conv_expr (se, expr);
6353 gfc_conv_string_parameter (se);
6354 return;
6355 }
6356
6357 if (expr->expr_type == EXPR_VARIABLE)
6358 {
6359 se->want_pointer = 1;
6360 gfc_conv_expr (se, expr);
6361 if (se->post.head)
6362 {
6363 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
6364 gfc_add_modify (&se->pre, var, se->expr);
6365 gfc_add_block_to_block (&se->pre, &se->post);
6366 se->expr = var;
6367 }
6368 return;
6369 }
6370
6371 if (expr->expr_type == EXPR_FUNCTION
6372 && ((expr->value.function.esym
6373 && expr->value.function.esym->result->attr.pointer
6374 && !expr->value.function.esym->result->attr.dimension)
6375 || (!expr->value.function.esym && !expr->ref
6376 && expr->symtree->n.sym->attr.pointer
6377 && !expr->symtree->n.sym->attr.dimension)))
6378 {
6379 se->want_pointer = 1;
6380 gfc_conv_expr (se, expr);
6381 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
6382 gfc_add_modify (&se->pre, var, se->expr);
6383 se->expr = var;
6384 return;
6385 }
6386
6387 gfc_conv_expr (se, expr);
6388
6389 /* Create a temporary var to hold the value. */
6390 if (TREE_CONSTANT (se->expr))
6391 {
6392 tree tmp = se->expr;
6393 STRIP_TYPE_NOPS (tmp);
6394 var = build_decl (input_location,
6395 CONST_DECL, NULL, TREE_TYPE (tmp));
6396 DECL_INITIAL (var) = tmp;
6397 TREE_STATIC (var) = 1;
6398 pushdecl (var);
6399 }
6400 else
6401 {
6402 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
6403 gfc_add_modify (&se->pre, var, se->expr);
6404 }
6405 gfc_add_block_to_block (&se->pre, &se->post);
6406
6407 /* Take the address of that value. */
6408 se->expr = gfc_build_addr_expr (NULL_TREE, var);
6409 }
6410
6411
6412 tree
gfc_trans_pointer_assign(gfc_code * code)6413 gfc_trans_pointer_assign (gfc_code * code)
6414 {
6415 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
6416 }
6417
6418
6419 /* Generate code for a pointer assignment. */
6420
6421 tree
gfc_trans_pointer_assignment(gfc_expr * expr1,gfc_expr * expr2)6422 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
6423 {
6424 gfc_se lse;
6425 gfc_se rse;
6426 stmtblock_t block;
6427 tree desc;
6428 tree tmp;
6429 tree decl;
6430 bool scalar;
6431 gfc_ss *ss;
6432
6433 gfc_start_block (&block);
6434
6435 gfc_init_se (&lse, NULL);
6436
6437 /* Check whether the expression is a scalar or not; we cannot use
6438 expr1->rank as it can be nonzero for proc pointers. */
6439 ss = gfc_walk_expr (expr1);
6440 scalar = ss == gfc_ss_terminator;
6441 if (!scalar)
6442 gfc_free_ss_chain (ss);
6443
6444 if (scalar)
6445 {
6446 /* Scalar pointers. */
6447 lse.want_pointer = 1;
6448 gfc_conv_expr (&lse, expr1);
6449 gfc_init_se (&rse, NULL);
6450 rse.want_pointer = 1;
6451 gfc_conv_expr (&rse, expr2);
6452
6453 if (expr1->symtree->n.sym->attr.proc_pointer
6454 && expr1->symtree->n.sym->attr.dummy)
6455 lse.expr = build_fold_indirect_ref_loc (input_location,
6456 lse.expr);
6457
6458 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
6459 && expr2->symtree->n.sym->attr.dummy)
6460 rse.expr = build_fold_indirect_ref_loc (input_location,
6461 rse.expr);
6462
6463 gfc_add_block_to_block (&block, &lse.pre);
6464 gfc_add_block_to_block (&block, &rse.pre);
6465
6466 /* Check character lengths if character expression. The test is only
6467 really added if -fbounds-check is enabled. Exclude deferred
6468 character length lefthand sides. */
6469 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
6470 && !expr1->ts.deferred
6471 && !expr1->symtree->n.sym->attr.proc_pointer
6472 && !gfc_is_proc_ptr_comp (expr1))
6473 {
6474 gcc_assert (expr2->ts.type == BT_CHARACTER);
6475 gcc_assert (lse.string_length && rse.string_length);
6476 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
6477 lse.string_length, rse.string_length,
6478 &block);
6479 }
6480
6481 /* The assignment to an deferred character length sets the string
6482 length to that of the rhs. */
6483 if (expr1->ts.deferred)
6484 {
6485 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
6486 gfc_add_modify (&block, lse.string_length, rse.string_length);
6487 else if (lse.string_length != NULL)
6488 gfc_add_modify (&block, lse.string_length,
6489 build_int_cst (gfc_charlen_type_node, 0));
6490 }
6491
6492 gfc_add_modify (&block, lse.expr,
6493 fold_convert (TREE_TYPE (lse.expr), rse.expr));
6494
6495 gfc_add_block_to_block (&block, &rse.post);
6496 gfc_add_block_to_block (&block, &lse.post);
6497 }
6498 else
6499 {
6500 gfc_ref* remap;
6501 bool rank_remap;
6502 tree strlen_lhs;
6503 tree strlen_rhs = NULL_TREE;
6504
6505 /* Array pointer. Find the last reference on the LHS and if it is an
6506 array section ref, we're dealing with bounds remapping. In this case,
6507 set it to AR_FULL so that gfc_conv_expr_descriptor does
6508 not see it and process the bounds remapping afterwards explicitly. */
6509 for (remap = expr1->ref; remap; remap = remap->next)
6510 if (!remap->next && remap->type == REF_ARRAY
6511 && remap->u.ar.type == AR_SECTION)
6512 break;
6513 rank_remap = (remap && remap->u.ar.end[0]);
6514
6515 if (remap)
6516 lse.descriptor_only = 1;
6517 gfc_conv_expr_descriptor (&lse, expr1);
6518 strlen_lhs = lse.string_length;
6519 desc = lse.expr;
6520
6521 if (expr2->expr_type == EXPR_NULL)
6522 {
6523 /* Just set the data pointer to null. */
6524 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
6525 }
6526 else if (rank_remap)
6527 {
6528 /* If we are rank-remapping, just get the RHS's descriptor and
6529 process this later on. */
6530 gfc_init_se (&rse, NULL);
6531 rse.direct_byref = 1;
6532 rse.byref_noassign = 1;
6533 gfc_conv_expr_descriptor (&rse, expr2);
6534 strlen_rhs = rse.string_length;
6535 }
6536 else if (expr2->expr_type == EXPR_VARIABLE)
6537 {
6538 /* Assign directly to the LHS's descriptor. */
6539 lse.direct_byref = 1;
6540 gfc_conv_expr_descriptor (&lse, expr2);
6541 strlen_rhs = lse.string_length;
6542
6543 /* If this is a subreference array pointer assignment, use the rhs
6544 descriptor element size for the lhs span. */
6545 if (expr1->symtree->n.sym->attr.subref_array_pointer)
6546 {
6547 decl = expr1->symtree->n.sym->backend_decl;
6548 gfc_init_se (&rse, NULL);
6549 rse.descriptor_only = 1;
6550 gfc_conv_expr (&rse, expr2);
6551 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
6552 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
6553 if (!INTEGER_CST_P (tmp))
6554 gfc_add_block_to_block (&lse.post, &rse.pre);
6555 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
6556 }
6557 }
6558 else
6559 {
6560 /* Assign to a temporary descriptor and then copy that
6561 temporary to the pointer. */
6562 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
6563
6564 lse.expr = tmp;
6565 lse.direct_byref = 1;
6566 gfc_conv_expr_descriptor (&lse, expr2);
6567 strlen_rhs = lse.string_length;
6568 gfc_add_modify (&lse.pre, desc, tmp);
6569 }
6570
6571 gfc_add_block_to_block (&block, &lse.pre);
6572 if (rank_remap)
6573 gfc_add_block_to_block (&block, &rse.pre);
6574
6575 /* If we do bounds remapping, update LHS descriptor accordingly. */
6576 if (remap)
6577 {
6578 int dim;
6579 gcc_assert (remap->u.ar.dimen == expr1->rank);
6580
6581 if (rank_remap)
6582 {
6583 /* Do rank remapping. We already have the RHS's descriptor
6584 converted in rse and now have to build the correct LHS
6585 descriptor for it. */
6586
6587 tree dtype, data;
6588 tree offs, stride;
6589 tree lbound, ubound;
6590
6591 /* Set dtype. */
6592 dtype = gfc_conv_descriptor_dtype (desc);
6593 tmp = gfc_get_dtype (TREE_TYPE (desc));
6594 gfc_add_modify (&block, dtype, tmp);
6595
6596 /* Copy data pointer. */
6597 data = gfc_conv_descriptor_data_get (rse.expr);
6598 gfc_conv_descriptor_data_set (&block, desc, data);
6599
6600 /* Copy offset but adjust it such that it would correspond
6601 to a lbound of zero. */
6602 offs = gfc_conv_descriptor_offset_get (rse.expr);
6603 for (dim = 0; dim < expr2->rank; ++dim)
6604 {
6605 stride = gfc_conv_descriptor_stride_get (rse.expr,
6606 gfc_rank_cst[dim]);
6607 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
6608 gfc_rank_cst[dim]);
6609 tmp = fold_build2_loc (input_location, MULT_EXPR,
6610 gfc_array_index_type, stride, lbound);
6611 offs = fold_build2_loc (input_location, PLUS_EXPR,
6612 gfc_array_index_type, offs, tmp);
6613 }
6614 gfc_conv_descriptor_offset_set (&block, desc, offs);
6615
6616 /* Set the bounds as declared for the LHS and calculate strides as
6617 well as another offset update accordingly. */
6618 stride = gfc_conv_descriptor_stride_get (rse.expr,
6619 gfc_rank_cst[0]);
6620 for (dim = 0; dim < expr1->rank; ++dim)
6621 {
6622 gfc_se lower_se;
6623 gfc_se upper_se;
6624
6625 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
6626
6627 /* Convert declared bounds. */
6628 gfc_init_se (&lower_se, NULL);
6629 gfc_init_se (&upper_se, NULL);
6630 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
6631 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
6632
6633 gfc_add_block_to_block (&block, &lower_se.pre);
6634 gfc_add_block_to_block (&block, &upper_se.pre);
6635
6636 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
6637 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
6638
6639 lbound = gfc_evaluate_now (lbound, &block);
6640 ubound = gfc_evaluate_now (ubound, &block);
6641
6642 gfc_add_block_to_block (&block, &lower_se.post);
6643 gfc_add_block_to_block (&block, &upper_se.post);
6644
6645 /* Set bounds in descriptor. */
6646 gfc_conv_descriptor_lbound_set (&block, desc,
6647 gfc_rank_cst[dim], lbound);
6648 gfc_conv_descriptor_ubound_set (&block, desc,
6649 gfc_rank_cst[dim], ubound);
6650
6651 /* Set stride. */
6652 stride = gfc_evaluate_now (stride, &block);
6653 gfc_conv_descriptor_stride_set (&block, desc,
6654 gfc_rank_cst[dim], stride);
6655
6656 /* Update offset. */
6657 offs = gfc_conv_descriptor_offset_get (desc);
6658 tmp = fold_build2_loc (input_location, MULT_EXPR,
6659 gfc_array_index_type, lbound, stride);
6660 offs = fold_build2_loc (input_location, MINUS_EXPR,
6661 gfc_array_index_type, offs, tmp);
6662 offs = gfc_evaluate_now (offs, &block);
6663 gfc_conv_descriptor_offset_set (&block, desc, offs);
6664
6665 /* Update stride. */
6666 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
6667 stride = fold_build2_loc (input_location, MULT_EXPR,
6668 gfc_array_index_type, stride, tmp);
6669 }
6670 }
6671 else
6672 {
6673 /* Bounds remapping. Just shift the lower bounds. */
6674
6675 gcc_assert (expr1->rank == expr2->rank);
6676
6677 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
6678 {
6679 gfc_se lbound_se;
6680
6681 gcc_assert (remap->u.ar.start[dim]);
6682 gcc_assert (!remap->u.ar.end[dim]);
6683 gfc_init_se (&lbound_se, NULL);
6684 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
6685
6686 gfc_add_block_to_block (&block, &lbound_se.pre);
6687 gfc_conv_shift_descriptor_lbound (&block, desc,
6688 dim, lbound_se.expr);
6689 gfc_add_block_to_block (&block, &lbound_se.post);
6690 }
6691 }
6692 }
6693
6694 /* Check string lengths if applicable. The check is only really added
6695 to the output code if -fbounds-check is enabled. */
6696 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
6697 {
6698 gcc_assert (expr2->ts.type == BT_CHARACTER);
6699 gcc_assert (strlen_lhs && strlen_rhs);
6700 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
6701 strlen_lhs, strlen_rhs, &block);
6702 }
6703
6704 /* If rank remapping was done, check with -fcheck=bounds that
6705 the target is at least as large as the pointer. */
6706 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
6707 {
6708 tree lsize, rsize;
6709 tree fault;
6710 const char* msg;
6711
6712 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
6713 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
6714
6715 lsize = gfc_evaluate_now (lsize, &block);
6716 rsize = gfc_evaluate_now (rsize, &block);
6717 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6718 rsize, lsize);
6719
6720 msg = _("Target of rank remapping is too small (%ld < %ld)");
6721 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
6722 msg, rsize, lsize);
6723 }
6724
6725 gfc_add_block_to_block (&block, &lse.post);
6726 if (rank_remap)
6727 gfc_add_block_to_block (&block, &rse.post);
6728 }
6729
6730 return gfc_finish_block (&block);
6731 }
6732
6733
6734 /* Makes sure se is suitable for passing as a function string parameter. */
6735 /* TODO: Need to check all callers of this function. It may be abused. */
6736
6737 void
gfc_conv_string_parameter(gfc_se * se)6738 gfc_conv_string_parameter (gfc_se * se)
6739 {
6740 tree type;
6741
6742 if (TREE_CODE (se->expr) == STRING_CST)
6743 {
6744 type = TREE_TYPE (TREE_TYPE (se->expr));
6745 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
6746 return;
6747 }
6748
6749 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
6750 {
6751 if (TREE_CODE (se->expr) != INDIRECT_REF)
6752 {
6753 type = TREE_TYPE (se->expr);
6754 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
6755 }
6756 else
6757 {
6758 type = gfc_get_character_type_len (gfc_default_character_kind,
6759 se->string_length);
6760 type = build_pointer_type (type);
6761 se->expr = gfc_build_addr_expr (type, se->expr);
6762 }
6763 }
6764
6765 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
6766 }
6767
6768
6769 /* Generate code for assignment of scalar variables. Includes character
6770 strings and derived types with allocatable components.
6771 If you know that the LHS has no allocations, set dealloc to false.
6772
6773 DEEP_COPY has no effect if the typespec TS is not a derived type with
6774 allocatable components. Otherwise, if it is set, an explicit copy of each
6775 allocatable component is made. This is necessary as a simple copy of the
6776 whole object would copy array descriptors as is, so that the lhs's
6777 allocatable components would point to the rhs's after the assignment.
6778 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6779 necessary if the rhs is a non-pointer function, as the allocatable components
6780 are not accessible by other means than the function's result after the
6781 function has returned. It is even more subtle when temporaries are involved,
6782 as the two following examples show:
6783 1. When we evaluate an array constructor, a temporary is created. Thus
6784 there is theoretically no alias possible. However, no deep copy is
6785 made for this temporary, so that if the constructor is made of one or
6786 more variable with allocatable components, those components still point
6787 to the variable's: DEEP_COPY should be set for the assignment from the
6788 temporary to the lhs in that case.
6789 2. When assigning a scalar to an array, we evaluate the scalar value out
6790 of the loop, store it into a temporary variable, and assign from that.
6791 In that case, deep copying when assigning to the temporary would be a
6792 waste of resources; however deep copies should happen when assigning from
6793 the temporary to each array element: again DEEP_COPY should be set for
6794 the assignment from the temporary to the lhs. */
6795
6796 tree
gfc_trans_scalar_assign(gfc_se * lse,gfc_se * rse,gfc_typespec ts,bool l_is_temp,bool deep_copy,bool dealloc)6797 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
6798 bool l_is_temp, bool deep_copy, bool dealloc)
6799 {
6800 stmtblock_t block;
6801 tree tmp;
6802 tree cond;
6803
6804 gfc_init_block (&block);
6805
6806 if (ts.type == BT_CHARACTER)
6807 {
6808 tree rlen = NULL;
6809 tree llen = NULL;
6810
6811 if (lse->string_length != NULL_TREE)
6812 {
6813 gfc_conv_string_parameter (lse);
6814 gfc_add_block_to_block (&block, &lse->pre);
6815 llen = lse->string_length;
6816 }
6817
6818 if (rse->string_length != NULL_TREE)
6819 {
6820 gcc_assert (rse->string_length != NULL_TREE);
6821 gfc_conv_string_parameter (rse);
6822 gfc_add_block_to_block (&block, &rse->pre);
6823 rlen = rse->string_length;
6824 }
6825
6826 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
6827 rse->expr, ts.kind);
6828 }
6829 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
6830 {
6831 cond = NULL_TREE;
6832
6833 /* Are the rhs and the lhs the same? */
6834 if (deep_copy)
6835 {
6836 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6837 gfc_build_addr_expr (NULL_TREE, lse->expr),
6838 gfc_build_addr_expr (NULL_TREE, rse->expr));
6839 cond = gfc_evaluate_now (cond, &lse->pre);
6840 }
6841
6842 /* Deallocate the lhs allocated components as long as it is not
6843 the same as the rhs. This must be done following the assignment
6844 to prevent deallocating data that could be used in the rhs
6845 expression. */
6846 if (!l_is_temp && dealloc)
6847 {
6848 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
6849 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
6850 if (deep_copy)
6851 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
6852 tmp);
6853 gfc_add_expr_to_block (&lse->post, tmp);
6854 }
6855
6856 gfc_add_block_to_block (&block, &rse->pre);
6857 gfc_add_block_to_block (&block, &lse->pre);
6858
6859 gfc_add_modify (&block, lse->expr,
6860 fold_convert (TREE_TYPE (lse->expr), rse->expr));
6861
6862 /* Do a deep copy if the rhs is a variable, if it is not the
6863 same as the lhs. */
6864 if (deep_copy)
6865 {
6866 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
6867 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
6868 tmp);
6869 gfc_add_expr_to_block (&block, tmp);
6870 }
6871 }
6872 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
6873 {
6874 gfc_add_block_to_block (&block, &lse->pre);
6875 gfc_add_block_to_block (&block, &rse->pre);
6876 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
6877 TREE_TYPE (lse->expr), rse->expr);
6878 gfc_add_modify (&block, lse->expr, tmp);
6879 }
6880 else
6881 {
6882 gfc_add_block_to_block (&block, &lse->pre);
6883 gfc_add_block_to_block (&block, &rse->pre);
6884
6885 gfc_add_modify (&block, lse->expr,
6886 fold_convert (TREE_TYPE (lse->expr), rse->expr));
6887 }
6888
6889 gfc_add_block_to_block (&block, &lse->post);
6890 gfc_add_block_to_block (&block, &rse->post);
6891
6892 return gfc_finish_block (&block);
6893 }
6894
6895
6896 /* There are quite a lot of restrictions on the optimisation in using an
6897 array function assign without a temporary. */
6898
6899 static bool
arrayfunc_assign_needs_temporary(gfc_expr * expr1,gfc_expr * expr2)6900 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
6901 {
6902 gfc_ref * ref;
6903 bool seen_array_ref;
6904 bool c = false;
6905 gfc_symbol *sym = expr1->symtree->n.sym;
6906
6907 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6908 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
6909 return true;
6910
6911 /* Elemental functions are scalarized so that they don't need a
6912 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6913 they would need special treatment in gfc_trans_arrayfunc_assign. */
6914 if (expr2->value.function.esym != NULL
6915 && expr2->value.function.esym->attr.elemental)
6916 return true;
6917
6918 /* Need a temporary if rhs is not FULL or a contiguous section. */
6919 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
6920 return true;
6921
6922 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6923 if (gfc_ref_needs_temporary_p (expr1->ref))
6924 return true;
6925
6926 /* Functions returning pointers or allocatables need temporaries. */
6927 c = expr2->value.function.esym
6928 ? (expr2->value.function.esym->attr.pointer
6929 || expr2->value.function.esym->attr.allocatable)
6930 : (expr2->symtree->n.sym->attr.pointer
6931 || expr2->symtree->n.sym->attr.allocatable);
6932 if (c)
6933 return true;
6934
6935 /* Character array functions need temporaries unless the
6936 character lengths are the same. */
6937 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
6938 {
6939 if (expr1->ts.u.cl->length == NULL
6940 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6941 return true;
6942
6943 if (expr2->ts.u.cl->length == NULL
6944 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6945 return true;
6946
6947 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
6948 expr2->ts.u.cl->length->value.integer) != 0)
6949 return true;
6950 }
6951
6952 /* Check that no LHS component references appear during an array
6953 reference. This is needed because we do not have the means to
6954 span any arbitrary stride with an array descriptor. This check
6955 is not needed for the rhs because the function result has to be
6956 a complete type. */
6957 seen_array_ref = false;
6958 for (ref = expr1->ref; ref; ref = ref->next)
6959 {
6960 if (ref->type == REF_ARRAY)
6961 seen_array_ref= true;
6962 else if (ref->type == REF_COMPONENT && seen_array_ref)
6963 return true;
6964 }
6965
6966 /* Check for a dependency. */
6967 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
6968 expr2->value.function.esym,
6969 expr2->value.function.actual,
6970 NOT_ELEMENTAL))
6971 return true;
6972
6973 /* If we have reached here with an intrinsic function, we do not
6974 need a temporary except in the particular case that reallocation
6975 on assignment is active and the lhs is allocatable and a target. */
6976 if (expr2->value.function.isym)
6977 return (gfc_option.flag_realloc_lhs
6978 && sym->attr.allocatable
6979 && sym->attr.target);
6980
6981 /* If the LHS is a dummy, we need a temporary if it is not
6982 INTENT(OUT). */
6983 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
6984 return true;
6985
6986 /* If the lhs has been host_associated, is in common, a pointer or is
6987 a target and the function is not using a RESULT variable, aliasing
6988 can occur and a temporary is needed. */
6989 if ((sym->attr.host_assoc
6990 || sym->attr.in_common
6991 || sym->attr.pointer
6992 || sym->attr.cray_pointee
6993 || sym->attr.target)
6994 && expr2->symtree != NULL
6995 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
6996 return true;
6997
6998 /* A PURE function can unconditionally be called without a temporary. */
6999 if (expr2->value.function.esym != NULL
7000 && expr2->value.function.esym->attr.pure)
7001 return false;
7002
7003 /* Implicit_pure functions are those which could legally be declared
7004 to be PURE. */
7005 if (expr2->value.function.esym != NULL
7006 && expr2->value.function.esym->attr.implicit_pure)
7007 return false;
7008
7009 if (!sym->attr.use_assoc
7010 && !sym->attr.in_common
7011 && !sym->attr.pointer
7012 && !sym->attr.target
7013 && !sym->attr.cray_pointee
7014 && expr2->value.function.esym)
7015 {
7016 /* A temporary is not needed if the function is not contained and
7017 the variable is local or host associated and not a pointer or
7018 a target. */
7019 if (!expr2->value.function.esym->attr.contained)
7020 return false;
7021
7022 /* A temporary is not needed if the lhs has never been host
7023 associated and the procedure is contained. */
7024 else if (!sym->attr.host_assoc)
7025 return false;
7026
7027 /* A temporary is not needed if the variable is local and not
7028 a pointer, a target or a result. */
7029 if (sym->ns->parent
7030 && expr2->value.function.esym->ns == sym->ns->parent)
7031 return false;
7032 }
7033
7034 /* Default to temporary use. */
7035 return true;
7036 }
7037
7038
7039 /* Provide the loop info so that the lhs descriptor can be built for
7040 reallocatable assignments from extrinsic function calls. */
7041
7042 static void
realloc_lhs_loop_for_fcn_call(gfc_se * se,locus * where,gfc_ss ** ss,gfc_loopinfo * loop)7043 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
7044 gfc_loopinfo *loop)
7045 {
7046 /* Signal that the function call should not be made by
7047 gfc_conv_loop_setup. */
7048 se->ss->is_alloc_lhs = 1;
7049 gfc_init_loopinfo (loop);
7050 gfc_add_ss_to_loop (loop, *ss);
7051 gfc_add_ss_to_loop (loop, se->ss);
7052 gfc_conv_ss_startstride (loop);
7053 gfc_conv_loop_setup (loop, where);
7054 gfc_copy_loopinfo_to_se (se, loop);
7055 gfc_add_block_to_block (&se->pre, &loop->pre);
7056 gfc_add_block_to_block (&se->pre, &loop->post);
7057 se->ss->is_alloc_lhs = 0;
7058 }
7059
7060
7061 /* For assignment to a reallocatable lhs from intrinsic functions,
7062 replace the se.expr (ie. the result) with a temporary descriptor.
7063 Null the data field so that the library allocates space for the
7064 result. Free the data of the original descriptor after the function,
7065 in case it appears in an argument expression and transfer the
7066 result to the original descriptor. */
7067
7068 static void
fcncall_realloc_result(gfc_se * se,int rank)7069 fcncall_realloc_result (gfc_se *se, int rank)
7070 {
7071 tree desc;
7072 tree res_desc;
7073 tree tmp;
7074 tree offset;
7075 tree zero_cond;
7076 int n;
7077
7078 /* Use the allocation done by the library. Substitute the lhs
7079 descriptor with a copy, whose data field is nulled.*/
7080 desc = build_fold_indirect_ref_loc (input_location, se->expr);
7081 if (POINTER_TYPE_P (TREE_TYPE (desc)))
7082 desc = build_fold_indirect_ref_loc (input_location, desc);
7083
7084 /* Unallocated, the descriptor does not have a dtype. */
7085 tmp = gfc_conv_descriptor_dtype (desc);
7086 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7087
7088 res_desc = gfc_evaluate_now (desc, &se->pre);
7089 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
7090 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
7091
7092 /* Free the lhs after the function call and copy the result data to
7093 the lhs descriptor. */
7094 tmp = gfc_conv_descriptor_data_get (desc);
7095 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
7096 boolean_type_node, tmp,
7097 build_int_cst (TREE_TYPE (tmp), 0));
7098 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
7099 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
7100 gfc_add_expr_to_block (&se->post, tmp);
7101
7102 tmp = gfc_conv_descriptor_data_get (res_desc);
7103 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
7104
7105 /* Check that the shapes are the same between lhs and expression. */
7106 for (n = 0 ; n < rank; n++)
7107 {
7108 tree tmp1;
7109 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7110 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
7111 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7112 gfc_array_index_type, tmp, tmp1);
7113 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7114 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7115 gfc_array_index_type, tmp, tmp1);
7116 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
7117 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7118 gfc_array_index_type, tmp, tmp1);
7119 tmp = fold_build2_loc (input_location, NE_EXPR,
7120 boolean_type_node, tmp,
7121 gfc_index_zero_node);
7122 tmp = gfc_evaluate_now (tmp, &se->post);
7123 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7124 boolean_type_node, tmp,
7125 zero_cond);
7126 }
7127
7128 /* 'zero_cond' being true is equal to lhs not being allocated or the
7129 shapes being different. */
7130 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
7131
7132 /* Now reset the bounds returned from the function call to bounds based
7133 on the lhs lbounds, except where the lhs is not allocated or the shapes
7134 of 'variable and 'expr' are different. Set the offset accordingly. */
7135 offset = gfc_index_zero_node;
7136 for (n = 0 ; n < rank; n++)
7137 {
7138 tree lbound;
7139
7140 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7141 lbound = fold_build3_loc (input_location, COND_EXPR,
7142 gfc_array_index_type, zero_cond,
7143 gfc_index_one_node, lbound);
7144 lbound = gfc_evaluate_now (lbound, &se->post);
7145
7146 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
7147 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7148 gfc_array_index_type, tmp, lbound);
7149 gfc_conv_descriptor_lbound_set (&se->post, desc,
7150 gfc_rank_cst[n], lbound);
7151 gfc_conv_descriptor_ubound_set (&se->post, desc,
7152 gfc_rank_cst[n], tmp);
7153
7154 /* Set stride and accumulate the offset. */
7155 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
7156 gfc_conv_descriptor_stride_set (&se->post, desc,
7157 gfc_rank_cst[n], tmp);
7158 tmp = fold_build2_loc (input_location, MULT_EXPR,
7159 gfc_array_index_type, lbound, tmp);
7160 offset = fold_build2_loc (input_location, MINUS_EXPR,
7161 gfc_array_index_type, offset, tmp);
7162 offset = gfc_evaluate_now (offset, &se->post);
7163 }
7164
7165 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
7166 }
7167
7168
7169
7170 /* Try to translate array(:) = func (...), where func is a transformational
7171 array function, without using a temporary. Returns NULL if this isn't the
7172 case. */
7173
7174 static tree
gfc_trans_arrayfunc_assign(gfc_expr * expr1,gfc_expr * expr2)7175 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
7176 {
7177 gfc_se se;
7178 gfc_ss *ss = NULL;
7179 gfc_component *comp = NULL;
7180 gfc_loopinfo loop;
7181
7182 if (arrayfunc_assign_needs_temporary (expr1, expr2))
7183 return NULL;
7184
7185 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7186 functions. */
7187 comp = gfc_get_proc_ptr_comp (expr2);
7188 gcc_assert (expr2->value.function.isym
7189 || (comp && comp->attr.dimension)
7190 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
7191 && expr2->value.function.esym->result->attr.dimension));
7192
7193 gfc_init_se (&se, NULL);
7194 gfc_start_block (&se.pre);
7195 se.want_pointer = 1;
7196
7197 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
7198
7199 if (expr1->ts.type == BT_DERIVED
7200 && expr1->ts.u.derived->attr.alloc_comp)
7201 {
7202 tree tmp;
7203 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
7204 expr1->rank);
7205 gfc_add_expr_to_block (&se.pre, tmp);
7206 }
7207
7208 se.direct_byref = 1;
7209 se.ss = gfc_walk_expr (expr2);
7210 gcc_assert (se.ss != gfc_ss_terminator);
7211
7212 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7213 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7214 Clearly, this cannot be done for an allocatable function result, since
7215 the shape of the result is unknown and, in any case, the function must
7216 correctly take care of the reallocation internally. For intrinsic
7217 calls, the array data is freed and the library takes care of allocation.
7218 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7219 to the library. */
7220 if (gfc_option.flag_realloc_lhs
7221 && gfc_is_reallocatable_lhs (expr1)
7222 && !gfc_expr_attr (expr1).codimension
7223 && !gfc_is_coindexed (expr1)
7224 && !(expr2->value.function.esym
7225 && expr2->value.function.esym->result->attr.allocatable))
7226 {
7227 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
7228
7229 if (!expr2->value.function.isym)
7230 {
7231 ss = gfc_walk_expr (expr1);
7232 gcc_assert (ss != gfc_ss_terminator);
7233
7234 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
7235 ss->is_alloc_lhs = 1;
7236 }
7237 else
7238 fcncall_realloc_result (&se, expr1->rank);
7239 }
7240
7241 gfc_conv_function_expr (&se, expr2);
7242 gfc_add_block_to_block (&se.pre, &se.post);
7243
7244 if (ss)
7245 gfc_cleanup_loop (&loop);
7246 else
7247 gfc_free_ss_chain (se.ss);
7248
7249 return gfc_finish_block (&se.pre);
7250 }
7251
7252
7253 /* Try to efficiently translate array(:) = 0. Return NULL if this
7254 can't be done. */
7255
7256 static tree
gfc_trans_zero_assign(gfc_expr * expr)7257 gfc_trans_zero_assign (gfc_expr * expr)
7258 {
7259 tree dest, len, type;
7260 tree tmp;
7261 gfc_symbol *sym;
7262
7263 sym = expr->symtree->n.sym;
7264 dest = gfc_get_symbol_decl (sym);
7265
7266 type = TREE_TYPE (dest);
7267 if (POINTER_TYPE_P (type))
7268 type = TREE_TYPE (type);
7269 if (!GFC_ARRAY_TYPE_P (type))
7270 return NULL_TREE;
7271
7272 /* Determine the length of the array. */
7273 len = GFC_TYPE_ARRAY_SIZE (type);
7274 if (!len || TREE_CODE (len) != INTEGER_CST)
7275 return NULL_TREE;
7276
7277 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
7278 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
7279 fold_convert (gfc_array_index_type, tmp));
7280
7281 /* If we are zeroing a local array avoid taking its address by emitting
7282 a = {} instead. */
7283 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
7284 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
7285 dest, build_constructor (TREE_TYPE (dest),
7286 NULL));
7287
7288 /* Convert arguments to the correct types. */
7289 dest = fold_convert (pvoid_type_node, dest);
7290 len = fold_convert (size_type_node, len);
7291
7292 /* Construct call to __builtin_memset. */
7293 tmp = build_call_expr_loc (input_location,
7294 builtin_decl_explicit (BUILT_IN_MEMSET),
7295 3, dest, integer_zero_node, len);
7296 return fold_convert (void_type_node, tmp);
7297 }
7298
7299
7300 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7301 that constructs the call to __builtin_memcpy. */
7302
7303 tree
gfc_build_memcpy_call(tree dst,tree src,tree len)7304 gfc_build_memcpy_call (tree dst, tree src, tree len)
7305 {
7306 tree tmp;
7307
7308 /* Convert arguments to the correct types. */
7309 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
7310 dst = gfc_build_addr_expr (pvoid_type_node, dst);
7311 else
7312 dst = fold_convert (pvoid_type_node, dst);
7313
7314 if (!POINTER_TYPE_P (TREE_TYPE (src)))
7315 src = gfc_build_addr_expr (pvoid_type_node, src);
7316 else
7317 src = fold_convert (pvoid_type_node, src);
7318
7319 len = fold_convert (size_type_node, len);
7320
7321 /* Construct call to __builtin_memcpy. */
7322 tmp = build_call_expr_loc (input_location,
7323 builtin_decl_explicit (BUILT_IN_MEMCPY),
7324 3, dst, src, len);
7325 return fold_convert (void_type_node, tmp);
7326 }
7327
7328
7329 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7330 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7331 source/rhs, both are gfc_full_array_ref_p which have been checked for
7332 dependencies. */
7333
7334 static tree
gfc_trans_array_copy(gfc_expr * expr1,gfc_expr * expr2)7335 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
7336 {
7337 tree dst, dlen, dtype;
7338 tree src, slen, stype;
7339 tree tmp;
7340
7341 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
7342 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
7343
7344 dtype = TREE_TYPE (dst);
7345 if (POINTER_TYPE_P (dtype))
7346 dtype = TREE_TYPE (dtype);
7347 stype = TREE_TYPE (src);
7348 if (POINTER_TYPE_P (stype))
7349 stype = TREE_TYPE (stype);
7350
7351 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
7352 return NULL_TREE;
7353
7354 /* Determine the lengths of the arrays. */
7355 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
7356 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
7357 return NULL_TREE;
7358 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
7359 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7360 dlen, fold_convert (gfc_array_index_type, tmp));
7361
7362 slen = GFC_TYPE_ARRAY_SIZE (stype);
7363 if (!slen || TREE_CODE (slen) != INTEGER_CST)
7364 return NULL_TREE;
7365 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
7366 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7367 slen, fold_convert (gfc_array_index_type, tmp));
7368
7369 /* Sanity check that they are the same. This should always be
7370 the case, as we should already have checked for conformance. */
7371 if (!tree_int_cst_equal (slen, dlen))
7372 return NULL_TREE;
7373
7374 return gfc_build_memcpy_call (dst, src, dlen);
7375 }
7376
7377
7378 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7379 this can't be done. EXPR1 is the destination/lhs for which
7380 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7381
7382 static tree
gfc_trans_array_constructor_copy(gfc_expr * expr1,gfc_expr * expr2)7383 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
7384 {
7385 unsigned HOST_WIDE_INT nelem;
7386 tree dst, dtype;
7387 tree src, stype;
7388 tree len;
7389 tree tmp;
7390
7391 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
7392 if (nelem == 0)
7393 return NULL_TREE;
7394
7395 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
7396 dtype = TREE_TYPE (dst);
7397 if (POINTER_TYPE_P (dtype))
7398 dtype = TREE_TYPE (dtype);
7399 if (!GFC_ARRAY_TYPE_P (dtype))
7400 return NULL_TREE;
7401
7402 /* Determine the lengths of the array. */
7403 len = GFC_TYPE_ARRAY_SIZE (dtype);
7404 if (!len || TREE_CODE (len) != INTEGER_CST)
7405 return NULL_TREE;
7406
7407 /* Confirm that the constructor is the same size. */
7408 if (compare_tree_int (len, nelem) != 0)
7409 return NULL_TREE;
7410
7411 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
7412 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
7413 fold_convert (gfc_array_index_type, tmp));
7414
7415 stype = gfc_typenode_for_spec (&expr2->ts);
7416 src = gfc_build_constant_array_constructor (expr2, stype);
7417
7418 stype = TREE_TYPE (src);
7419 if (POINTER_TYPE_P (stype))
7420 stype = TREE_TYPE (stype);
7421
7422 return gfc_build_memcpy_call (dst, src, len);
7423 }
7424
7425
7426 /* Tells whether the expression is to be treated as a variable reference. */
7427
7428 static bool
expr_is_variable(gfc_expr * expr)7429 expr_is_variable (gfc_expr *expr)
7430 {
7431 gfc_expr *arg;
7432 gfc_component *comp;
7433 gfc_symbol *func_ifc;
7434
7435 if (expr->expr_type == EXPR_VARIABLE)
7436 return true;
7437
7438 arg = gfc_get_noncopying_intrinsic_argument (expr);
7439 if (arg)
7440 {
7441 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
7442 return expr_is_variable (arg);
7443 }
7444
7445 /* A data-pointer-returning function should be considered as a variable
7446 too. */
7447 if (expr->expr_type == EXPR_FUNCTION
7448 && expr->ref == NULL)
7449 {
7450 if (expr->value.function.isym != NULL)
7451 return false;
7452
7453 if (expr->value.function.esym != NULL)
7454 {
7455 func_ifc = expr->value.function.esym;
7456 goto found_ifc;
7457 }
7458 else
7459 {
7460 gcc_assert (expr->symtree);
7461 func_ifc = expr->symtree->n.sym;
7462 goto found_ifc;
7463 }
7464
7465 gcc_unreachable ();
7466 }
7467
7468 comp = gfc_get_proc_ptr_comp (expr);
7469 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
7470 && comp)
7471 {
7472 func_ifc = comp->ts.interface;
7473 goto found_ifc;
7474 }
7475
7476 if (expr->expr_type == EXPR_COMPCALL)
7477 {
7478 gcc_assert (!expr->value.compcall.tbp->is_generic);
7479 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
7480 goto found_ifc;
7481 }
7482
7483 return false;
7484
7485 found_ifc:
7486 gcc_assert (func_ifc->attr.function
7487 && func_ifc->result != NULL);
7488 return func_ifc->result->attr.pointer;
7489 }
7490
7491
7492 /* Is the lhs OK for automatic reallocation? */
7493
7494 static bool
is_scalar_reallocatable_lhs(gfc_expr * expr)7495 is_scalar_reallocatable_lhs (gfc_expr *expr)
7496 {
7497 gfc_ref * ref;
7498
7499 /* An allocatable variable with no reference. */
7500 if (expr->symtree->n.sym->attr.allocatable
7501 && !expr->ref)
7502 return true;
7503
7504 /* All that can be left are allocatable components. */
7505 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7506 && expr->symtree->n.sym->ts.type != BT_CLASS)
7507 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7508 return false;
7509
7510 /* Find an allocatable component ref last. */
7511 for (ref = expr->ref; ref; ref = ref->next)
7512 if (ref->type == REF_COMPONENT
7513 && !ref->next
7514 && ref->u.c.component->attr.allocatable)
7515 return true;
7516
7517 return false;
7518 }
7519
7520
7521 /* Allocate or reallocate scalar lhs, as necessary. */
7522
7523 static void
alloc_scalar_allocatable_for_assignment(stmtblock_t * block,tree string_length,gfc_expr * expr1,gfc_expr * expr2)7524 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
7525 tree string_length,
7526 gfc_expr *expr1,
7527 gfc_expr *expr2)
7528
7529 {
7530 tree cond;
7531 tree tmp;
7532 tree size;
7533 tree size_in_bytes;
7534 tree jump_label1;
7535 tree jump_label2;
7536 gfc_se lse;
7537
7538 if (!expr1 || expr1->rank)
7539 return;
7540
7541 if (!expr2 || expr2->rank)
7542 return;
7543
7544 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7545
7546 /* Since this is a scalar lhs, we can afford to do this. That is,
7547 there is no risk of side effects being repeated. */
7548 gfc_init_se (&lse, NULL);
7549 lse.want_pointer = 1;
7550 gfc_conv_expr (&lse, expr1);
7551
7552 jump_label1 = gfc_build_label_decl (NULL_TREE);
7553 jump_label2 = gfc_build_label_decl (NULL_TREE);
7554
7555 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7556 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
7557 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7558 lse.expr, tmp);
7559 tmp = build3_v (COND_EXPR, cond,
7560 build1_v (GOTO_EXPR, jump_label1),
7561 build_empty_stmt (input_location));
7562 gfc_add_expr_to_block (block, tmp);
7563
7564 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7565 {
7566 /* Use the rhs string length and the lhs element size. */
7567 size = string_length;
7568 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
7569 tmp = TYPE_SIZE_UNIT (tmp);
7570 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7571 TREE_TYPE (tmp), tmp,
7572 fold_convert (TREE_TYPE (tmp), size));
7573 }
7574 else
7575 {
7576 /* Otherwise use the length in bytes of the rhs. */
7577 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7578 size_in_bytes = size;
7579 }
7580
7581 if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
7582 {
7583 tmp = build_call_expr_loc (input_location,
7584 builtin_decl_explicit (BUILT_IN_CALLOC),
7585 2, build_one_cst (size_type_node),
7586 size_in_bytes);
7587 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
7588 gfc_add_modify (block, lse.expr, tmp);
7589 }
7590 else
7591 {
7592 tmp = build_call_expr_loc (input_location,
7593 builtin_decl_explicit (BUILT_IN_MALLOC),
7594 1, size_in_bytes);
7595 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
7596 gfc_add_modify (block, lse.expr, tmp);
7597 }
7598
7599 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7600 {
7601 /* Deferred characters need checking for lhs and rhs string
7602 length. Other deferred parameter variables will have to
7603 come here too. */
7604 tmp = build1_v (GOTO_EXPR, jump_label2);
7605 gfc_add_expr_to_block (block, tmp);
7606 }
7607 tmp = build1_v (LABEL_EXPR, jump_label1);
7608 gfc_add_expr_to_block (block, tmp);
7609
7610 /* For a deferred length character, reallocate if lengths of lhs and
7611 rhs are different. */
7612 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7613 {
7614 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7615 expr1->ts.u.cl->backend_decl, size);
7616 /* Jump past the realloc if the lengths are the same. */
7617 tmp = build3_v (COND_EXPR, cond,
7618 build1_v (GOTO_EXPR, jump_label2),
7619 build_empty_stmt (input_location));
7620 gfc_add_expr_to_block (block, tmp);
7621 tmp = build_call_expr_loc (input_location,
7622 builtin_decl_explicit (BUILT_IN_REALLOC),
7623 2, fold_convert (pvoid_type_node, lse.expr),
7624 size_in_bytes);
7625 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
7626 gfc_add_modify (block, lse.expr, tmp);
7627 tmp = build1_v (LABEL_EXPR, jump_label2);
7628 gfc_add_expr_to_block (block, tmp);
7629
7630 /* Update the lhs character length. */
7631 size = string_length;
7632 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
7633 }
7634 }
7635
7636
7637 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7638 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7639 init_flag indicates initialization expressions and dealloc that no
7640 deallocate prior assignment is needed (if in doubt, set true). */
7641
7642 static tree
gfc_trans_assignment_1(gfc_expr * expr1,gfc_expr * expr2,bool init_flag,bool dealloc)7643 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
7644 bool dealloc)
7645 {
7646 gfc_se lse;
7647 gfc_se rse;
7648 gfc_ss *lss;
7649 gfc_ss *lss_section;
7650 gfc_ss *rss;
7651 gfc_loopinfo loop;
7652 tree tmp;
7653 stmtblock_t block;
7654 stmtblock_t body;
7655 bool l_is_temp;
7656 bool scalar_to_array;
7657 tree string_length;
7658 int n;
7659
7660 /* Assignment of the form lhs = rhs. */
7661 gfc_start_block (&block);
7662
7663 gfc_init_se (&lse, NULL);
7664 gfc_init_se (&rse, NULL);
7665
7666 /* Walk the lhs. */
7667 lss = gfc_walk_expr (expr1);
7668 if (gfc_is_reallocatable_lhs (expr1)
7669 && !(expr2->expr_type == EXPR_FUNCTION
7670 && expr2->value.function.isym != NULL))
7671 lss->is_alloc_lhs = 1;
7672 rss = NULL;
7673 if (lss != gfc_ss_terminator)
7674 {
7675 /* The assignment needs scalarization. */
7676 lss_section = lss;
7677
7678 /* Find a non-scalar SS from the lhs. */
7679 while (lss_section != gfc_ss_terminator
7680 && lss_section->info->type != GFC_SS_SECTION)
7681 lss_section = lss_section->next;
7682
7683 gcc_assert (lss_section != gfc_ss_terminator);
7684
7685 /* Initialize the scalarizer. */
7686 gfc_init_loopinfo (&loop);
7687
7688 /* Walk the rhs. */
7689 rss = gfc_walk_expr (expr2);
7690 if (rss == gfc_ss_terminator)
7691 /* The rhs is scalar. Add a ss for the expression. */
7692 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
7693
7694 /* Associate the SS with the loop. */
7695 gfc_add_ss_to_loop (&loop, lss);
7696 gfc_add_ss_to_loop (&loop, rss);
7697
7698 /* Calculate the bounds of the scalarization. */
7699 gfc_conv_ss_startstride (&loop);
7700 /* Enable loop reversal. */
7701 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
7702 loop.reverse[n] = GFC_ENABLE_REVERSE;
7703 /* Resolve any data dependencies in the statement. */
7704 gfc_conv_resolve_dependencies (&loop, lss, rss);
7705 /* Setup the scalarizing loops. */
7706 gfc_conv_loop_setup (&loop, &expr2->where);
7707
7708 /* Setup the gfc_se structures. */
7709 gfc_copy_loopinfo_to_se (&lse, &loop);
7710 gfc_copy_loopinfo_to_se (&rse, &loop);
7711
7712 rse.ss = rss;
7713 gfc_mark_ss_chain_used (rss, 1);
7714 if (loop.temp_ss == NULL)
7715 {
7716 lse.ss = lss;
7717 gfc_mark_ss_chain_used (lss, 1);
7718 }
7719 else
7720 {
7721 lse.ss = loop.temp_ss;
7722 gfc_mark_ss_chain_used (lss, 3);
7723 gfc_mark_ss_chain_used (loop.temp_ss, 3);
7724 }
7725
7726 /* Allow the scalarizer to workshare array assignments. */
7727 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
7728 ompws_flags |= OMPWS_SCALARIZER_WS;
7729
7730 /* Start the scalarized loop body. */
7731 gfc_start_scalarized_body (&loop, &body);
7732 }
7733 else
7734 gfc_init_block (&body);
7735
7736 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
7737
7738 /* Translate the expression. */
7739 gfc_conv_expr (&rse, expr2);
7740
7741 /* Stabilize a string length for temporaries. */
7742 if (expr2->ts.type == BT_CHARACTER)
7743 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
7744 else
7745 string_length = NULL_TREE;
7746
7747 if (l_is_temp)
7748 {
7749 gfc_conv_tmp_array_ref (&lse);
7750 if (expr2->ts.type == BT_CHARACTER)
7751 lse.string_length = string_length;
7752 }
7753 else
7754 gfc_conv_expr (&lse, expr1);
7755
7756 /* Assignments of scalar derived types with allocatable components
7757 to arrays must be done with a deep copy and the rhs temporary
7758 must have its components deallocated afterwards. */
7759 scalar_to_array = (expr2->ts.type == BT_DERIVED
7760 && expr2->ts.u.derived->attr.alloc_comp
7761 && !expr_is_variable (expr2)
7762 && !gfc_is_constant_expr (expr2)
7763 && expr1->rank && !expr2->rank);
7764 if (scalar_to_array && dealloc)
7765 {
7766 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
7767 gfc_add_expr_to_block (&loop.post, tmp);
7768 }
7769
7770 /* When assigning a character function result to a deferred-length variable,
7771 the function call must happen before the (re)allocation of the lhs -
7772 otherwise the character length of the result is not known.
7773 NOTE: This relies on having the exact dependence of the length type
7774 parameter available to the caller; gfortran saves it in the .mod files. */
7775 if (gfc_option.flag_realloc_lhs && expr2->ts.type == BT_CHARACTER
7776 && expr1->ts.deferred)
7777 gfc_add_block_to_block (&block, &rse.pre);
7778
7779 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
7780 l_is_temp || init_flag,
7781 expr_is_variable (expr2) || scalar_to_array
7782 || expr2->expr_type == EXPR_ARRAY, dealloc);
7783 gfc_add_expr_to_block (&body, tmp);
7784
7785 if (lss == gfc_ss_terminator)
7786 {
7787 /* F2003: Add the code for reallocation on assignment. */
7788 if (gfc_option.flag_realloc_lhs
7789 && is_scalar_reallocatable_lhs (expr1))
7790 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
7791 expr1, expr2);
7792
7793 /* Use the scalar assignment as is. */
7794 gfc_add_block_to_block (&block, &body);
7795 }
7796 else
7797 {
7798 gcc_assert (lse.ss == gfc_ss_terminator
7799 && rse.ss == gfc_ss_terminator);
7800
7801 if (l_is_temp)
7802 {
7803 gfc_trans_scalarized_loop_boundary (&loop, &body);
7804
7805 /* We need to copy the temporary to the actual lhs. */
7806 gfc_init_se (&lse, NULL);
7807 gfc_init_se (&rse, NULL);
7808 gfc_copy_loopinfo_to_se (&lse, &loop);
7809 gfc_copy_loopinfo_to_se (&rse, &loop);
7810
7811 rse.ss = loop.temp_ss;
7812 lse.ss = lss;
7813
7814 gfc_conv_tmp_array_ref (&rse);
7815 gfc_conv_expr (&lse, expr1);
7816
7817 gcc_assert (lse.ss == gfc_ss_terminator
7818 && rse.ss == gfc_ss_terminator);
7819
7820 if (expr2->ts.type == BT_CHARACTER)
7821 rse.string_length = string_length;
7822
7823 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
7824 false, false, dealloc);
7825 gfc_add_expr_to_block (&body, tmp);
7826 }
7827
7828 /* F2003: Allocate or reallocate lhs of allocatable array. */
7829 if (gfc_option.flag_realloc_lhs
7830 && gfc_is_reallocatable_lhs (expr1)
7831 && !gfc_expr_attr (expr1).codimension
7832 && !gfc_is_coindexed (expr1)
7833 && expr2->rank)
7834 {
7835 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
7836 ompws_flags &= ~OMPWS_SCALARIZER_WS;
7837 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
7838 if (tmp != NULL_TREE)
7839 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
7840 }
7841
7842 /* Generate the copying loops. */
7843 gfc_trans_scalarizing_loops (&loop, &body);
7844
7845 /* Wrap the whole thing up. */
7846 gfc_add_block_to_block (&block, &loop.pre);
7847 gfc_add_block_to_block (&block, &loop.post);
7848
7849 gfc_cleanup_loop (&loop);
7850 }
7851
7852 return gfc_finish_block (&block);
7853 }
7854
7855
7856 /* Check whether EXPR is a copyable array. */
7857
7858 static bool
copyable_array_p(gfc_expr * expr)7859 copyable_array_p (gfc_expr * expr)
7860 {
7861 if (expr->expr_type != EXPR_VARIABLE)
7862 return false;
7863
7864 /* First check it's an array. */
7865 if (expr->rank < 1 || !expr->ref || expr->ref->next)
7866 return false;
7867
7868 if (!gfc_full_array_ref_p (expr->ref, NULL))
7869 return false;
7870
7871 /* Next check that it's of a simple enough type. */
7872 switch (expr->ts.type)
7873 {
7874 case BT_INTEGER:
7875 case BT_REAL:
7876 case BT_COMPLEX:
7877 case BT_LOGICAL:
7878 return true;
7879
7880 case BT_CHARACTER:
7881 return false;
7882
7883 case BT_DERIVED:
7884 return !expr->ts.u.derived->attr.alloc_comp;
7885
7886 default:
7887 break;
7888 }
7889
7890 return false;
7891 }
7892
7893 /* Translate an assignment. */
7894
7895 tree
gfc_trans_assignment(gfc_expr * expr1,gfc_expr * expr2,bool init_flag,bool dealloc)7896 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
7897 bool dealloc)
7898 {
7899 tree tmp;
7900
7901 /* Special case a single function returning an array. */
7902 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
7903 {
7904 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
7905 if (tmp)
7906 return tmp;
7907 }
7908
7909 /* Special case assigning an array to zero. */
7910 if (copyable_array_p (expr1)
7911 && is_zero_initializer_p (expr2))
7912 {
7913 tmp = gfc_trans_zero_assign (expr1);
7914 if (tmp)
7915 return tmp;
7916 }
7917
7918 /* Special case copying one array to another. */
7919 if (copyable_array_p (expr1)
7920 && copyable_array_p (expr2)
7921 && gfc_compare_types (&expr1->ts, &expr2->ts)
7922 && !gfc_check_dependency (expr1, expr2, 0))
7923 {
7924 tmp = gfc_trans_array_copy (expr1, expr2);
7925 if (tmp)
7926 return tmp;
7927 }
7928
7929 /* Special case initializing an array from a constant array constructor. */
7930 if (copyable_array_p (expr1)
7931 && expr2->expr_type == EXPR_ARRAY
7932 && gfc_compare_types (&expr1->ts, &expr2->ts))
7933 {
7934 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
7935 if (tmp)
7936 return tmp;
7937 }
7938
7939 /* Fallback to the scalarizer to generate explicit loops. */
7940 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
7941 }
7942
7943 tree
gfc_trans_init_assign(gfc_code * code)7944 gfc_trans_init_assign (gfc_code * code)
7945 {
7946 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
7947 }
7948
7949 tree
gfc_trans_assign(gfc_code * code)7950 gfc_trans_assign (gfc_code * code)
7951 {
7952 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
7953 }
7954