* ggc.h (empty_string): Delete.
[official-gcc.git] / gcc / fortran / trans-expr.c
blobacd0428eae6bf563b0e62a8afc0ad5119c6364a6
1 /* Expression translation
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
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.
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.
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/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "options.h"
28 #include "tree.h"
29 #include "gfortran.h"
30 #include "trans.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
35 #include "arith.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
43 #include "gimplify.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
46 arrays. */
48 static tree
49 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
51 enum gfc_array_kind akind;
53 if (attr.pointer)
54 akind = GFC_ARRAY_POINTER_CONT;
55 else if (attr.allocatable)
56 akind = GFC_ARRAY_ALLOCATABLE;
57 else
58 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar)))
61 scalar = TREE_TYPE (scalar);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
63 akind, !(attr.pointer || attr.target));
66 tree
67 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
69 tree desc, type;
71 type = get_scalar_to_descriptor_type (scalar, attr);
72 desc = gfc_create_var (type, "desc");
73 DECL_ARTIFICIAL (desc) = 1;
75 if (CONSTANT_CLASS_P (scalar))
77 tree tmp;
78 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
79 gfc_add_modify (&se->pre, tmp, scalar);
80 scalar = tmp;
82 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
83 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
84 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
85 gfc_get_dtype (type));
86 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
88 /* Copy pointer address back - but only if it could have changed and
89 if the actual argument is a pointer and not, e.g., NULL(). */
90 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
91 gfc_add_modify (&se->post, scalar,
92 fold_convert (TREE_TYPE (scalar),
93 gfc_conv_descriptor_data_get (desc)));
94 return desc;
98 /* Get the coarray token from the ultimate array or component ref.
99 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
101 tree
102 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
104 gfc_symbol *sym = expr->symtree->n.sym;
105 bool is_coarray = sym->attr.codimension;
106 gfc_expr *caf_expr = gfc_copy_expr (expr);
107 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
109 while (ref)
111 if (ref->type == REF_COMPONENT
112 && (ref->u.c.component->attr.allocatable
113 || ref->u.c.component->attr.pointer)
114 && (is_coarray || ref->u.c.component->attr.codimension))
115 last_caf_ref = ref;
116 ref = ref->next;
119 if (last_caf_ref == NULL)
120 return NULL_TREE;
122 tree comp = last_caf_ref->u.c.component->caf_token, caf;
123 gfc_se se;
124 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
125 if (comp == NULL_TREE && comp_ref)
126 return NULL_TREE;
127 gfc_init_se (&se, outerse);
128 gfc_free_ref_list (last_caf_ref->next);
129 last_caf_ref->next = NULL;
130 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
131 se.want_pointer = comp_ref;
132 gfc_conv_expr (&se, caf_expr);
133 gfc_add_block_to_block (&outerse->pre, &se.pre);
135 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
136 se.expr = TREE_OPERAND (se.expr, 0);
137 gfc_free_expr (caf_expr);
139 if (comp_ref)
140 caf = fold_build3_loc (input_location, COMPONENT_REF,
141 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
142 else
143 caf = gfc_conv_descriptor_token (se.expr);
144 return gfc_build_addr_expr (NULL_TREE, caf);
148 /* This is the seed for an eventual trans-class.c
150 The following parameters should not be used directly since they might
151 in future implementations. Use the corresponding APIs. */
152 #define CLASS_DATA_FIELD 0
153 #define CLASS_VPTR_FIELD 1
154 #define CLASS_LEN_FIELD 2
155 #define VTABLE_HASH_FIELD 0
156 #define VTABLE_SIZE_FIELD 1
157 #define VTABLE_EXTENDS_FIELD 2
158 #define VTABLE_DEF_INIT_FIELD 3
159 #define VTABLE_COPY_FIELD 4
160 #define VTABLE_FINAL_FIELD 5
161 #define VTABLE_DEALLOCATE_FIELD 6
164 tree
165 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
167 tree tmp;
168 tree field;
169 vec<constructor_elt, va_gc> *init = NULL;
171 field = TYPE_FIELDS (TREE_TYPE (decl));
172 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
173 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
175 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
178 return build_constructor (TREE_TYPE (decl), init);
182 tree
183 gfc_class_data_get (tree decl)
185 tree data;
186 if (POINTER_TYPE_P (TREE_TYPE (decl)))
187 decl = build_fold_indirect_ref_loc (input_location, decl);
188 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
189 CLASS_DATA_FIELD);
190 return fold_build3_loc (input_location, COMPONENT_REF,
191 TREE_TYPE (data), decl, data,
192 NULL_TREE);
196 tree
197 gfc_class_vptr_get (tree decl)
199 tree vptr;
200 /* For class arrays decl may be a temporary descriptor handle, the vptr is
201 then available through the saved descriptor. */
202 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
203 && GFC_DECL_SAVED_DESCRIPTOR (decl))
204 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
205 if (POINTER_TYPE_P (TREE_TYPE (decl)))
206 decl = build_fold_indirect_ref_loc (input_location, decl);
207 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
208 CLASS_VPTR_FIELD);
209 return fold_build3_loc (input_location, COMPONENT_REF,
210 TREE_TYPE (vptr), decl, vptr,
211 NULL_TREE);
215 tree
216 gfc_class_len_get (tree decl)
218 tree len;
219 /* For class arrays decl may be a temporary descriptor handle, the len is
220 then available through the saved descriptor. */
221 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
222 && GFC_DECL_SAVED_DESCRIPTOR (decl))
223 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
224 if (POINTER_TYPE_P (TREE_TYPE (decl)))
225 decl = build_fold_indirect_ref_loc (input_location, decl);
226 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
227 CLASS_LEN_FIELD);
228 return fold_build3_loc (input_location, COMPONENT_REF,
229 TREE_TYPE (len), decl, len,
230 NULL_TREE);
234 /* Try to get the _len component of a class. When the class is not unlimited
235 poly, i.e. no _len field exists, then return a zero node. */
237 tree
238 gfc_class_len_or_zero_get (tree decl)
240 tree len;
241 /* For class arrays decl may be a temporary descriptor handle, the vptr is
242 then available through the saved descriptor. */
243 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
244 && GFC_DECL_SAVED_DESCRIPTOR (decl))
245 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
246 if (POINTER_TYPE_P (TREE_TYPE (decl)))
247 decl = build_fold_indirect_ref_loc (input_location, decl);
248 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
249 CLASS_LEN_FIELD);
250 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
251 TREE_TYPE (len), decl, len,
252 NULL_TREE)
253 : integer_zero_node;
257 /* Get the specified FIELD from the VPTR. */
259 static tree
260 vptr_field_get (tree vptr, int fieldno)
262 tree field;
263 vptr = build_fold_indirect_ref_loc (input_location, vptr);
264 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
265 fieldno);
266 field = fold_build3_loc (input_location, COMPONENT_REF,
267 TREE_TYPE (field), vptr, field,
268 NULL_TREE);
269 gcc_assert (field);
270 return field;
274 /* Get the field from the class' vptr. */
276 static tree
277 class_vtab_field_get (tree decl, int fieldno)
279 tree vptr;
280 vptr = gfc_class_vptr_get (decl);
281 return vptr_field_get (vptr, fieldno);
285 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
286 unison. */
287 #define VTAB_GET_FIELD_GEN(name, field) tree \
288 gfc_class_vtab_## name ##_get (tree cl) \
290 return class_vtab_field_get (cl, field); \
293 tree \
294 gfc_vptr_## name ##_get (tree vptr) \
296 return vptr_field_get (vptr, field); \
299 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
300 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
301 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
302 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
303 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
304 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
307 /* The size field is returned as an array index type. Therefore treat
308 it and only it specially. */
310 tree
311 gfc_class_vtab_size_get (tree cl)
313 tree size;
314 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
315 /* Always return size as an array index type. */
316 size = fold_convert (gfc_array_index_type, size);
317 gcc_assert (size);
318 return size;
321 tree
322 gfc_vptr_size_get (tree vptr)
324 tree size;
325 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
326 /* Always return size as an array index type. */
327 size = fold_convert (gfc_array_index_type, size);
328 gcc_assert (size);
329 return size;
333 #undef CLASS_DATA_FIELD
334 #undef CLASS_VPTR_FIELD
335 #undef CLASS_LEN_FIELD
336 #undef VTABLE_HASH_FIELD
337 #undef VTABLE_SIZE_FIELD
338 #undef VTABLE_EXTENDS_FIELD
339 #undef VTABLE_DEF_INIT_FIELD
340 #undef VTABLE_COPY_FIELD
341 #undef VTABLE_FINAL_FIELD
344 /* Search for the last _class ref in the chain of references of this
345 expression and cut the chain there. Albeit this routine is similiar
346 to class.c::gfc_add_component_ref (), is there a significant
347 difference: gfc_add_component_ref () concentrates on an array ref to
348 be the last ref in the chain. This routine is oblivious to the kind
349 of refs following. */
351 gfc_expr *
352 gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
354 gfc_expr *base_expr;
355 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
357 /* Find the last class reference. */
358 class_ref = NULL;
359 array_ref = NULL;
360 for (ref = e->ref; ref; ref = ref->next)
362 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
363 array_ref = ref;
365 if (ref->type == REF_COMPONENT
366 && ref->u.c.component->ts.type == BT_CLASS)
368 /* Component to the right of a part reference with nonzero rank
369 must not have the ALLOCATABLE attribute. If attempts are
370 made to reference such a component reference, an error results
371 followed by an ICE. */
372 if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
373 return NULL;
374 class_ref = ref;
377 if (ref->next == NULL)
378 break;
381 /* Remove and store all subsequent references after the
382 CLASS reference. */
383 if (class_ref)
385 tail = class_ref->next;
386 class_ref->next = NULL;
388 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
390 tail = e->ref;
391 e->ref = NULL;
394 base_expr = gfc_expr_to_initialize (e);
396 /* Restore the original tail expression. */
397 if (class_ref)
399 gfc_free_ref_list (class_ref->next);
400 class_ref->next = tail;
402 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
404 gfc_free_ref_list (e->ref);
405 e->ref = tail;
407 return base_expr;
411 /* Reset the vptr to the declared type, e.g. after deallocation. */
413 void
414 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
416 gfc_symbol *vtab;
417 tree vptr;
418 tree vtable;
419 gfc_se se;
421 /* Evaluate the expression and obtain the vptr from it. */
422 gfc_init_se (&se, NULL);
423 if (e->rank)
424 gfc_conv_expr_descriptor (&se, e);
425 else
426 gfc_conv_expr (&se, e);
427 gfc_add_block_to_block (block, &se.pre);
428 vptr = gfc_get_vptr_from_expr (se.expr);
430 /* If a vptr is not found, we can do nothing more. */
431 if (vptr == NULL_TREE)
432 return;
434 if (UNLIMITED_POLY (e))
435 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
436 else
438 /* Return the vptr to the address of the declared type. */
439 vtab = gfc_find_derived_vtab (e->ts.u.derived);
440 vtable = vtab->backend_decl;
441 if (vtable == NULL_TREE)
442 vtable = gfc_get_symbol_decl (vtab);
443 vtable = gfc_build_addr_expr (NULL, vtable);
444 vtable = fold_convert (TREE_TYPE (vptr), vtable);
445 gfc_add_modify (block, vptr, vtable);
450 /* Reset the len for unlimited polymorphic objects. */
452 void
453 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
455 gfc_expr *e;
456 gfc_se se_len;
457 e = gfc_find_and_cut_at_last_class_ref (expr);
458 if (e == NULL)
459 return;
460 gfc_add_len_component (e);
461 gfc_init_se (&se_len, NULL);
462 gfc_conv_expr (&se_len, e);
463 gfc_add_modify (block, se_len.expr,
464 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
465 gfc_free_expr (e);
469 /* Obtain the vptr of the last class reference in an expression.
470 Return NULL_TREE if no class reference is found. */
472 tree
473 gfc_get_vptr_from_expr (tree expr)
475 tree tmp;
476 tree type;
478 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
480 type = TREE_TYPE (tmp);
481 while (type)
483 if (GFC_CLASS_TYPE_P (type))
484 return gfc_class_vptr_get (tmp);
485 if (type != TYPE_CANONICAL (type))
486 type = TYPE_CANONICAL (type);
487 else
488 type = NULL_TREE;
490 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
491 break;
494 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
495 tmp = build_fold_indirect_ref_loc (input_location, tmp);
497 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
498 return gfc_class_vptr_get (tmp);
500 return NULL_TREE;
504 static void
505 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
506 bool lhs_type)
508 tree tmp, tmp2, type;
510 gfc_conv_descriptor_data_set (block, lhs_desc,
511 gfc_conv_descriptor_data_get (rhs_desc));
512 gfc_conv_descriptor_offset_set (block, lhs_desc,
513 gfc_conv_descriptor_offset_get (rhs_desc));
515 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
516 gfc_conv_descriptor_dtype (rhs_desc));
518 /* Assign the dimension as range-ref. */
519 tmp = gfc_get_descriptor_dimension (lhs_desc);
520 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
522 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
523 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
524 gfc_index_zero_node, NULL_TREE, NULL_TREE);
525 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
526 gfc_index_zero_node, NULL_TREE, NULL_TREE);
527 gfc_add_modify (block, tmp, tmp2);
531 /* Takes a derived type expression and returns the address of a temporary
532 class object of the 'declared' type. If vptr is not NULL, this is
533 used for the temporary class object.
534 optional_alloc_ptr is false when the dummy is neither allocatable
535 nor a pointer; that's only relevant for the optional handling. */
536 void
537 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
538 gfc_typespec class_ts, tree vptr, bool optional,
539 bool optional_alloc_ptr)
541 gfc_symbol *vtab;
542 tree cond_optional = NULL_TREE;
543 gfc_ss *ss;
544 tree ctree;
545 tree var;
546 tree tmp;
548 /* The derived type needs to be converted to a temporary
549 CLASS object. */
550 tmp = gfc_typenode_for_spec (&class_ts);
551 var = gfc_create_var (tmp, "class");
553 /* Set the vptr. */
554 ctree = gfc_class_vptr_get (var);
556 if (vptr != NULL_TREE)
558 /* Use the dynamic vptr. */
559 tmp = vptr;
561 else
563 /* In this case the vtab corresponds to the derived type and the
564 vptr must point to it. */
565 vtab = gfc_find_derived_vtab (e->ts.u.derived);
566 gcc_assert (vtab);
567 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
569 gfc_add_modify (&parmse->pre, ctree,
570 fold_convert (TREE_TYPE (ctree), tmp));
572 /* Now set the data field. */
573 ctree = gfc_class_data_get (var);
575 if (optional)
576 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
578 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
580 /* If there is a ready made pointer to a derived type, use it
581 rather than evaluating the expression again. */
582 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
583 gfc_add_modify (&parmse->pre, ctree, tmp);
585 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
587 /* For an array reference in an elemental procedure call we need
588 to retain the ss to provide the scalarized array reference. */
589 gfc_conv_expr_reference (parmse, e);
590 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
591 if (optional)
592 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
593 cond_optional, tmp,
594 fold_convert (TREE_TYPE (tmp), null_pointer_node));
595 gfc_add_modify (&parmse->pre, ctree, tmp);
597 else
599 ss = gfc_walk_expr (e);
600 if (ss == gfc_ss_terminator)
602 parmse->ss = NULL;
603 gfc_conv_expr_reference (parmse, e);
605 /* Scalar to an assumed-rank array. */
606 if (class_ts.u.derived->components->as)
608 tree type;
609 type = get_scalar_to_descriptor_type (parmse->expr,
610 gfc_expr_attr (e));
611 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
612 gfc_get_dtype (type));
613 if (optional)
614 parmse->expr = build3_loc (input_location, COND_EXPR,
615 TREE_TYPE (parmse->expr),
616 cond_optional, parmse->expr,
617 fold_convert (TREE_TYPE (parmse->expr),
618 null_pointer_node));
619 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
621 else
623 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
624 if (optional)
625 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
626 cond_optional, tmp,
627 fold_convert (TREE_TYPE (tmp),
628 null_pointer_node));
629 gfc_add_modify (&parmse->pre, ctree, tmp);
632 else
634 stmtblock_t block;
635 gfc_init_block (&block);
637 parmse->ss = ss;
638 gfc_conv_expr_descriptor (parmse, e);
640 if (e->rank != class_ts.u.derived->components->as->rank)
642 gcc_assert (class_ts.u.derived->components->as->type
643 == AS_ASSUMED_RANK);
644 class_array_data_assign (&block, ctree, parmse->expr, false);
646 else
648 if (gfc_expr_attr (e).codimension)
649 parmse->expr = fold_build1_loc (input_location,
650 VIEW_CONVERT_EXPR,
651 TREE_TYPE (ctree),
652 parmse->expr);
653 gfc_add_modify (&block, ctree, parmse->expr);
656 if (optional)
658 tmp = gfc_finish_block (&block);
660 gfc_init_block (&block);
661 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
663 tmp = build3_v (COND_EXPR, cond_optional, tmp,
664 gfc_finish_block (&block));
665 gfc_add_expr_to_block (&parmse->pre, tmp);
667 else
668 gfc_add_block_to_block (&parmse->pre, &block);
672 if (class_ts.u.derived->components->ts.type == BT_DERIVED
673 && class_ts.u.derived->components->ts.u.derived
674 ->attr.unlimited_polymorphic)
676 /* Take care about initializing the _len component correctly. */
677 ctree = gfc_class_len_get (var);
678 if (UNLIMITED_POLY (e))
680 gfc_expr *len;
681 gfc_se se;
683 len = gfc_copy_expr (e);
684 gfc_add_len_component (len);
685 gfc_init_se (&se, NULL);
686 gfc_conv_expr (&se, len);
687 if (optional)
688 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
689 cond_optional, se.expr,
690 fold_convert (TREE_TYPE (se.expr),
691 integer_zero_node));
692 else
693 tmp = se.expr;
695 else
696 tmp = integer_zero_node;
697 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
698 tmp));
700 /* Pass the address of the class object. */
701 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
703 if (optional && optional_alloc_ptr)
704 parmse->expr = build3_loc (input_location, COND_EXPR,
705 TREE_TYPE (parmse->expr),
706 cond_optional, parmse->expr,
707 fold_convert (TREE_TYPE (parmse->expr),
708 null_pointer_node));
712 /* Create a new class container, which is required as scalar coarrays
713 have an array descriptor while normal scalars haven't. Optionally,
714 NULL pointer checks are added if the argument is OPTIONAL. */
716 static void
717 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
718 gfc_typespec class_ts, bool optional)
720 tree var, ctree, tmp;
721 stmtblock_t block;
722 gfc_ref *ref;
723 gfc_ref *class_ref;
725 gfc_init_block (&block);
727 class_ref = NULL;
728 for (ref = e->ref; ref; ref = ref->next)
730 if (ref->type == REF_COMPONENT
731 && ref->u.c.component->ts.type == BT_CLASS)
732 class_ref = ref;
735 if (class_ref == NULL
736 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
737 tmp = e->symtree->n.sym->backend_decl;
738 else
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
742 gfc_se tmpse;
743 ref = class_ref->next;
744 class_ref->next = NULL;
745 gfc_init_se (&tmpse, NULL);
746 gfc_conv_expr (&tmpse, e);
747 class_ref->next = ref;
748 tmp = tmpse.expr;
751 var = gfc_typenode_for_spec (&class_ts);
752 var = gfc_create_var (var, "class");
754 ctree = gfc_class_vptr_get (var);
755 gfc_add_modify (&block, ctree,
756 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
758 ctree = gfc_class_data_get (var);
759 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
760 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
762 /* Pass the address of the class object. */
763 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
765 if (optional)
767 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
768 tree tmp2;
770 tmp = gfc_finish_block (&block);
772 gfc_init_block (&block);
773 tmp2 = gfc_class_data_get (var);
774 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
775 null_pointer_node));
776 tmp2 = gfc_finish_block (&block);
778 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
779 cond, tmp, tmp2);
780 gfc_add_expr_to_block (&parmse->pre, tmp);
782 else
783 gfc_add_block_to_block (&parmse->pre, &block);
787 /* Takes an intrinsic type expression and returns the address of a temporary
788 class object of the 'declared' type. */
789 void
790 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
791 gfc_typespec class_ts)
793 gfc_symbol *vtab;
794 gfc_ss *ss;
795 tree ctree;
796 tree var;
797 tree tmp;
799 /* The intrinsic type needs to be converted to a temporary
800 CLASS object. */
801 tmp = gfc_typenode_for_spec (&class_ts);
802 var = gfc_create_var (tmp, "class");
804 /* Set the vptr. */
805 ctree = gfc_class_vptr_get (var);
807 vtab = gfc_find_vtab (&e->ts);
808 gcc_assert (vtab);
809 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
810 gfc_add_modify (&parmse->pre, ctree,
811 fold_convert (TREE_TYPE (ctree), tmp));
813 /* Now set the data field. */
814 ctree = gfc_class_data_get (var);
815 if (parmse->ss && parmse->ss->info->useflags)
817 /* For an array reference in an elemental procedure call we need
818 to retain the ss to provide the scalarized array reference. */
819 gfc_conv_expr_reference (parmse, e);
820 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
821 gfc_add_modify (&parmse->pre, ctree, tmp);
823 else
825 ss = gfc_walk_expr (e);
826 if (ss == gfc_ss_terminator)
828 parmse->ss = NULL;
829 gfc_conv_expr_reference (parmse, e);
830 if (class_ts.u.derived->components->as
831 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
833 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
834 gfc_expr_attr (e));
835 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
836 TREE_TYPE (ctree), tmp);
838 else
839 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
840 gfc_add_modify (&parmse->pre, ctree, tmp);
842 else
844 parmse->ss = ss;
845 parmse->use_offset = 1;
846 gfc_conv_expr_descriptor (parmse, e);
847 if (class_ts.u.derived->components->as->rank != e->rank)
849 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
850 TREE_TYPE (ctree), parmse->expr);
851 gfc_add_modify (&parmse->pre, ctree, tmp);
853 else
854 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
858 gcc_assert (class_ts.type == BT_CLASS);
859 if (class_ts.u.derived->components->ts.type == BT_DERIVED
860 && class_ts.u.derived->components->ts.u.derived
861 ->attr.unlimited_polymorphic)
863 ctree = gfc_class_len_get (var);
864 /* When the actual arg is a char array, then set the _len component of the
865 unlimited polymorphic entity to the length of the string. */
866 if (e->ts.type == BT_CHARACTER)
868 /* Start with parmse->string_length because this seems to be set to a
869 correct value more often. */
870 if (parmse->string_length)
871 tmp = parmse->string_length;
872 /* When the string_length is not yet set, then try the backend_decl of
873 the cl. */
874 else if (e->ts.u.cl->backend_decl)
875 tmp = e->ts.u.cl->backend_decl;
876 /* If both of the above approaches fail, then try to generate an
877 expression from the input, which is only feasible currently, when the
878 expression can be evaluated to a constant one. */
879 else
881 /* Try to simplify the expression. */
882 gfc_simplify_expr (e, 0);
883 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
885 /* Amazingly all data is present to compute the length of a
886 constant string, but the expression is not yet there. */
887 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
888 &e->where);
889 mpz_set_ui (e->ts.u.cl->length->value.integer,
890 e->value.character.length);
891 gfc_conv_const_charlen (e->ts.u.cl);
892 e->ts.u.cl->resolved = 1;
893 tmp = e->ts.u.cl->backend_decl;
895 else
897 gfc_error ("Can't compute the length of the char array at %L.",
898 &e->where);
902 else
903 tmp = integer_zero_node;
905 gfc_add_modify (&parmse->pre, ctree, tmp);
907 else if (class_ts.type == BT_CLASS
908 && class_ts.u.derived->components
909 && class_ts.u.derived->components->ts.u
910 .derived->attr.unlimited_polymorphic)
912 ctree = gfc_class_len_get (var);
913 gfc_add_modify (&parmse->pre, ctree,
914 fold_convert (TREE_TYPE (ctree),
915 integer_zero_node));
917 /* Pass the address of the class object. */
918 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
922 /* Takes a scalarized class array expression and returns the
923 address of a temporary scalar class object of the 'declared'
924 type.
925 OOP-TODO: This could be improved by adding code that branched on
926 the dynamic type being the same as the declared type. In this case
927 the original class expression can be passed directly.
928 optional_alloc_ptr is false when the dummy is neither allocatable
929 nor a pointer; that's relevant for the optional handling.
930 Set copyback to true if class container's _data and _vtab pointers
931 might get modified. */
933 void
934 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
935 bool elemental, bool copyback, bool optional,
936 bool optional_alloc_ptr)
938 tree ctree;
939 tree var;
940 tree tmp;
941 tree vptr;
942 tree cond = NULL_TREE;
943 tree slen = NULL_TREE;
944 gfc_ref *ref;
945 gfc_ref *class_ref;
946 stmtblock_t block;
947 bool full_array = false;
949 gfc_init_block (&block);
951 class_ref = NULL;
952 for (ref = e->ref; ref; ref = ref->next)
954 if (ref->type == REF_COMPONENT
955 && ref->u.c.component->ts.type == BT_CLASS)
956 class_ref = ref;
958 if (ref->next == NULL)
959 break;
962 if ((ref == NULL || class_ref == ref)
963 && (!class_ts.u.derived->components->as
964 || class_ts.u.derived->components->as->rank != -1))
965 return;
967 /* Test for FULL_ARRAY. */
968 if (e->rank == 0 && gfc_expr_attr (e).codimension
969 && gfc_expr_attr (e).dimension)
970 full_array = true;
971 else
972 gfc_is_class_array_ref (e, &full_array);
974 /* The derived type needs to be converted to a temporary
975 CLASS object. */
976 tmp = gfc_typenode_for_spec (&class_ts);
977 var = gfc_create_var (tmp, "class");
979 /* Set the data. */
980 ctree = gfc_class_data_get (var);
981 if (class_ts.u.derived->components->as
982 && e->rank != class_ts.u.derived->components->as->rank)
984 if (e->rank == 0)
986 tree type = get_scalar_to_descriptor_type (parmse->expr,
987 gfc_expr_attr (e));
988 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
989 gfc_get_dtype (type));
991 tmp = gfc_class_data_get (parmse->expr);
992 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
993 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
995 gfc_conv_descriptor_data_set (&block, ctree, tmp);
997 else
998 class_array_data_assign (&block, ctree, parmse->expr, false);
1000 else
1002 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1003 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1004 TREE_TYPE (ctree), parmse->expr);
1005 gfc_add_modify (&block, ctree, parmse->expr);
1008 /* Return the data component, except in the case of scalarized array
1009 references, where nullification of the cannot occur and so there
1010 is no need. */
1011 if (!elemental && full_array && copyback)
1013 if (class_ts.u.derived->components->as
1014 && e->rank != class_ts.u.derived->components->as->rank)
1016 if (e->rank == 0)
1017 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1018 gfc_conv_descriptor_data_get (ctree));
1019 else
1020 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1022 else
1023 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1026 /* Set the vptr. */
1027 ctree = gfc_class_vptr_get (var);
1029 /* The vptr is the second field of the actual argument.
1030 First we have to find the corresponding class reference. */
1032 tmp = NULL_TREE;
1033 if (class_ref == NULL
1034 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1036 tmp = e->symtree->n.sym->backend_decl;
1038 if (TREE_CODE (tmp) == FUNCTION_DECL)
1039 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1041 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1042 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1044 slen = integer_zero_node;
1046 else
1048 /* Remove everything after the last class reference, convert the
1049 expression and then recover its tailend once more. */
1050 gfc_se tmpse;
1051 ref = class_ref->next;
1052 class_ref->next = NULL;
1053 gfc_init_se (&tmpse, NULL);
1054 gfc_conv_expr (&tmpse, e);
1055 class_ref->next = ref;
1056 tmp = tmpse.expr;
1057 slen = tmpse.string_length;
1060 gcc_assert (tmp != NULL_TREE);
1062 /* Dereference if needs be. */
1063 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1064 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1066 vptr = gfc_class_vptr_get (tmp);
1067 gfc_add_modify (&block, ctree,
1068 fold_convert (TREE_TYPE (ctree), vptr));
1070 /* Return the vptr component, except in the case of scalarized array
1071 references, where the dynamic type cannot change. */
1072 if (!elemental && full_array && copyback)
1073 gfc_add_modify (&parmse->post, vptr,
1074 fold_convert (TREE_TYPE (vptr), ctree));
1076 /* For unlimited polymorphic objects also set the _len component. */
1077 if (class_ts.type == BT_CLASS
1078 && class_ts.u.derived->components
1079 && class_ts.u.derived->components->ts.u
1080 .derived->attr.unlimited_polymorphic)
1082 ctree = gfc_class_len_get (var);
1083 if (UNLIMITED_POLY (e))
1084 tmp = gfc_class_len_get (tmp);
1085 else if (e->ts.type == BT_CHARACTER)
1087 gcc_assert (slen != NULL_TREE);
1088 tmp = slen;
1090 else
1091 tmp = integer_zero_node;
1092 gfc_add_modify (&parmse->pre, ctree,
1093 fold_convert (TREE_TYPE (ctree), tmp));
1095 /* Return the len component, except in the case of scalarized array
1096 references, where the dynamic type cannot change. */
1097 if (!elemental && full_array && copyback)
1098 gfc_add_modify (&parmse->post, tmp,
1099 fold_convert (TREE_TYPE (tmp), ctree));
1102 if (optional)
1104 tree tmp2;
1106 cond = gfc_conv_expr_present (e->symtree->n.sym);
1107 /* parmse->pre may contain some preparatory instructions for the
1108 temporary array descriptor. Those may only be executed when the
1109 optional argument is set, therefore add parmse->pre's instructions
1110 to block, which is later guarded by an if (optional_arg_given). */
1111 gfc_add_block_to_block (&parmse->pre, &block);
1112 block.head = parmse->pre.head;
1113 parmse->pre.head = NULL_TREE;
1114 tmp = gfc_finish_block (&block);
1116 if (optional_alloc_ptr)
1117 tmp2 = build_empty_stmt (input_location);
1118 else
1120 gfc_init_block (&block);
1122 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1123 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1124 null_pointer_node));
1125 tmp2 = gfc_finish_block (&block);
1128 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1129 cond, tmp, tmp2);
1130 gfc_add_expr_to_block (&parmse->pre, tmp);
1132 else
1133 gfc_add_block_to_block (&parmse->pre, &block);
1135 /* Pass the address of the class object. */
1136 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1138 if (optional && optional_alloc_ptr)
1139 parmse->expr = build3_loc (input_location, COND_EXPR,
1140 TREE_TYPE (parmse->expr),
1141 cond, parmse->expr,
1142 fold_convert (TREE_TYPE (parmse->expr),
1143 null_pointer_node));
1147 /* Given a class array declaration and an index, returns the address
1148 of the referenced element. */
1150 tree
1151 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
1153 tree data = data_comp != NULL_TREE ? data_comp :
1154 gfc_class_data_get (class_decl);
1155 tree size = gfc_class_vtab_size_get (class_decl);
1156 tree offset = fold_build2_loc (input_location, MULT_EXPR,
1157 gfc_array_index_type,
1158 index, size);
1159 tree ptr;
1160 data = gfc_conv_descriptor_data_get (data);
1161 ptr = fold_convert (pvoid_type_node, data);
1162 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1163 return fold_convert (TREE_TYPE (data), ptr);
1167 /* Copies one class expression to another, assuming that if either
1168 'to' or 'from' are arrays they are packed. Should 'from' be
1169 NULL_TREE, the initialization expression for 'to' is used, assuming
1170 that the _vptr is set. */
1172 tree
1173 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1175 tree fcn;
1176 tree fcn_type;
1177 tree from_data;
1178 tree from_len;
1179 tree to_data;
1180 tree to_len;
1181 tree to_ref;
1182 tree from_ref;
1183 vec<tree, va_gc> *args;
1184 tree tmp;
1185 tree stdcopy;
1186 tree extcopy;
1187 tree index;
1188 bool is_from_desc = false, is_to_class = false;
1190 args = NULL;
1191 /* To prevent warnings on uninitialized variables. */
1192 from_len = to_len = NULL_TREE;
1194 if (from != NULL_TREE)
1195 fcn = gfc_class_vtab_copy_get (from);
1196 else
1197 fcn = gfc_class_vtab_copy_get (to);
1199 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1201 if (from != NULL_TREE)
1203 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1204 if (is_from_desc)
1206 from_data = from;
1207 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1209 else
1211 /* Check that from is a class. When the class is part of a coarray,
1212 then from is a common pointer and is to be used as is. */
1213 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1214 ? build_fold_indirect_ref (from) : from;
1215 from_data =
1216 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1217 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1218 ? gfc_class_data_get (from) : from;
1219 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1222 else
1223 from_data = gfc_class_vtab_def_init_get (to);
1225 if (unlimited)
1227 if (from != NULL_TREE && unlimited)
1228 from_len = gfc_class_len_or_zero_get (from);
1229 else
1230 from_len = integer_zero_node;
1233 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1235 is_to_class = true;
1236 to_data = gfc_class_data_get (to);
1237 if (unlimited)
1238 to_len = gfc_class_len_get (to);
1240 else
1241 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1242 to_data = to;
1244 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1246 stmtblock_t loopbody;
1247 stmtblock_t body;
1248 stmtblock_t ifbody;
1249 gfc_loopinfo loop;
1250 tree orig_nelems = nelems; /* Needed for bounds check. */
1252 gfc_init_block (&body);
1253 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1254 gfc_array_index_type, nelems,
1255 gfc_index_one_node);
1256 nelems = gfc_evaluate_now (tmp, &body);
1257 index = gfc_create_var (gfc_array_index_type, "S");
1259 if (is_from_desc)
1261 from_ref = gfc_get_class_array_ref (index, from, from_data);
1262 vec_safe_push (args, from_ref);
1264 else
1265 vec_safe_push (args, from_data);
1267 if (is_to_class)
1268 to_ref = gfc_get_class_array_ref (index, to, to_data);
1269 else
1271 tmp = gfc_conv_array_data (to);
1272 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1273 to_ref = gfc_build_addr_expr (NULL_TREE,
1274 gfc_build_array_ref (tmp, index, to));
1276 vec_safe_push (args, to_ref);
1278 /* Add bounds check. */
1279 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1281 char *msg;
1282 const char *name = "<<unknown>>";
1283 tree from_len;
1285 if (DECL_P (to))
1286 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1288 from_len = gfc_conv_descriptor_size (from_data, 1);
1289 tmp = fold_build2_loc (input_location, NE_EXPR,
1290 boolean_type_node, from_len, orig_nelems);
1291 msg = xasprintf ("Array bound mismatch for dimension %d "
1292 "of array '%s' (%%ld/%%ld)",
1293 1, name);
1295 gfc_trans_runtime_check (true, false, tmp, &body,
1296 &gfc_current_locus, msg,
1297 fold_convert (long_integer_type_node, orig_nelems),
1298 fold_convert (long_integer_type_node, from_len));
1300 free (msg);
1303 tmp = build_call_vec (fcn_type, fcn, args);
1305 /* Build the body of the loop. */
1306 gfc_init_block (&loopbody);
1307 gfc_add_expr_to_block (&loopbody, tmp);
1309 /* Build the loop and return. */
1310 gfc_init_loopinfo (&loop);
1311 loop.dimen = 1;
1312 loop.from[0] = gfc_index_zero_node;
1313 loop.loopvar[0] = index;
1314 loop.to[0] = nelems;
1315 gfc_trans_scalarizing_loops (&loop, &loopbody);
1316 gfc_init_block (&ifbody);
1317 gfc_add_block_to_block (&ifbody, &loop.pre);
1318 stdcopy = gfc_finish_block (&ifbody);
1319 /* In initialization mode from_len is a constant zero. */
1320 if (unlimited && !integer_zerop (from_len))
1322 vec_safe_push (args, from_len);
1323 vec_safe_push (args, to_len);
1324 tmp = build_call_vec (fcn_type, fcn, args);
1325 /* Build the body of the loop. */
1326 gfc_init_block (&loopbody);
1327 gfc_add_expr_to_block (&loopbody, tmp);
1329 /* Build the loop and return. */
1330 gfc_init_loopinfo (&loop);
1331 loop.dimen = 1;
1332 loop.from[0] = gfc_index_zero_node;
1333 loop.loopvar[0] = index;
1334 loop.to[0] = nelems;
1335 gfc_trans_scalarizing_loops (&loop, &loopbody);
1336 gfc_init_block (&ifbody);
1337 gfc_add_block_to_block (&ifbody, &loop.pre);
1338 extcopy = gfc_finish_block (&ifbody);
1340 tmp = fold_build2_loc (input_location, GT_EXPR,
1341 boolean_type_node, from_len,
1342 integer_zero_node);
1343 tmp = fold_build3_loc (input_location, COND_EXPR,
1344 void_type_node, tmp, extcopy, stdcopy);
1345 gfc_add_expr_to_block (&body, tmp);
1346 tmp = gfc_finish_block (&body);
1348 else
1350 gfc_add_expr_to_block (&body, stdcopy);
1351 tmp = gfc_finish_block (&body);
1353 gfc_cleanup_loop (&loop);
1355 else
1357 gcc_assert (!is_from_desc);
1358 vec_safe_push (args, from_data);
1359 vec_safe_push (args, to_data);
1360 stdcopy = build_call_vec (fcn_type, fcn, args);
1362 /* In initialization mode from_len is a constant zero. */
1363 if (unlimited && !integer_zerop (from_len))
1365 vec_safe_push (args, from_len);
1366 vec_safe_push (args, to_len);
1367 extcopy = build_call_vec (fcn_type, fcn, args);
1368 tmp = fold_build2_loc (input_location, GT_EXPR,
1369 boolean_type_node, from_len,
1370 integer_zero_node);
1371 tmp = fold_build3_loc (input_location, COND_EXPR,
1372 void_type_node, tmp, extcopy, stdcopy);
1374 else
1375 tmp = stdcopy;
1378 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1379 if (from == NULL_TREE)
1381 tree cond;
1382 cond = fold_build2_loc (input_location, NE_EXPR,
1383 boolean_type_node,
1384 from_data, null_pointer_node);
1385 tmp = fold_build3_loc (input_location, COND_EXPR,
1386 void_type_node, cond,
1387 tmp, build_empty_stmt (input_location));
1390 return tmp;
1394 static tree
1395 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1397 gfc_actual_arglist *actual;
1398 gfc_expr *ppc;
1399 gfc_code *ppc_code;
1400 tree res;
1402 actual = gfc_get_actual_arglist ();
1403 actual->expr = gfc_copy_expr (rhs);
1404 actual->next = gfc_get_actual_arglist ();
1405 actual->next->expr = gfc_copy_expr (lhs);
1406 ppc = gfc_copy_expr (obj);
1407 gfc_add_vptr_component (ppc);
1408 gfc_add_component_ref (ppc, "_copy");
1409 ppc_code = gfc_get_code (EXEC_CALL);
1410 ppc_code->resolved_sym = ppc->symtree->n.sym;
1411 /* Although '_copy' is set to be elemental in class.c, it is
1412 not staying that way. Find out why, sometime.... */
1413 ppc_code->resolved_sym->attr.elemental = 1;
1414 ppc_code->ext.actual = actual;
1415 ppc_code->expr1 = ppc;
1416 /* Since '_copy' is elemental, the scalarizer will take care
1417 of arrays in gfc_trans_call. */
1418 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1419 gfc_free_statements (ppc_code);
1421 if (UNLIMITED_POLY(obj))
1423 /* Check if rhs is non-NULL. */
1424 gfc_se src;
1425 gfc_init_se (&src, NULL);
1426 gfc_conv_expr (&src, rhs);
1427 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1428 tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1429 src.expr, fold_convert (TREE_TYPE (src.expr),
1430 null_pointer_node));
1431 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1432 build_empty_stmt (input_location));
1435 return res;
1438 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1439 A MEMCPY is needed to copy the full data from the default initializer
1440 of the dynamic type. */
1442 tree
1443 gfc_trans_class_init_assign (gfc_code *code)
1445 stmtblock_t block;
1446 tree tmp;
1447 gfc_se dst,src,memsz;
1448 gfc_expr *lhs, *rhs, *sz;
1450 gfc_start_block (&block);
1452 lhs = gfc_copy_expr (code->expr1);
1453 gfc_add_data_component (lhs);
1455 rhs = gfc_copy_expr (code->expr1);
1456 gfc_add_vptr_component (rhs);
1458 /* Make sure that the component backend_decls have been built, which
1459 will not have happened if the derived types concerned have not
1460 been referenced. */
1461 gfc_get_derived_type (rhs->ts.u.derived);
1462 gfc_add_def_init_component (rhs);
1463 /* The _def_init is always scalar. */
1464 rhs->rank = 0;
1466 if (code->expr1->ts.type == BT_CLASS
1467 && CLASS_DATA (code->expr1)->attr.dimension)
1469 gfc_array_spec *tmparr = gfc_get_array_spec ();
1470 *tmparr = *CLASS_DATA (code->expr1)->as;
1471 gfc_add_full_array_ref (lhs, tmparr);
1472 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1474 else
1476 sz = gfc_copy_expr (code->expr1);
1477 gfc_add_vptr_component (sz);
1478 gfc_add_size_component (sz);
1480 gfc_init_se (&dst, NULL);
1481 gfc_init_se (&src, NULL);
1482 gfc_init_se (&memsz, NULL);
1483 gfc_conv_expr (&dst, lhs);
1484 gfc_conv_expr (&src, rhs);
1485 gfc_conv_expr (&memsz, sz);
1486 gfc_add_block_to_block (&block, &src.pre);
1487 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1489 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1491 if (UNLIMITED_POLY(code->expr1))
1493 /* Check if _def_init is non-NULL. */
1494 tree cond = fold_build2_loc (input_location, NE_EXPR,
1495 boolean_type_node, src.expr,
1496 fold_convert (TREE_TYPE (src.expr),
1497 null_pointer_node));
1498 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1499 tmp, build_empty_stmt (input_location));
1503 if (code->expr1->symtree->n.sym->attr.optional
1504 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1506 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1507 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1508 present, tmp,
1509 build_empty_stmt (input_location));
1512 gfc_add_expr_to_block (&block, tmp);
1514 return gfc_finish_block (&block);
1518 /* End of prototype trans-class.c */
1521 static void
1522 realloc_lhs_warning (bt type, bool array, locus *where)
1524 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1525 gfc_warning (OPT_Wrealloc_lhs,
1526 "Code for reallocating the allocatable array at %L will "
1527 "be added", where);
1528 else if (warn_realloc_lhs_all)
1529 gfc_warning (OPT_Wrealloc_lhs_all,
1530 "Code for reallocating the allocatable variable at %L "
1531 "will be added", where);
1535 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1536 gfc_expr *);
1538 /* Copy the scalarization loop variables. */
1540 static void
1541 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1543 dest->ss = src->ss;
1544 dest->loop = src->loop;
1548 /* Initialize a simple expression holder.
1550 Care must be taken when multiple se are created with the same parent.
1551 The child se must be kept in sync. The easiest way is to delay creation
1552 of a child se until after after the previous se has been translated. */
1554 void
1555 gfc_init_se (gfc_se * se, gfc_se * parent)
1557 memset (se, 0, sizeof (gfc_se));
1558 gfc_init_block (&se->pre);
1559 gfc_init_block (&se->post);
1561 se->parent = parent;
1563 if (parent)
1564 gfc_copy_se_loopvars (se, parent);
1568 /* Advances to the next SS in the chain. Use this rather than setting
1569 se->ss = se->ss->next because all the parents needs to be kept in sync.
1570 See gfc_init_se. */
1572 void
1573 gfc_advance_se_ss_chain (gfc_se * se)
1575 gfc_se *p;
1576 gfc_ss *ss;
1578 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1580 p = se;
1581 /* Walk down the parent chain. */
1582 while (p != NULL)
1584 /* Simple consistency check. */
1585 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1586 || p->parent->ss->nested_ss == p->ss);
1588 /* If we were in a nested loop, the next scalarized expression can be
1589 on the parent ss' next pointer. Thus we should not take the next
1590 pointer blindly, but rather go up one nest level as long as next
1591 is the end of chain. */
1592 ss = p->ss;
1593 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1594 ss = ss->parent;
1596 p->ss = ss->next;
1598 p = p->parent;
1603 /* Ensures the result of the expression as either a temporary variable
1604 or a constant so that it can be used repeatedly. */
1606 void
1607 gfc_make_safe_expr (gfc_se * se)
1609 tree var;
1611 if (CONSTANT_CLASS_P (se->expr))
1612 return;
1614 /* We need a temporary for this result. */
1615 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1616 gfc_add_modify (&se->pre, var, se->expr);
1617 se->expr = var;
1621 /* Return an expression which determines if a dummy parameter is present.
1622 Also used for arguments to procedures with multiple entry points. */
1624 tree
1625 gfc_conv_expr_present (gfc_symbol * sym)
1627 tree decl, cond;
1629 gcc_assert (sym->attr.dummy);
1630 decl = gfc_get_symbol_decl (sym);
1632 /* Intrinsic scalars with VALUE attribute which are passed by value
1633 use a hidden argument to denote the present status. */
1634 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1635 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1636 && !sym->attr.dimension)
1638 char name[GFC_MAX_SYMBOL_LEN + 2];
1639 tree tree_name;
1641 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1642 name[0] = '_';
1643 strcpy (&name[1], sym->name);
1644 tree_name = get_identifier (name);
1646 /* Walk function argument list to find hidden arg. */
1647 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1648 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1649 if (DECL_NAME (cond) == tree_name)
1650 break;
1652 gcc_assert (cond);
1653 return cond;
1656 if (TREE_CODE (decl) != PARM_DECL)
1658 /* Array parameters use a temporary descriptor, we want the real
1659 parameter. */
1660 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1661 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1662 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1665 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
1666 fold_convert (TREE_TYPE (decl), null_pointer_node));
1668 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1669 as actual argument to denote absent dummies. For array descriptors,
1670 we thus also need to check the array descriptor. For BT_CLASS, it
1671 can also occur for scalars and F2003 due to type->class wrapping and
1672 class->class wrapping. Note further that BT_CLASS always uses an
1673 array descriptor for arrays, also for explicit-shape/assumed-size. */
1675 if (!sym->attr.allocatable
1676 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1677 || (sym->ts.type == BT_CLASS
1678 && !CLASS_DATA (sym)->attr.allocatable
1679 && !CLASS_DATA (sym)->attr.class_pointer))
1680 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1681 || sym->ts.type == BT_CLASS))
1683 tree tmp;
1685 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1686 || sym->as->type == AS_ASSUMED_RANK
1687 || sym->attr.codimension))
1688 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1690 tmp = build_fold_indirect_ref_loc (input_location, decl);
1691 if (sym->ts.type == BT_CLASS)
1692 tmp = gfc_class_data_get (tmp);
1693 tmp = gfc_conv_array_data (tmp);
1695 else if (sym->ts.type == BT_CLASS)
1696 tmp = gfc_class_data_get (decl);
1697 else
1698 tmp = NULL_TREE;
1700 if (tmp != NULL_TREE)
1702 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
1703 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1704 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1705 boolean_type_node, cond, tmp);
1709 return cond;
1713 /* Converts a missing, dummy argument into a null or zero. */
1715 void
1716 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1718 tree present;
1719 tree tmp;
1721 present = gfc_conv_expr_present (arg->symtree->n.sym);
1723 if (kind > 0)
1725 /* Create a temporary and convert it to the correct type. */
1726 tmp = gfc_get_int_type (kind);
1727 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1728 se->expr));
1730 /* Test for a NULL value. */
1731 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1732 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1733 tmp = gfc_evaluate_now (tmp, &se->pre);
1734 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1736 else
1738 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1739 present, se->expr,
1740 build_zero_cst (TREE_TYPE (se->expr)));
1741 tmp = gfc_evaluate_now (tmp, &se->pre);
1742 se->expr = tmp;
1745 if (ts.type == BT_CHARACTER)
1747 tmp = build_int_cst (gfc_charlen_type_node, 0);
1748 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1749 present, se->string_length, tmp);
1750 tmp = gfc_evaluate_now (tmp, &se->pre);
1751 se->string_length = tmp;
1753 return;
1757 /* Get the character length of an expression, looking through gfc_refs
1758 if necessary. */
1760 tree
1761 gfc_get_expr_charlen (gfc_expr *e)
1763 gfc_ref *r;
1764 tree length;
1766 gcc_assert (e->expr_type == EXPR_VARIABLE
1767 && e->ts.type == BT_CHARACTER);
1769 length = NULL; /* To silence compiler warning. */
1771 if (is_subref_array (e) && e->ts.u.cl->length)
1773 gfc_se tmpse;
1774 gfc_init_se (&tmpse, NULL);
1775 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1776 e->ts.u.cl->backend_decl = tmpse.expr;
1777 return tmpse.expr;
1780 /* First candidate: if the variable is of type CHARACTER, the
1781 expression's length could be the length of the character
1782 variable. */
1783 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1784 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1786 /* Look through the reference chain for component references. */
1787 for (r = e->ref; r; r = r->next)
1789 switch (r->type)
1791 case REF_COMPONENT:
1792 if (r->u.c.component->ts.type == BT_CHARACTER)
1793 length = r->u.c.component->ts.u.cl->backend_decl;
1794 break;
1796 case REF_ARRAY:
1797 /* Do nothing. */
1798 break;
1800 default:
1801 /* We should never got substring references here. These will be
1802 broken down by the scalarizer. */
1803 gcc_unreachable ();
1804 break;
1808 gcc_assert (length != NULL);
1809 return length;
1813 /* Return for an expression the backend decl of the coarray. */
1815 tree
1816 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1818 tree caf_decl;
1819 bool found = false;
1820 gfc_ref *ref;
1822 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1824 /* Not-implemented diagnostic. */
1825 if (expr->symtree->n.sym->ts.type == BT_CLASS
1826 && UNLIMITED_POLY (expr->symtree->n.sym)
1827 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1828 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1829 "%L is not supported", &expr->where);
1831 for (ref = expr->ref; ref; ref = ref->next)
1832 if (ref->type == REF_COMPONENT)
1834 if (ref->u.c.component->ts.type == BT_CLASS
1835 && UNLIMITED_POLY (ref->u.c.component)
1836 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1837 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1838 "component at %L is not supported", &expr->where);
1841 /* Make sure the backend_decl is present before accessing it. */
1842 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1843 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1844 : expr->symtree->n.sym->backend_decl;
1846 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1848 if (expr->ref && expr->ref->type == REF_ARRAY)
1850 caf_decl = gfc_class_data_get (caf_decl);
1851 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1852 return caf_decl;
1854 for (ref = expr->ref; ref; ref = ref->next)
1856 if (ref->type == REF_COMPONENT
1857 && strcmp (ref->u.c.component->name, "_data") != 0)
1859 caf_decl = gfc_class_data_get (caf_decl);
1860 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1861 return caf_decl;
1862 break;
1864 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1865 break;
1868 if (expr->symtree->n.sym->attr.codimension)
1869 return caf_decl;
1871 /* The following code assumes that the coarray is a component reachable via
1872 only scalar components/variables; the Fortran standard guarantees this. */
1874 for (ref = expr->ref; ref; ref = ref->next)
1875 if (ref->type == REF_COMPONENT)
1877 gfc_component *comp = ref->u.c.component;
1879 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1880 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1881 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1882 TREE_TYPE (comp->backend_decl), caf_decl,
1883 comp->backend_decl, NULL_TREE);
1884 if (comp->ts.type == BT_CLASS)
1886 caf_decl = gfc_class_data_get (caf_decl);
1887 if (CLASS_DATA (comp)->attr.codimension)
1889 found = true;
1890 break;
1893 if (comp->attr.codimension)
1895 found = true;
1896 break;
1899 gcc_assert (found && caf_decl);
1900 return caf_decl;
1904 /* Obtain the Coarray token - and optionally also the offset. */
1906 void
1907 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1908 tree se_expr, gfc_expr *expr)
1910 tree tmp;
1912 /* Coarray token. */
1913 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1915 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1916 == GFC_ARRAY_ALLOCATABLE
1917 || expr->symtree->n.sym->attr.select_type_temporary);
1918 *token = gfc_conv_descriptor_token (caf_decl);
1920 else if (DECL_LANG_SPECIFIC (caf_decl)
1921 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1922 *token = GFC_DECL_TOKEN (caf_decl);
1923 else
1925 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1926 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1927 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1930 if (offset == NULL)
1931 return;
1933 /* Offset between the coarray base address and the address wanted. */
1934 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1935 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1936 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1937 *offset = build_int_cst (gfc_array_index_type, 0);
1938 else if (DECL_LANG_SPECIFIC (caf_decl)
1939 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
1940 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
1941 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
1942 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
1943 else
1944 *offset = build_int_cst (gfc_array_index_type, 0);
1946 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
1947 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
1949 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
1950 tmp = gfc_conv_descriptor_data_get (tmp);
1952 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
1953 tmp = gfc_conv_descriptor_data_get (se_expr);
1954 else
1956 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
1957 tmp = se_expr;
1960 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1961 *offset, fold_convert (gfc_array_index_type, tmp));
1963 if (expr->symtree->n.sym->ts.type == BT_DERIVED
1964 && expr->symtree->n.sym->attr.codimension
1965 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
1967 gfc_expr *base_expr = gfc_copy_expr (expr);
1968 gfc_ref *ref = base_expr->ref;
1969 gfc_se base_se;
1971 // Iterate through the refs until the last one.
1972 while (ref->next)
1973 ref = ref->next;
1975 if (ref->type == REF_ARRAY
1976 && ref->u.ar.type != AR_FULL)
1978 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
1979 int i;
1980 for (i = 0; i < ranksum; ++i)
1982 ref->u.ar.start[i] = NULL;
1983 ref->u.ar.end[i] = NULL;
1985 ref->u.ar.type = AR_FULL;
1987 gfc_init_se (&base_se, NULL);
1988 if (gfc_caf_attr (base_expr).dimension)
1990 gfc_conv_expr_descriptor (&base_se, base_expr);
1991 tmp = gfc_conv_descriptor_data_get (base_se.expr);
1993 else
1995 gfc_conv_expr (&base_se, base_expr);
1996 tmp = base_se.expr;
1999 gfc_free_expr (base_expr);
2000 gfc_add_block_to_block (&se->pre, &base_se.pre);
2001 gfc_add_block_to_block (&se->post, &base_se.post);
2003 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2004 tmp = gfc_conv_descriptor_data_get (caf_decl);
2005 else
2007 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2008 tmp = caf_decl;
2011 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2012 fold_convert (gfc_array_index_type, *offset),
2013 fold_convert (gfc_array_index_type, tmp));
2017 /* Convert the coindex of a coarray into an image index; the result is
2018 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2019 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2021 tree
2022 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2024 gfc_ref *ref;
2025 tree lbound, ubound, extent, tmp, img_idx;
2026 gfc_se se;
2027 int i;
2029 for (ref = e->ref; ref; ref = ref->next)
2030 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2031 break;
2032 gcc_assert (ref != NULL);
2034 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2036 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2037 integer_zero_node);
2040 img_idx = integer_zero_node;
2041 extent = integer_one_node;
2042 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2043 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2045 gfc_init_se (&se, NULL);
2046 gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
2047 gfc_add_block_to_block (block, &se.pre);
2048 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2049 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2050 integer_type_node, se.expr,
2051 fold_convert(integer_type_node, lbound));
2052 tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
2053 extent, tmp);
2054 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2055 img_idx, tmp);
2056 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2058 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2059 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2060 tmp = fold_convert (integer_type_node, tmp);
2061 extent = fold_build2_loc (input_location, MULT_EXPR,
2062 integer_type_node, extent, tmp);
2065 else
2066 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2068 gfc_init_se (&se, NULL);
2069 gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
2070 gfc_add_block_to_block (block, &se.pre);
2071 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2072 lbound = fold_convert (integer_type_node, lbound);
2073 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2074 integer_type_node, se.expr, lbound);
2075 tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
2076 extent, tmp);
2077 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2078 img_idx, tmp);
2079 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2081 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2082 ubound = fold_convert (integer_type_node, ubound);
2083 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2084 integer_type_node, ubound, lbound);
2085 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2086 tmp, integer_one_node);
2087 extent = fold_build2_loc (input_location, MULT_EXPR,
2088 integer_type_node, extent, tmp);
2091 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2092 img_idx, integer_one_node);
2093 return img_idx;
2097 /* For each character array constructor subexpression without a ts.u.cl->length,
2098 replace it by its first element (if there aren't any elements, the length
2099 should already be set to zero). */
2101 static void
2102 flatten_array_ctors_without_strlen (gfc_expr* e)
2104 gfc_actual_arglist* arg;
2105 gfc_constructor* c;
2107 if (!e)
2108 return;
2110 switch (e->expr_type)
2113 case EXPR_OP:
2114 flatten_array_ctors_without_strlen (e->value.op.op1);
2115 flatten_array_ctors_without_strlen (e->value.op.op2);
2116 break;
2118 case EXPR_COMPCALL:
2119 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2120 gcc_unreachable ();
2122 case EXPR_FUNCTION:
2123 for (arg = e->value.function.actual; arg; arg = arg->next)
2124 flatten_array_ctors_without_strlen (arg->expr);
2125 break;
2127 case EXPR_ARRAY:
2129 /* We've found what we're looking for. */
2130 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2132 gfc_constructor *c;
2133 gfc_expr* new_expr;
2135 gcc_assert (e->value.constructor);
2137 c = gfc_constructor_first (e->value.constructor);
2138 new_expr = c->expr;
2139 c->expr = NULL;
2141 flatten_array_ctors_without_strlen (new_expr);
2142 gfc_replace_expr (e, new_expr);
2143 break;
2146 /* Otherwise, fall through to handle constructor elements. */
2147 gcc_fallthrough ();
2148 case EXPR_STRUCTURE:
2149 for (c = gfc_constructor_first (e->value.constructor);
2150 c; c = gfc_constructor_next (c))
2151 flatten_array_ctors_without_strlen (c->expr);
2152 break;
2154 default:
2155 break;
2161 /* Generate code to initialize a string length variable. Returns the
2162 value. For array constructors, cl->length might be NULL and in this case,
2163 the first element of the constructor is needed. expr is the original
2164 expression so we can access it but can be NULL if this is not needed. */
2166 void
2167 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2169 gfc_se se;
2171 gfc_init_se (&se, NULL);
2173 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2174 return;
2176 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2177 "flatten" array constructors by taking their first element; all elements
2178 should be the same length or a cl->length should be present. */
2179 if (!cl->length)
2181 gfc_expr* expr_flat;
2182 gcc_assert (expr);
2183 expr_flat = gfc_copy_expr (expr);
2184 flatten_array_ctors_without_strlen (expr_flat);
2185 gfc_resolve_expr (expr_flat);
2187 gfc_conv_expr (&se, expr_flat);
2188 gfc_add_block_to_block (pblock, &se.pre);
2189 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2191 gfc_free_expr (expr_flat);
2192 return;
2195 /* Convert cl->length. */
2197 gcc_assert (cl->length);
2199 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2200 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2201 se.expr, build_int_cst (gfc_charlen_type_node, 0));
2202 gfc_add_block_to_block (pblock, &se.pre);
2204 if (cl->backend_decl)
2205 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2206 else
2207 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2211 static void
2212 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2213 const char *name, locus *where)
2215 tree tmp;
2216 tree type;
2217 tree fault;
2218 gfc_se start;
2219 gfc_se end;
2220 char *msg;
2221 mpz_t length;
2223 type = gfc_get_character_type (kind, ref->u.ss.length);
2224 type = build_pointer_type (type);
2226 gfc_init_se (&start, se);
2227 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2228 gfc_add_block_to_block (&se->pre, &start.pre);
2230 if (integer_onep (start.expr))
2231 gfc_conv_string_parameter (se);
2232 else
2234 tmp = start.expr;
2235 STRIP_NOPS (tmp);
2236 /* Avoid multiple evaluation of substring start. */
2237 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2238 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2240 /* Change the start of the string. */
2241 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2242 tmp = se->expr;
2243 else
2244 tmp = build_fold_indirect_ref_loc (input_location,
2245 se->expr);
2246 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2247 se->expr = gfc_build_addr_expr (type, tmp);
2250 /* Length = end + 1 - start. */
2251 gfc_init_se (&end, se);
2252 if (ref->u.ss.end == NULL)
2253 end.expr = se->string_length;
2254 else
2256 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2257 gfc_add_block_to_block (&se->pre, &end.pre);
2259 tmp = end.expr;
2260 STRIP_NOPS (tmp);
2261 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2262 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2264 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2266 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2267 boolean_type_node, start.expr,
2268 end.expr);
2270 /* Check lower bound. */
2271 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2272 start.expr,
2273 build_int_cst (gfc_charlen_type_node, 1));
2274 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2275 boolean_type_node, nonempty, fault);
2276 if (name)
2277 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2278 "is less than one", name);
2279 else
2280 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2281 "is less than one");
2282 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2283 fold_convert (long_integer_type_node,
2284 start.expr));
2285 free (msg);
2287 /* Check upper bound. */
2288 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2289 end.expr, se->string_length);
2290 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2291 boolean_type_node, nonempty, fault);
2292 if (name)
2293 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2294 "exceeds string length (%%ld)", name);
2295 else
2296 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2297 "exceeds string length (%%ld)");
2298 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2299 fold_convert (long_integer_type_node, end.expr),
2300 fold_convert (long_integer_type_node,
2301 se->string_length));
2302 free (msg);
2305 /* Try to calculate the length from the start and end expressions. */
2306 if (ref->u.ss.end
2307 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2309 int i_len;
2311 i_len = mpz_get_si (length) + 1;
2312 if (i_len < 0)
2313 i_len = 0;
2315 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2316 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2318 else
2320 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2321 end.expr, start.expr);
2322 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2323 build_int_cst (gfc_charlen_type_node, 1), tmp);
2324 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2325 tmp, build_int_cst (gfc_charlen_type_node, 0));
2328 se->string_length = tmp;
2332 /* Convert a derived type component reference. */
2334 static void
2335 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2337 gfc_component *c;
2338 tree tmp;
2339 tree decl;
2340 tree field;
2341 tree context;
2343 c = ref->u.c.component;
2345 if (c->backend_decl == NULL_TREE
2346 && ref->u.c.sym != NULL)
2347 gfc_get_derived_type (ref->u.c.sym);
2349 field = c->backend_decl;
2350 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2351 decl = se->expr;
2352 context = DECL_FIELD_CONTEXT (field);
2354 /* Components can correspond to fields of different containing
2355 types, as components are created without context, whereas
2356 a concrete use of a component has the type of decl as context.
2357 So, if the type doesn't match, we search the corresponding
2358 FIELD_DECL in the parent type. To not waste too much time
2359 we cache this result in norestrict_decl.
2360 On the other hand, if the context is a UNION or a MAP (a
2361 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2363 if (context != TREE_TYPE (decl)
2364 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2365 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2367 tree f2 = c->norestrict_decl;
2368 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2369 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2370 if (TREE_CODE (f2) == FIELD_DECL
2371 && DECL_NAME (f2) == DECL_NAME (field))
2372 break;
2373 gcc_assert (f2);
2374 c->norestrict_decl = f2;
2375 field = f2;
2378 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2379 && strcmp ("_data", c->name) == 0)
2381 /* Found a ref to the _data component. Store the associated ref to
2382 the vptr in se->class_vptr. */
2383 se->class_vptr = gfc_class_vptr_get (decl);
2385 else
2386 se->class_vptr = NULL_TREE;
2388 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2389 decl, field, NULL_TREE);
2391 se->expr = tmp;
2393 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2394 strlen () conditional below. */
2395 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2396 && !(c->attr.allocatable && c->ts.deferred))
2398 tmp = c->ts.u.cl->backend_decl;
2399 /* Components must always be constant length. */
2400 gcc_assert (tmp && INTEGER_CST_P (tmp));
2401 se->string_length = tmp;
2404 if (gfc_deferred_strlen (c, &field))
2406 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2407 TREE_TYPE (field),
2408 decl, field, NULL_TREE);
2409 se->string_length = tmp;
2412 if (((c->attr.pointer || c->attr.allocatable)
2413 && (!c->attr.dimension && !c->attr.codimension)
2414 && c->ts.type != BT_CHARACTER)
2415 || c->attr.proc_pointer)
2416 se->expr = build_fold_indirect_ref_loc (input_location,
2417 se->expr);
2421 /* This function deals with component references to components of the
2422 parent type for derived type extensions. */
2423 static void
2424 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2426 gfc_component *c;
2427 gfc_component *cmp;
2428 gfc_symbol *dt;
2429 gfc_ref parent;
2431 dt = ref->u.c.sym;
2432 c = ref->u.c.component;
2434 /* Return if the component is in the parent type. */
2435 for (cmp = dt->components; cmp; cmp = cmp->next)
2436 if (strcmp (c->name, cmp->name) == 0)
2437 return;
2439 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2440 parent.type = REF_COMPONENT;
2441 parent.next = NULL;
2442 parent.u.c.sym = dt;
2443 parent.u.c.component = dt->components;
2445 if (dt->backend_decl == NULL)
2446 gfc_get_derived_type (dt);
2448 /* Build the reference and call self. */
2449 gfc_conv_component_ref (se, &parent);
2450 parent.u.c.sym = dt->components->ts.u.derived;
2451 parent.u.c.component = c;
2452 conv_parent_component_references (se, &parent);
2455 /* Return the contents of a variable. Also handles reference/pointer
2456 variables (all Fortran pointer references are implicit). */
2458 static void
2459 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2461 gfc_ss *ss;
2462 gfc_ref *ref;
2463 gfc_symbol *sym;
2464 tree parent_decl = NULL_TREE;
2465 int parent_flag;
2466 bool return_value;
2467 bool alternate_entry;
2468 bool entry_master;
2469 bool is_classarray;
2470 bool first_time = true;
2472 sym = expr->symtree->n.sym;
2473 is_classarray = IS_CLASS_ARRAY (sym);
2474 ss = se->ss;
2475 if (ss != NULL)
2477 gfc_ss_info *ss_info = ss->info;
2479 /* Check that something hasn't gone horribly wrong. */
2480 gcc_assert (ss != gfc_ss_terminator);
2481 gcc_assert (ss_info->expr == expr);
2483 /* A scalarized term. We already know the descriptor. */
2484 se->expr = ss_info->data.array.descriptor;
2485 se->string_length = ss_info->string_length;
2486 ref = ss_info->data.array.ref;
2487 if (ref)
2488 gcc_assert (ref->type == REF_ARRAY
2489 && ref->u.ar.type != AR_ELEMENT);
2490 else
2491 gfc_conv_tmp_array_ref (se);
2493 else
2495 tree se_expr = NULL_TREE;
2497 se->expr = gfc_get_symbol_decl (sym);
2499 /* Deal with references to a parent results or entries by storing
2500 the current_function_decl and moving to the parent_decl. */
2501 return_value = sym->attr.function && sym->result == sym;
2502 alternate_entry = sym->attr.function && sym->attr.entry
2503 && sym->result == sym;
2504 entry_master = sym->attr.result
2505 && sym->ns->proc_name->attr.entry_master
2506 && !gfc_return_by_reference (sym->ns->proc_name);
2507 if (current_function_decl)
2508 parent_decl = DECL_CONTEXT (current_function_decl);
2510 if ((se->expr == parent_decl && return_value)
2511 || (sym->ns && sym->ns->proc_name
2512 && parent_decl
2513 && sym->ns->proc_name->backend_decl == parent_decl
2514 && (alternate_entry || entry_master)))
2515 parent_flag = 1;
2516 else
2517 parent_flag = 0;
2519 /* Special case for assigning the return value of a function.
2520 Self recursive functions must have an explicit return value. */
2521 if (return_value && (se->expr == current_function_decl || parent_flag))
2522 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2524 /* Similarly for alternate entry points. */
2525 else if (alternate_entry
2526 && (sym->ns->proc_name->backend_decl == current_function_decl
2527 || parent_flag))
2529 gfc_entry_list *el = NULL;
2531 for (el = sym->ns->entries; el; el = el->next)
2532 if (sym == el->sym)
2534 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2535 break;
2539 else if (entry_master
2540 && (sym->ns->proc_name->backend_decl == current_function_decl
2541 || parent_flag))
2542 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2544 if (se_expr)
2545 se->expr = se_expr;
2547 /* Procedure actual arguments. Look out for temporary variables
2548 with the same attributes as function values. */
2549 else if (!sym->attr.temporary
2550 && sym->attr.flavor == FL_PROCEDURE
2551 && se->expr != current_function_decl)
2553 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2555 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2556 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2558 return;
2562 /* Dereference the expression, where needed. Since characters
2563 are entirely different from other types, they are treated
2564 separately. */
2565 if (sym->ts.type == BT_CHARACTER)
2567 /* Dereference character pointer dummy arguments
2568 or results. */
2569 if ((sym->attr.pointer || sym->attr.allocatable)
2570 && (sym->attr.dummy
2571 || sym->attr.function
2572 || sym->attr.result))
2573 se->expr = build_fold_indirect_ref_loc (input_location,
2574 se->expr);
2577 else if (!sym->attr.value)
2579 /* Dereference temporaries for class array dummy arguments. */
2580 if (sym->attr.dummy && is_classarray
2581 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2583 if (!se->descriptor_only)
2584 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2586 se->expr = build_fold_indirect_ref_loc (input_location,
2587 se->expr);
2590 /* Dereference non-character scalar dummy arguments. */
2591 if (sym->attr.dummy && !sym->attr.dimension
2592 && !(sym->attr.codimension && sym->attr.allocatable)
2593 && (sym->ts.type != BT_CLASS
2594 || (!CLASS_DATA (sym)->attr.dimension
2595 && !(CLASS_DATA (sym)->attr.codimension
2596 && CLASS_DATA (sym)->attr.allocatable))))
2597 se->expr = build_fold_indirect_ref_loc (input_location,
2598 se->expr);
2600 /* Dereference scalar hidden result. */
2601 if (flag_f2c && sym->ts.type == BT_COMPLEX
2602 && (sym->attr.function || sym->attr.result)
2603 && !sym->attr.dimension && !sym->attr.pointer
2604 && !sym->attr.always_explicit)
2605 se->expr = build_fold_indirect_ref_loc (input_location,
2606 se->expr);
2608 /* Dereference non-character, non-class pointer variables.
2609 These must be dummies, results, or scalars. */
2610 if (!is_classarray
2611 && (sym->attr.pointer || sym->attr.allocatable
2612 || gfc_is_associate_pointer (sym)
2613 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2614 && (sym->attr.dummy
2615 || sym->attr.function
2616 || sym->attr.result
2617 || (!sym->attr.dimension
2618 && (!sym->attr.codimension || !sym->attr.allocatable))))
2619 se->expr = build_fold_indirect_ref_loc (input_location,
2620 se->expr);
2621 /* Now treat the class array pointer variables accordingly. */
2622 else if (sym->ts.type == BT_CLASS
2623 && sym->attr.dummy
2624 && (CLASS_DATA (sym)->attr.dimension
2625 || CLASS_DATA (sym)->attr.codimension)
2626 && ((CLASS_DATA (sym)->as
2627 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2628 || CLASS_DATA (sym)->attr.allocatable
2629 || CLASS_DATA (sym)->attr.class_pointer))
2630 se->expr = build_fold_indirect_ref_loc (input_location,
2631 se->expr);
2632 /* And the case where a non-dummy, non-result, non-function,
2633 non-allotable and non-pointer classarray is present. This case was
2634 previously covered by the first if, but with introducing the
2635 condition !is_classarray there, that case has to be covered
2636 explicitly. */
2637 else if (sym->ts.type == BT_CLASS
2638 && !sym->attr.dummy
2639 && !sym->attr.function
2640 && !sym->attr.result
2641 && (CLASS_DATA (sym)->attr.dimension
2642 || CLASS_DATA (sym)->attr.codimension)
2643 && (sym->assoc
2644 || !CLASS_DATA (sym)->attr.allocatable)
2645 && !CLASS_DATA (sym)->attr.class_pointer)
2646 se->expr = build_fold_indirect_ref_loc (input_location,
2647 se->expr);
2650 ref = expr->ref;
2653 /* For character variables, also get the length. */
2654 if (sym->ts.type == BT_CHARACTER)
2656 /* If the character length of an entry isn't set, get the length from
2657 the master function instead. */
2658 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2659 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2660 else
2661 se->string_length = sym->ts.u.cl->backend_decl;
2662 gcc_assert (se->string_length);
2665 while (ref)
2667 switch (ref->type)
2669 case REF_ARRAY:
2670 /* Return the descriptor if that's what we want and this is an array
2671 section reference. */
2672 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2673 return;
2674 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2675 /* Return the descriptor for array pointers and allocations. */
2676 if (se->want_pointer
2677 && ref->next == NULL && (se->descriptor_only))
2678 return;
2680 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2681 /* Return a pointer to an element. */
2682 break;
2684 case REF_COMPONENT:
2685 if (first_time && is_classarray && sym->attr.dummy
2686 && se->descriptor_only
2687 && !CLASS_DATA (sym)->attr.allocatable
2688 && !CLASS_DATA (sym)->attr.class_pointer
2689 && CLASS_DATA (sym)->as
2690 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2691 && strcmp ("_data", ref->u.c.component->name) == 0)
2692 /* Skip the first ref of a _data component, because for class
2693 arrays that one is already done by introducing a temporary
2694 array descriptor. */
2695 break;
2697 if (ref->u.c.sym->attr.extension)
2698 conv_parent_component_references (se, ref);
2700 gfc_conv_component_ref (se, ref);
2701 if (!ref->next && ref->u.c.sym->attr.codimension
2702 && se->want_pointer && se->descriptor_only)
2703 return;
2705 break;
2707 case REF_SUBSTRING:
2708 gfc_conv_substring (se, ref, expr->ts.kind,
2709 expr->symtree->name, &expr->where);
2710 break;
2712 default:
2713 gcc_unreachable ();
2714 break;
2716 first_time = false;
2717 ref = ref->next;
2719 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2720 separately. */
2721 if (se->want_pointer)
2723 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2724 gfc_conv_string_parameter (se);
2725 else
2726 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2731 /* Unary ops are easy... Or they would be if ! was a valid op. */
2733 static void
2734 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2736 gfc_se operand;
2737 tree type;
2739 gcc_assert (expr->ts.type != BT_CHARACTER);
2740 /* Initialize the operand. */
2741 gfc_init_se (&operand, se);
2742 gfc_conv_expr_val (&operand, expr->value.op.op1);
2743 gfc_add_block_to_block (&se->pre, &operand.pre);
2745 type = gfc_typenode_for_spec (&expr->ts);
2747 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2748 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2749 All other unary operators have an equivalent GIMPLE unary operator. */
2750 if (code == TRUTH_NOT_EXPR)
2751 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2752 build_int_cst (type, 0));
2753 else
2754 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2758 /* Expand power operator to optimal multiplications when a value is raised
2759 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2760 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2761 Programming", 3rd Edition, 1998. */
2763 /* This code is mostly duplicated from expand_powi in the backend.
2764 We establish the "optimal power tree" lookup table with the defined size.
2765 The items in the table are the exponents used to calculate the index
2766 exponents. Any integer n less than the value can get an "addition chain",
2767 with the first node being one. */
2768 #define POWI_TABLE_SIZE 256
2770 /* The table is from builtins.c. */
2771 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2773 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2774 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2775 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2776 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2777 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2778 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2779 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2780 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2781 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2782 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2783 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2784 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2785 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2786 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2787 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2788 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2789 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2790 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2791 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2792 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2793 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2794 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2795 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2796 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2797 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2798 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2799 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2800 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2801 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2802 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2803 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2804 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2807 /* If n is larger than lookup table's max index, we use the "window
2808 method". */
2809 #define POWI_WINDOW_SIZE 3
2811 /* Recursive function to expand the power operator. The temporary
2812 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2813 static tree
2814 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2816 tree op0;
2817 tree op1;
2818 tree tmp;
2819 int digit;
2821 if (n < POWI_TABLE_SIZE)
2823 if (tmpvar[n])
2824 return tmpvar[n];
2826 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2827 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2829 else if (n & 1)
2831 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2832 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2833 op1 = gfc_conv_powi (se, digit, tmpvar);
2835 else
2837 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2838 op1 = op0;
2841 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2842 tmp = gfc_evaluate_now (tmp, &se->pre);
2844 if (n < POWI_TABLE_SIZE)
2845 tmpvar[n] = tmp;
2847 return tmp;
2851 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2852 return 1. Else return 0 and a call to runtime library functions
2853 will have to be built. */
2854 static int
2855 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2857 tree cond;
2858 tree tmp;
2859 tree type;
2860 tree vartmp[POWI_TABLE_SIZE];
2861 HOST_WIDE_INT m;
2862 unsigned HOST_WIDE_INT n;
2863 int sgn;
2864 wide_int wrhs = rhs;
2866 /* If exponent is too large, we won't expand it anyway, so don't bother
2867 with large integer values. */
2868 if (!wi::fits_shwi_p (wrhs))
2869 return 0;
2871 m = wrhs.to_shwi ();
2872 /* Use the wide_int's routine to reliably get the absolute value on all
2873 platforms. Then convert it to a HOST_WIDE_INT like above. */
2874 n = wi::abs (wrhs).to_shwi ();
2876 type = TREE_TYPE (lhs);
2877 sgn = tree_int_cst_sgn (rhs);
2879 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2880 || optimize_size) && (m > 2 || m < -1))
2881 return 0;
2883 /* rhs == 0 */
2884 if (sgn == 0)
2886 se->expr = gfc_build_const (type, integer_one_node);
2887 return 1;
2890 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2891 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2893 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2894 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2895 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2896 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2898 /* If rhs is even,
2899 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2900 if ((n & 1) == 0)
2902 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2903 boolean_type_node, tmp, cond);
2904 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2905 tmp, build_int_cst (type, 1),
2906 build_int_cst (type, 0));
2907 return 1;
2909 /* If rhs is odd,
2910 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2911 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
2912 build_int_cst (type, -1),
2913 build_int_cst (type, 0));
2914 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2915 cond, build_int_cst (type, 1), tmp);
2916 return 1;
2919 memset (vartmp, 0, sizeof (vartmp));
2920 vartmp[1] = lhs;
2921 if (sgn == -1)
2923 tmp = gfc_build_const (type, integer_one_node);
2924 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
2925 vartmp[1]);
2928 se->expr = gfc_conv_powi (se, n, vartmp);
2930 return 1;
2934 /* Power op (**). Constant integer exponent has special handling. */
2936 static void
2937 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
2939 tree gfc_int4_type_node;
2940 int kind;
2941 int ikind;
2942 int res_ikind_1, res_ikind_2;
2943 gfc_se lse;
2944 gfc_se rse;
2945 tree fndecl = NULL;
2947 gfc_init_se (&lse, se);
2948 gfc_conv_expr_val (&lse, expr->value.op.op1);
2949 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
2950 gfc_add_block_to_block (&se->pre, &lse.pre);
2952 gfc_init_se (&rse, se);
2953 gfc_conv_expr_val (&rse, expr->value.op.op2);
2954 gfc_add_block_to_block (&se->pre, &rse.pre);
2956 if (expr->value.op.op2->ts.type == BT_INTEGER
2957 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
2958 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
2959 return;
2961 gfc_int4_type_node = gfc_get_int_type (4);
2963 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2964 library routine. But in the end, we have to convert the result back
2965 if this case applies -- with res_ikind_K, we keep track whether operand K
2966 falls into this case. */
2967 res_ikind_1 = -1;
2968 res_ikind_2 = -1;
2970 kind = expr->value.op.op1->ts.kind;
2971 switch (expr->value.op.op2->ts.type)
2973 case BT_INTEGER:
2974 ikind = expr->value.op.op2->ts.kind;
2975 switch (ikind)
2977 case 1:
2978 case 2:
2979 rse.expr = convert (gfc_int4_type_node, rse.expr);
2980 res_ikind_2 = ikind;
2981 /* Fall through. */
2983 case 4:
2984 ikind = 0;
2985 break;
2987 case 8:
2988 ikind = 1;
2989 break;
2991 case 16:
2992 ikind = 2;
2993 break;
2995 default:
2996 gcc_unreachable ();
2998 switch (kind)
3000 case 1:
3001 case 2:
3002 if (expr->value.op.op1->ts.type == BT_INTEGER)
3004 lse.expr = convert (gfc_int4_type_node, lse.expr);
3005 res_ikind_1 = kind;
3007 else
3008 gcc_unreachable ();
3009 /* Fall through. */
3011 case 4:
3012 kind = 0;
3013 break;
3015 case 8:
3016 kind = 1;
3017 break;
3019 case 10:
3020 kind = 2;
3021 break;
3023 case 16:
3024 kind = 3;
3025 break;
3027 default:
3028 gcc_unreachable ();
3031 switch (expr->value.op.op1->ts.type)
3033 case BT_INTEGER:
3034 if (kind == 3) /* Case 16 was not handled properly above. */
3035 kind = 2;
3036 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3037 break;
3039 case BT_REAL:
3040 /* Use builtins for real ** int4. */
3041 if (ikind == 0)
3043 switch (kind)
3045 case 0:
3046 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3047 break;
3049 case 1:
3050 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3051 break;
3053 case 2:
3054 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3055 break;
3057 case 3:
3058 /* Use the __builtin_powil() only if real(kind=16) is
3059 actually the C long double type. */
3060 if (!gfc_real16_is_float128)
3061 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3062 break;
3064 default:
3065 gcc_unreachable ();
3069 /* If we don't have a good builtin for this, go for the
3070 library function. */
3071 if (!fndecl)
3072 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3073 break;
3075 case BT_COMPLEX:
3076 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3077 break;
3079 default:
3080 gcc_unreachable ();
3082 break;
3084 case BT_REAL:
3085 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3086 break;
3088 case BT_COMPLEX:
3089 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3090 break;
3092 default:
3093 gcc_unreachable ();
3094 break;
3097 se->expr = build_call_expr_loc (input_location,
3098 fndecl, 2, lse.expr, rse.expr);
3100 /* Convert the result back if it is of wrong integer kind. */
3101 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3103 /* We want the maximum of both operand kinds as result. */
3104 if (res_ikind_1 < res_ikind_2)
3105 res_ikind_1 = res_ikind_2;
3106 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3111 /* Generate code to allocate a string temporary. */
3113 tree
3114 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3116 tree var;
3117 tree tmp;
3119 if (gfc_can_put_var_on_stack (len))
3121 /* Create a temporary variable to hold the result. */
3122 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3123 gfc_charlen_type_node, len,
3124 build_int_cst (gfc_charlen_type_node, 1));
3125 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
3127 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3128 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3129 else
3130 tmp = build_array_type (TREE_TYPE (type), tmp);
3132 var = gfc_create_var (tmp, "str");
3133 var = gfc_build_addr_expr (type, var);
3135 else
3137 /* Allocate a temporary to hold the result. */
3138 var = gfc_create_var (type, "pstr");
3139 gcc_assert (POINTER_TYPE_P (type));
3140 tmp = TREE_TYPE (type);
3141 if (TREE_CODE (tmp) == ARRAY_TYPE)
3142 tmp = TREE_TYPE (tmp);
3143 tmp = TYPE_SIZE_UNIT (tmp);
3144 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3145 fold_convert (size_type_node, len),
3146 fold_convert (size_type_node, tmp));
3147 tmp = gfc_call_malloc (&se->pre, type, tmp);
3148 gfc_add_modify (&se->pre, var, tmp);
3150 /* Free the temporary afterwards. */
3151 tmp = gfc_call_free (var);
3152 gfc_add_expr_to_block (&se->post, tmp);
3155 return var;
3159 /* Handle a string concatenation operation. A temporary will be allocated to
3160 hold the result. */
3162 static void
3163 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3165 gfc_se lse, rse;
3166 tree len, type, var, tmp, fndecl;
3168 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3169 && expr->value.op.op2->ts.type == BT_CHARACTER);
3170 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3172 gfc_init_se (&lse, se);
3173 gfc_conv_expr (&lse, expr->value.op.op1);
3174 gfc_conv_string_parameter (&lse);
3175 gfc_init_se (&rse, se);
3176 gfc_conv_expr (&rse, expr->value.op.op2);
3177 gfc_conv_string_parameter (&rse);
3179 gfc_add_block_to_block (&se->pre, &lse.pre);
3180 gfc_add_block_to_block (&se->pre, &rse.pre);
3182 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3183 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3184 if (len == NULL_TREE)
3186 len = fold_build2_loc (input_location, PLUS_EXPR,
3187 TREE_TYPE (lse.string_length),
3188 lse.string_length, rse.string_length);
3191 type = build_pointer_type (type);
3193 var = gfc_conv_string_tmp (se, type, len);
3195 /* Do the actual concatenation. */
3196 if (expr->ts.kind == 1)
3197 fndecl = gfor_fndecl_concat_string;
3198 else if (expr->ts.kind == 4)
3199 fndecl = gfor_fndecl_concat_string_char4;
3200 else
3201 gcc_unreachable ();
3203 tmp = build_call_expr_loc (input_location,
3204 fndecl, 6, len, var, lse.string_length, lse.expr,
3205 rse.string_length, rse.expr);
3206 gfc_add_expr_to_block (&se->pre, tmp);
3208 /* Add the cleanup for the operands. */
3209 gfc_add_block_to_block (&se->pre, &rse.post);
3210 gfc_add_block_to_block (&se->pre, &lse.post);
3212 se->expr = var;
3213 se->string_length = len;
3216 /* Translates an op expression. Common (binary) cases are handled by this
3217 function, others are passed on. Recursion is used in either case.
3218 We use the fact that (op1.ts == op2.ts) (except for the power
3219 operator **).
3220 Operators need no special handling for scalarized expressions as long as
3221 they call gfc_conv_simple_val to get their operands.
3222 Character strings get special handling. */
3224 static void
3225 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3227 enum tree_code code;
3228 gfc_se lse;
3229 gfc_se rse;
3230 tree tmp, type;
3231 int lop;
3232 int checkstring;
3234 checkstring = 0;
3235 lop = 0;
3236 switch (expr->value.op.op)
3238 case INTRINSIC_PARENTHESES:
3239 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3240 && flag_protect_parens)
3242 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3243 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3244 return;
3247 /* Fallthrough. */
3248 case INTRINSIC_UPLUS:
3249 gfc_conv_expr (se, expr->value.op.op1);
3250 return;
3252 case INTRINSIC_UMINUS:
3253 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3254 return;
3256 case INTRINSIC_NOT:
3257 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3258 return;
3260 case INTRINSIC_PLUS:
3261 code = PLUS_EXPR;
3262 break;
3264 case INTRINSIC_MINUS:
3265 code = MINUS_EXPR;
3266 break;
3268 case INTRINSIC_TIMES:
3269 code = MULT_EXPR;
3270 break;
3272 case INTRINSIC_DIVIDE:
3273 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3274 an integer, we must round towards zero, so we use a
3275 TRUNC_DIV_EXPR. */
3276 if (expr->ts.type == BT_INTEGER)
3277 code = TRUNC_DIV_EXPR;
3278 else
3279 code = RDIV_EXPR;
3280 break;
3282 case INTRINSIC_POWER:
3283 gfc_conv_power_op (se, expr);
3284 return;
3286 case INTRINSIC_CONCAT:
3287 gfc_conv_concat_op (se, expr);
3288 return;
3290 case INTRINSIC_AND:
3291 code = TRUTH_ANDIF_EXPR;
3292 lop = 1;
3293 break;
3295 case INTRINSIC_OR:
3296 code = TRUTH_ORIF_EXPR;
3297 lop = 1;
3298 break;
3300 /* EQV and NEQV only work on logicals, but since we represent them
3301 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3302 case INTRINSIC_EQ:
3303 case INTRINSIC_EQ_OS:
3304 case INTRINSIC_EQV:
3305 code = EQ_EXPR;
3306 checkstring = 1;
3307 lop = 1;
3308 break;
3310 case INTRINSIC_NE:
3311 case INTRINSIC_NE_OS:
3312 case INTRINSIC_NEQV:
3313 code = NE_EXPR;
3314 checkstring = 1;
3315 lop = 1;
3316 break;
3318 case INTRINSIC_GT:
3319 case INTRINSIC_GT_OS:
3320 code = GT_EXPR;
3321 checkstring = 1;
3322 lop = 1;
3323 break;
3325 case INTRINSIC_GE:
3326 case INTRINSIC_GE_OS:
3327 code = GE_EXPR;
3328 checkstring = 1;
3329 lop = 1;
3330 break;
3332 case INTRINSIC_LT:
3333 case INTRINSIC_LT_OS:
3334 code = LT_EXPR;
3335 checkstring = 1;
3336 lop = 1;
3337 break;
3339 case INTRINSIC_LE:
3340 case INTRINSIC_LE_OS:
3341 code = LE_EXPR;
3342 checkstring = 1;
3343 lop = 1;
3344 break;
3346 case INTRINSIC_USER:
3347 case INTRINSIC_ASSIGN:
3348 /* These should be converted into function calls by the frontend. */
3349 gcc_unreachable ();
3351 default:
3352 fatal_error (input_location, "Unknown intrinsic op");
3353 return;
3356 /* The only exception to this is **, which is handled separately anyway. */
3357 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3359 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3360 checkstring = 0;
3362 /* lhs */
3363 gfc_init_se (&lse, se);
3364 gfc_conv_expr (&lse, expr->value.op.op1);
3365 gfc_add_block_to_block (&se->pre, &lse.pre);
3367 /* rhs */
3368 gfc_init_se (&rse, se);
3369 gfc_conv_expr (&rse, expr->value.op.op2);
3370 gfc_add_block_to_block (&se->pre, &rse.pre);
3372 if (checkstring)
3374 gfc_conv_string_parameter (&lse);
3375 gfc_conv_string_parameter (&rse);
3377 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3378 rse.string_length, rse.expr,
3379 expr->value.op.op1->ts.kind,
3380 code);
3381 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3382 gfc_add_block_to_block (&lse.post, &rse.post);
3385 type = gfc_typenode_for_spec (&expr->ts);
3387 if (lop)
3389 /* The result of logical ops is always boolean_type_node. */
3390 tmp = fold_build2_loc (input_location, code, boolean_type_node,
3391 lse.expr, rse.expr);
3392 se->expr = convert (type, tmp);
3394 else
3395 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3397 /* Add the post blocks. */
3398 gfc_add_block_to_block (&se->post, &rse.post);
3399 gfc_add_block_to_block (&se->post, &lse.post);
3402 /* If a string's length is one, we convert it to a single character. */
3404 tree
3405 gfc_string_to_single_character (tree len, tree str, int kind)
3408 if (len == NULL
3409 || !tree_fits_uhwi_p (len)
3410 || !POINTER_TYPE_P (TREE_TYPE (str)))
3411 return NULL_TREE;
3413 if (TREE_INT_CST_LOW (len) == 1)
3415 str = fold_convert (gfc_get_pchar_type (kind), str);
3416 return build_fold_indirect_ref_loc (input_location, str);
3419 if (kind == 1
3420 && TREE_CODE (str) == ADDR_EXPR
3421 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3422 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3423 && array_ref_low_bound (TREE_OPERAND (str, 0))
3424 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3425 && TREE_INT_CST_LOW (len) > 1
3426 && TREE_INT_CST_LOW (len)
3427 == (unsigned HOST_WIDE_INT)
3428 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3430 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3431 ret = build_fold_indirect_ref_loc (input_location, ret);
3432 if (TREE_CODE (ret) == INTEGER_CST)
3434 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3435 int i, length = TREE_STRING_LENGTH (string_cst);
3436 const char *ptr = TREE_STRING_POINTER (string_cst);
3438 for (i = 1; i < length; i++)
3439 if (ptr[i] != ' ')
3440 return NULL_TREE;
3442 return ret;
3446 return NULL_TREE;
3450 void
3451 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3454 if (sym->backend_decl)
3456 /* This becomes the nominal_type in
3457 function.c:assign_parm_find_data_types. */
3458 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3459 /* This becomes the passed_type in
3460 function.c:assign_parm_find_data_types. C promotes char to
3461 integer for argument passing. */
3462 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3464 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3467 if (expr != NULL)
3469 /* If we have a constant character expression, make it into an
3470 integer. */
3471 if ((*expr)->expr_type == EXPR_CONSTANT)
3473 gfc_typespec ts;
3474 gfc_clear_ts (&ts);
3476 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3477 (int)(*expr)->value.character.string[0]);
3478 if ((*expr)->ts.kind != gfc_c_int_kind)
3480 /* The expr needs to be compatible with a C int. If the
3481 conversion fails, then the 2 causes an ICE. */
3482 ts.type = BT_INTEGER;
3483 ts.kind = gfc_c_int_kind;
3484 gfc_convert_type (*expr, &ts, 2);
3487 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3489 if ((*expr)->ref == NULL)
3491 se->expr = gfc_string_to_single_character
3492 (build_int_cst (integer_type_node, 1),
3493 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3494 gfc_get_symbol_decl
3495 ((*expr)->symtree->n.sym)),
3496 (*expr)->ts.kind);
3498 else
3500 gfc_conv_variable (se, *expr);
3501 se->expr = gfc_string_to_single_character
3502 (build_int_cst (integer_type_node, 1),
3503 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3504 se->expr),
3505 (*expr)->ts.kind);
3511 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3512 if STR is a string literal, otherwise return -1. */
3514 static int
3515 gfc_optimize_len_trim (tree len, tree str, int kind)
3517 if (kind == 1
3518 && TREE_CODE (str) == ADDR_EXPR
3519 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3520 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3521 && array_ref_low_bound (TREE_OPERAND (str, 0))
3522 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3523 && tree_fits_uhwi_p (len)
3524 && tree_to_uhwi (len) >= 1
3525 && tree_to_uhwi (len)
3526 == (unsigned HOST_WIDE_INT)
3527 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3529 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3530 folded = build_fold_indirect_ref_loc (input_location, folded);
3531 if (TREE_CODE (folded) == INTEGER_CST)
3533 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3534 int length = TREE_STRING_LENGTH (string_cst);
3535 const char *ptr = TREE_STRING_POINTER (string_cst);
3537 for (; length > 0; length--)
3538 if (ptr[length - 1] != ' ')
3539 break;
3541 return length;
3544 return -1;
3547 /* Helper to build a call to memcmp. */
3549 static tree
3550 build_memcmp_call (tree s1, tree s2, tree n)
3552 tree tmp;
3554 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3555 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3556 else
3557 s1 = fold_convert (pvoid_type_node, s1);
3559 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3560 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3561 else
3562 s2 = fold_convert (pvoid_type_node, s2);
3564 n = fold_convert (size_type_node, n);
3566 tmp = build_call_expr_loc (input_location,
3567 builtin_decl_explicit (BUILT_IN_MEMCMP),
3568 3, s1, s2, n);
3570 return fold_convert (integer_type_node, tmp);
3573 /* Compare two strings. If they are all single characters, the result is the
3574 subtraction of them. Otherwise, we build a library call. */
3576 tree
3577 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3578 enum tree_code code)
3580 tree sc1;
3581 tree sc2;
3582 tree fndecl;
3584 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3585 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3587 sc1 = gfc_string_to_single_character (len1, str1, kind);
3588 sc2 = gfc_string_to_single_character (len2, str2, kind);
3590 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3592 /* Deal with single character specially. */
3593 sc1 = fold_convert (integer_type_node, sc1);
3594 sc2 = fold_convert (integer_type_node, sc2);
3595 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3596 sc1, sc2);
3599 if ((code == EQ_EXPR || code == NE_EXPR)
3600 && optimize
3601 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3603 /* If one string is a string literal with LEN_TRIM longer
3604 than the length of the second string, the strings
3605 compare unequal. */
3606 int len = gfc_optimize_len_trim (len1, str1, kind);
3607 if (len > 0 && compare_tree_int (len2, len) < 0)
3608 return integer_one_node;
3609 len = gfc_optimize_len_trim (len2, str2, kind);
3610 if (len > 0 && compare_tree_int (len1, len) < 0)
3611 return integer_one_node;
3614 /* We can compare via memcpy if the strings are known to be equal
3615 in length and they are
3616 - kind=1
3617 - kind=4 and the comparison is for (in)equality. */
3619 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3620 && tree_int_cst_equal (len1, len2)
3621 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3623 tree tmp;
3624 tree chartype;
3626 chartype = gfc_get_char_type (kind);
3627 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3628 fold_convert (TREE_TYPE(len1),
3629 TYPE_SIZE_UNIT(chartype)),
3630 len1);
3631 return build_memcmp_call (str1, str2, tmp);
3634 /* Build a call for the comparison. */
3635 if (kind == 1)
3636 fndecl = gfor_fndecl_compare_string;
3637 else if (kind == 4)
3638 fndecl = gfor_fndecl_compare_string_char4;
3639 else
3640 gcc_unreachable ();
3642 return build_call_expr_loc (input_location, fndecl, 4,
3643 len1, str1, len2, str2);
3647 /* Return the backend_decl for a procedure pointer component. */
3649 static tree
3650 get_proc_ptr_comp (gfc_expr *e)
3652 gfc_se comp_se;
3653 gfc_expr *e2;
3654 expr_t old_type;
3656 gfc_init_se (&comp_se, NULL);
3657 e2 = gfc_copy_expr (e);
3658 /* We have to restore the expr type later so that gfc_free_expr frees
3659 the exact same thing that was allocated.
3660 TODO: This is ugly. */
3661 old_type = e2->expr_type;
3662 e2->expr_type = EXPR_VARIABLE;
3663 gfc_conv_expr (&comp_se, e2);
3664 e2->expr_type = old_type;
3665 gfc_free_expr (e2);
3666 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3670 /* Convert a typebound function reference from a class object. */
3671 static void
3672 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3674 gfc_ref *ref;
3675 tree var;
3677 if (!VAR_P (base_object))
3679 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3680 gfc_add_modify (&se->pre, var, base_object);
3682 se->expr = gfc_class_vptr_get (base_object);
3683 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3684 ref = expr->ref;
3685 while (ref && ref->next)
3686 ref = ref->next;
3687 gcc_assert (ref && ref->type == REF_COMPONENT);
3688 if (ref->u.c.sym->attr.extension)
3689 conv_parent_component_references (se, ref);
3690 gfc_conv_component_ref (se, ref);
3691 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3695 static void
3696 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3698 tree tmp;
3700 if (gfc_is_proc_ptr_comp (expr))
3701 tmp = get_proc_ptr_comp (expr);
3702 else if (sym->attr.dummy)
3704 tmp = gfc_get_symbol_decl (sym);
3705 if (sym->attr.proc_pointer)
3706 tmp = build_fold_indirect_ref_loc (input_location,
3707 tmp);
3708 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3709 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3711 else
3713 if (!sym->backend_decl)
3714 sym->backend_decl = gfc_get_extern_function_decl (sym);
3716 TREE_USED (sym->backend_decl) = 1;
3718 tmp = sym->backend_decl;
3720 if (sym->attr.cray_pointee)
3722 /* TODO - make the cray pointee a pointer to a procedure,
3723 assign the pointer to it and use it for the call. This
3724 will do for now! */
3725 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3726 gfc_get_symbol_decl (sym->cp_pointer));
3727 tmp = gfc_evaluate_now (tmp, &se->pre);
3730 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3732 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3733 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3736 se->expr = tmp;
3740 /* Initialize MAPPING. */
3742 void
3743 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3745 mapping->syms = NULL;
3746 mapping->charlens = NULL;
3750 /* Free all memory held by MAPPING (but not MAPPING itself). */
3752 void
3753 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3755 gfc_interface_sym_mapping *sym;
3756 gfc_interface_sym_mapping *nextsym;
3757 gfc_charlen *cl;
3758 gfc_charlen *nextcl;
3760 for (sym = mapping->syms; sym; sym = nextsym)
3762 nextsym = sym->next;
3763 sym->new_sym->n.sym->formal = NULL;
3764 gfc_free_symbol (sym->new_sym->n.sym);
3765 gfc_free_expr (sym->expr);
3766 free (sym->new_sym);
3767 free (sym);
3769 for (cl = mapping->charlens; cl; cl = nextcl)
3771 nextcl = cl->next;
3772 gfc_free_expr (cl->length);
3773 free (cl);
3778 /* Return a copy of gfc_charlen CL. Add the returned structure to
3779 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3781 static gfc_charlen *
3782 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3783 gfc_charlen * cl)
3785 gfc_charlen *new_charlen;
3787 new_charlen = gfc_get_charlen ();
3788 new_charlen->next = mapping->charlens;
3789 new_charlen->length = gfc_copy_expr (cl->length);
3791 mapping->charlens = new_charlen;
3792 return new_charlen;
3796 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3797 array variable that can be used as the actual argument for dummy
3798 argument SYM. Add any initialization code to BLOCK. PACKED is as
3799 for gfc_get_nodesc_array_type and DATA points to the first element
3800 in the passed array. */
3802 static tree
3803 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3804 gfc_packed packed, tree data)
3806 tree type;
3807 tree var;
3809 type = gfc_typenode_for_spec (&sym->ts);
3810 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3811 !sym->attr.target && !sym->attr.pointer
3812 && !sym->attr.proc_pointer);
3814 var = gfc_create_var (type, "ifm");
3815 gfc_add_modify (block, var, fold_convert (type, data));
3817 return var;
3821 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3822 and offset of descriptorless array type TYPE given that it has the same
3823 size as DESC. Add any set-up code to BLOCK. */
3825 static void
3826 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
3828 int n;
3829 tree dim;
3830 tree offset;
3831 tree tmp;
3833 offset = gfc_index_zero_node;
3834 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
3836 dim = gfc_rank_cst[n];
3837 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
3838 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
3840 GFC_TYPE_ARRAY_LBOUND (type, n)
3841 = gfc_conv_descriptor_lbound_get (desc, dim);
3842 GFC_TYPE_ARRAY_UBOUND (type, n)
3843 = gfc_conv_descriptor_ubound_get (desc, dim);
3845 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
3847 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3848 gfc_array_index_type,
3849 gfc_conv_descriptor_ubound_get (desc, dim),
3850 gfc_conv_descriptor_lbound_get (desc, dim));
3851 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3852 gfc_array_index_type,
3853 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
3854 tmp = gfc_evaluate_now (tmp, block);
3855 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
3857 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3858 GFC_TYPE_ARRAY_LBOUND (type, n),
3859 GFC_TYPE_ARRAY_STRIDE (type, n));
3860 offset = fold_build2_loc (input_location, MINUS_EXPR,
3861 gfc_array_index_type, offset, tmp);
3863 offset = gfc_evaluate_now (offset, block);
3864 GFC_TYPE_ARRAY_OFFSET (type) = offset;
3868 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3869 in SE. The caller may still use se->expr and se->string_length after
3870 calling this function. */
3872 void
3873 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
3874 gfc_symbol * sym, gfc_se * se,
3875 gfc_expr *expr)
3877 gfc_interface_sym_mapping *sm;
3878 tree desc;
3879 tree tmp;
3880 tree value;
3881 gfc_symbol *new_sym;
3882 gfc_symtree *root;
3883 gfc_symtree *new_symtree;
3885 /* Create a new symbol to represent the actual argument. */
3886 new_sym = gfc_new_symbol (sym->name, NULL);
3887 new_sym->ts = sym->ts;
3888 new_sym->as = gfc_copy_array_spec (sym->as);
3889 new_sym->attr.referenced = 1;
3890 new_sym->attr.dimension = sym->attr.dimension;
3891 new_sym->attr.contiguous = sym->attr.contiguous;
3892 new_sym->attr.codimension = sym->attr.codimension;
3893 new_sym->attr.pointer = sym->attr.pointer;
3894 new_sym->attr.allocatable = sym->attr.allocatable;
3895 new_sym->attr.flavor = sym->attr.flavor;
3896 new_sym->attr.function = sym->attr.function;
3898 /* Ensure that the interface is available and that
3899 descriptors are passed for array actual arguments. */
3900 if (sym->attr.flavor == FL_PROCEDURE)
3902 new_sym->formal = expr->symtree->n.sym->formal;
3903 new_sym->attr.always_explicit
3904 = expr->symtree->n.sym->attr.always_explicit;
3907 /* Create a fake symtree for it. */
3908 root = NULL;
3909 new_symtree = gfc_new_symtree (&root, sym->name);
3910 new_symtree->n.sym = new_sym;
3911 gcc_assert (new_symtree == root);
3913 /* Create a dummy->actual mapping. */
3914 sm = XCNEW (gfc_interface_sym_mapping);
3915 sm->next = mapping->syms;
3916 sm->old = sym;
3917 sm->new_sym = new_symtree;
3918 sm->expr = gfc_copy_expr (expr);
3919 mapping->syms = sm;
3921 /* Stabilize the argument's value. */
3922 if (!sym->attr.function && se)
3923 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3925 if (sym->ts.type == BT_CHARACTER)
3927 /* Create a copy of the dummy argument's length. */
3928 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
3929 sm->expr->ts.u.cl = new_sym->ts.u.cl;
3931 /* If the length is specified as "*", record the length that
3932 the caller is passing. We should use the callee's length
3933 in all other cases. */
3934 if (!new_sym->ts.u.cl->length && se)
3936 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
3937 new_sym->ts.u.cl->backend_decl = se->string_length;
3941 if (!se)
3942 return;
3944 /* Use the passed value as-is if the argument is a function. */
3945 if (sym->attr.flavor == FL_PROCEDURE)
3946 value = se->expr;
3948 /* If the argument is a pass-by-value scalar, use the value as is. */
3949 else if (!sym->attr.dimension && sym->attr.value)
3950 value = se->expr;
3952 /* If the argument is either a string or a pointer to a string,
3953 convert it to a boundless character type. */
3954 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
3956 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
3957 tmp = build_pointer_type (tmp);
3958 if (sym->attr.pointer)
3959 value = build_fold_indirect_ref_loc (input_location,
3960 se->expr);
3961 else
3962 value = se->expr;
3963 value = fold_convert (tmp, value);
3966 /* If the argument is a scalar, a pointer to an array or an allocatable,
3967 dereference it. */
3968 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
3969 value = build_fold_indirect_ref_loc (input_location,
3970 se->expr);
3972 /* For character(*), use the actual argument's descriptor. */
3973 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
3974 value = build_fold_indirect_ref_loc (input_location,
3975 se->expr);
3977 /* If the argument is an array descriptor, use it to determine
3978 information about the actual argument's shape. */
3979 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
3980 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
3982 /* Get the actual argument's descriptor. */
3983 desc = build_fold_indirect_ref_loc (input_location,
3984 se->expr);
3986 /* Create the replacement variable. */
3987 tmp = gfc_conv_descriptor_data_get (desc);
3988 value = gfc_get_interface_mapping_array (&se->pre, sym,
3989 PACKED_NO, tmp);
3991 /* Use DESC to work out the upper bounds, strides and offset. */
3992 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
3994 else
3995 /* Otherwise we have a packed array. */
3996 value = gfc_get_interface_mapping_array (&se->pre, sym,
3997 PACKED_FULL, se->expr);
3999 new_sym->backend_decl = value;
4003 /* Called once all dummy argument mappings have been added to MAPPING,
4004 but before the mapping is used to evaluate expressions. Pre-evaluate
4005 the length of each argument, adding any initialization code to PRE and
4006 any finalization code to POST. */
4008 void
4009 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4010 stmtblock_t * pre, stmtblock_t * post)
4012 gfc_interface_sym_mapping *sym;
4013 gfc_expr *expr;
4014 gfc_se se;
4016 for (sym = mapping->syms; sym; sym = sym->next)
4017 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4018 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4020 expr = sym->new_sym->n.sym->ts.u.cl->length;
4021 gfc_apply_interface_mapping_to_expr (mapping, expr);
4022 gfc_init_se (&se, NULL);
4023 gfc_conv_expr (&se, expr);
4024 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4025 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4026 gfc_add_block_to_block (pre, &se.pre);
4027 gfc_add_block_to_block (post, &se.post);
4029 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4034 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4035 constructor C. */
4037 static void
4038 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4039 gfc_constructor_base base)
4041 gfc_constructor *c;
4042 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4044 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4045 if (c->iterator)
4047 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4048 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4049 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4055 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4056 reference REF. */
4058 static void
4059 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4060 gfc_ref * ref)
4062 int n;
4064 for (; ref; ref = ref->next)
4065 switch (ref->type)
4067 case REF_ARRAY:
4068 for (n = 0; n < ref->u.ar.dimen; n++)
4070 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4071 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4072 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4074 break;
4076 case REF_COMPONENT:
4077 break;
4079 case REF_SUBSTRING:
4080 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4081 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4082 break;
4087 /* Convert intrinsic function calls into result expressions. */
4089 static bool
4090 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4092 gfc_symbol *sym;
4093 gfc_expr *new_expr;
4094 gfc_expr *arg1;
4095 gfc_expr *arg2;
4096 int d, dup;
4098 arg1 = expr->value.function.actual->expr;
4099 if (expr->value.function.actual->next)
4100 arg2 = expr->value.function.actual->next->expr;
4101 else
4102 arg2 = NULL;
4104 sym = arg1->symtree->n.sym;
4106 if (sym->attr.dummy)
4107 return false;
4109 new_expr = NULL;
4111 switch (expr->value.function.isym->id)
4113 case GFC_ISYM_LEN:
4114 /* TODO figure out why this condition is necessary. */
4115 if (sym->attr.function
4116 && (arg1->ts.u.cl->length == NULL
4117 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4118 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4119 return false;
4121 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4122 break;
4124 case GFC_ISYM_LEN_TRIM:
4125 new_expr = gfc_copy_expr (arg1);
4126 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4128 if (!new_expr)
4129 return false;
4131 gfc_replace_expr (arg1, new_expr);
4132 return true;
4134 case GFC_ISYM_SIZE:
4135 if (!sym->as || sym->as->rank == 0)
4136 return false;
4138 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4140 dup = mpz_get_si (arg2->value.integer);
4141 d = dup - 1;
4143 else
4145 dup = sym->as->rank;
4146 d = 0;
4149 for (; d < dup; d++)
4151 gfc_expr *tmp;
4153 if (!sym->as->upper[d] || !sym->as->lower[d])
4155 gfc_free_expr (new_expr);
4156 return false;
4159 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4160 gfc_get_int_expr (gfc_default_integer_kind,
4161 NULL, 1));
4162 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4163 if (new_expr)
4164 new_expr = gfc_multiply (new_expr, tmp);
4165 else
4166 new_expr = tmp;
4168 break;
4170 case GFC_ISYM_LBOUND:
4171 case GFC_ISYM_UBOUND:
4172 /* TODO These implementations of lbound and ubound do not limit if
4173 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4175 if (!sym->as || sym->as->rank == 0)
4176 return false;
4178 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4179 d = mpz_get_si (arg2->value.integer) - 1;
4180 else
4181 /* TODO: If the need arises, this could produce an array of
4182 ubound/lbounds. */
4183 gcc_unreachable ();
4185 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4187 if (sym->as->lower[d])
4188 new_expr = gfc_copy_expr (sym->as->lower[d]);
4190 else
4192 if (sym->as->upper[d])
4193 new_expr = gfc_copy_expr (sym->as->upper[d]);
4195 break;
4197 default:
4198 break;
4201 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4202 if (!new_expr)
4203 return false;
4205 gfc_replace_expr (expr, new_expr);
4206 return true;
4210 static void
4211 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4212 gfc_interface_mapping * mapping)
4214 gfc_formal_arglist *f;
4215 gfc_actual_arglist *actual;
4217 actual = expr->value.function.actual;
4218 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4220 for (; f && actual; f = f->next, actual = actual->next)
4222 if (!actual->expr)
4223 continue;
4225 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4228 if (map_expr->symtree->n.sym->attr.dimension)
4230 int d;
4231 gfc_array_spec *as;
4233 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4235 for (d = 0; d < as->rank; d++)
4237 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4238 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4241 expr->value.function.esym->as = as;
4244 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4246 expr->value.function.esym->ts.u.cl->length
4247 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4249 gfc_apply_interface_mapping_to_expr (mapping,
4250 expr->value.function.esym->ts.u.cl->length);
4255 /* EXPR is a copy of an expression that appeared in the interface
4256 associated with MAPPING. Walk it recursively looking for references to
4257 dummy arguments that MAPPING maps to actual arguments. Replace each such
4258 reference with a reference to the associated actual argument. */
4260 static void
4261 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4262 gfc_expr * expr)
4264 gfc_interface_sym_mapping *sym;
4265 gfc_actual_arglist *actual;
4267 if (!expr)
4268 return;
4270 /* Copying an expression does not copy its length, so do that here. */
4271 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4273 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4274 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4277 /* Apply the mapping to any references. */
4278 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4280 /* ...and to the expression's symbol, if it has one. */
4281 /* TODO Find out why the condition on expr->symtree had to be moved into
4282 the loop rather than being outside it, as originally. */
4283 for (sym = mapping->syms; sym; sym = sym->next)
4284 if (expr->symtree && sym->old == expr->symtree->n.sym)
4286 if (sym->new_sym->n.sym->backend_decl)
4287 expr->symtree = sym->new_sym;
4288 else if (sym->expr)
4289 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4292 /* ...and to subexpressions in expr->value. */
4293 switch (expr->expr_type)
4295 case EXPR_VARIABLE:
4296 case EXPR_CONSTANT:
4297 case EXPR_NULL:
4298 case EXPR_SUBSTRING:
4299 break;
4301 case EXPR_OP:
4302 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4303 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4304 break;
4306 case EXPR_FUNCTION:
4307 for (actual = expr->value.function.actual; actual; actual = actual->next)
4308 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4310 if (expr->value.function.esym == NULL
4311 && expr->value.function.isym != NULL
4312 && expr->value.function.actual->expr->symtree
4313 && gfc_map_intrinsic_function (expr, mapping))
4314 break;
4316 for (sym = mapping->syms; sym; sym = sym->next)
4317 if (sym->old == expr->value.function.esym)
4319 expr->value.function.esym = sym->new_sym->n.sym;
4320 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4321 expr->value.function.esym->result = sym->new_sym->n.sym;
4323 break;
4325 case EXPR_ARRAY:
4326 case EXPR_STRUCTURE:
4327 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4328 break;
4330 case EXPR_COMPCALL:
4331 case EXPR_PPC:
4332 gcc_unreachable ();
4333 break;
4336 return;
4340 /* Evaluate interface expression EXPR using MAPPING. Store the result
4341 in SE. */
4343 void
4344 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4345 gfc_se * se, gfc_expr * expr)
4347 expr = gfc_copy_expr (expr);
4348 gfc_apply_interface_mapping_to_expr (mapping, expr);
4349 gfc_conv_expr (se, expr);
4350 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4351 gfc_free_expr (expr);
4355 /* Returns a reference to a temporary array into which a component of
4356 an actual argument derived type array is copied and then returned
4357 after the function call. */
4358 void
4359 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4360 sym_intent intent, bool formal_ptr)
4362 gfc_se lse;
4363 gfc_se rse;
4364 gfc_ss *lss;
4365 gfc_ss *rss;
4366 gfc_loopinfo loop;
4367 gfc_loopinfo loop2;
4368 gfc_array_info *info;
4369 tree offset;
4370 tree tmp_index;
4371 tree tmp;
4372 tree base_type;
4373 tree size;
4374 stmtblock_t body;
4375 int n;
4376 int dimen;
4378 gfc_init_se (&lse, NULL);
4379 gfc_init_se (&rse, NULL);
4381 /* Walk the argument expression. */
4382 rss = gfc_walk_expr (expr);
4384 gcc_assert (rss != gfc_ss_terminator);
4386 /* Initialize the scalarizer. */
4387 gfc_init_loopinfo (&loop);
4388 gfc_add_ss_to_loop (&loop, rss);
4390 /* Calculate the bounds of the scalarization. */
4391 gfc_conv_ss_startstride (&loop);
4393 /* Build an ss for the temporary. */
4394 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4395 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4397 base_type = gfc_typenode_for_spec (&expr->ts);
4398 if (GFC_ARRAY_TYPE_P (base_type)
4399 || GFC_DESCRIPTOR_TYPE_P (base_type))
4400 base_type = gfc_get_element_type (base_type);
4402 if (expr->ts.type == BT_CLASS)
4403 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4405 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4406 ? expr->ts.u.cl->backend_decl
4407 : NULL),
4408 loop.dimen);
4410 parmse->string_length = loop.temp_ss->info->string_length;
4412 /* Associate the SS with the loop. */
4413 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4415 /* Setup the scalarizing loops. */
4416 gfc_conv_loop_setup (&loop, &expr->where);
4418 /* Pass the temporary descriptor back to the caller. */
4419 info = &loop.temp_ss->info->data.array;
4420 parmse->expr = info->descriptor;
4422 /* Setup the gfc_se structures. */
4423 gfc_copy_loopinfo_to_se (&lse, &loop);
4424 gfc_copy_loopinfo_to_se (&rse, &loop);
4426 rse.ss = rss;
4427 lse.ss = loop.temp_ss;
4428 gfc_mark_ss_chain_used (rss, 1);
4429 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4431 /* Start the scalarized loop body. */
4432 gfc_start_scalarized_body (&loop, &body);
4434 /* Translate the expression. */
4435 gfc_conv_expr (&rse, expr);
4437 /* Reset the offset for the function call since the loop
4438 is zero based on the data pointer. Note that the temp
4439 comes first in the loop chain since it is added second. */
4440 if (gfc_is_alloc_class_array_function (expr))
4442 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4443 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4444 gfc_index_zero_node);
4447 gfc_conv_tmp_array_ref (&lse);
4449 if (intent != INTENT_OUT)
4451 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4452 gfc_add_expr_to_block (&body, tmp);
4453 gcc_assert (rse.ss == gfc_ss_terminator);
4454 gfc_trans_scalarizing_loops (&loop, &body);
4456 else
4458 /* Make sure that the temporary declaration survives by merging
4459 all the loop declarations into the current context. */
4460 for (n = 0; n < loop.dimen; n++)
4462 gfc_merge_block_scope (&body);
4463 body = loop.code[loop.order[n]];
4465 gfc_merge_block_scope (&body);
4468 /* Add the post block after the second loop, so that any
4469 freeing of allocated memory is done at the right time. */
4470 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4472 /**********Copy the temporary back again.*********/
4474 gfc_init_se (&lse, NULL);
4475 gfc_init_se (&rse, NULL);
4477 /* Walk the argument expression. */
4478 lss = gfc_walk_expr (expr);
4479 rse.ss = loop.temp_ss;
4480 lse.ss = lss;
4482 /* Initialize the scalarizer. */
4483 gfc_init_loopinfo (&loop2);
4484 gfc_add_ss_to_loop (&loop2, lss);
4486 dimen = rse.ss->dimen;
4488 /* Skip the write-out loop for this case. */
4489 if (gfc_is_alloc_class_array_function (expr))
4490 goto class_array_fcn;
4492 /* Calculate the bounds of the scalarization. */
4493 gfc_conv_ss_startstride (&loop2);
4495 /* Setup the scalarizing loops. */
4496 gfc_conv_loop_setup (&loop2, &expr->where);
4498 gfc_copy_loopinfo_to_se (&lse, &loop2);
4499 gfc_copy_loopinfo_to_se (&rse, &loop2);
4501 gfc_mark_ss_chain_used (lss, 1);
4502 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4504 /* Declare the variable to hold the temporary offset and start the
4505 scalarized loop body. */
4506 offset = gfc_create_var (gfc_array_index_type, NULL);
4507 gfc_start_scalarized_body (&loop2, &body);
4509 /* Build the offsets for the temporary from the loop variables. The
4510 temporary array has lbounds of zero and strides of one in all
4511 dimensions, so this is very simple. The offset is only computed
4512 outside the innermost loop, so the overall transfer could be
4513 optimized further. */
4514 info = &rse.ss->info->data.array;
4516 tmp_index = gfc_index_zero_node;
4517 for (n = dimen - 1; n > 0; n--)
4519 tree tmp_str;
4520 tmp = rse.loop->loopvar[n];
4521 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4522 tmp, rse.loop->from[n]);
4523 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4524 tmp, tmp_index);
4526 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4527 gfc_array_index_type,
4528 rse.loop->to[n-1], rse.loop->from[n-1]);
4529 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4530 gfc_array_index_type,
4531 tmp_str, gfc_index_one_node);
4533 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4534 gfc_array_index_type, tmp, tmp_str);
4537 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4538 gfc_array_index_type,
4539 tmp_index, rse.loop->from[0]);
4540 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4542 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4543 gfc_array_index_type,
4544 rse.loop->loopvar[0], offset);
4546 /* Now use the offset for the reference. */
4547 tmp = build_fold_indirect_ref_loc (input_location,
4548 info->data);
4549 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4551 if (expr->ts.type == BT_CHARACTER)
4552 rse.string_length = expr->ts.u.cl->backend_decl;
4554 gfc_conv_expr (&lse, expr);
4556 gcc_assert (lse.ss == gfc_ss_terminator);
4558 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4559 gfc_add_expr_to_block (&body, tmp);
4561 /* Generate the copying loops. */
4562 gfc_trans_scalarizing_loops (&loop2, &body);
4564 /* Wrap the whole thing up by adding the second loop to the post-block
4565 and following it by the post-block of the first loop. In this way,
4566 if the temporary needs freeing, it is done after use! */
4567 if (intent != INTENT_IN)
4569 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4570 gfc_add_block_to_block (&parmse->post, &loop2.post);
4573 class_array_fcn:
4575 gfc_add_block_to_block (&parmse->post, &loop.post);
4577 gfc_cleanup_loop (&loop);
4578 gfc_cleanup_loop (&loop2);
4580 /* Pass the string length to the argument expression. */
4581 if (expr->ts.type == BT_CHARACTER)
4582 parmse->string_length = expr->ts.u.cl->backend_decl;
4584 /* Determine the offset for pointer formal arguments and set the
4585 lbounds to one. */
4586 if (formal_ptr)
4588 size = gfc_index_one_node;
4589 offset = gfc_index_zero_node;
4590 for (n = 0; n < dimen; n++)
4592 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4593 gfc_rank_cst[n]);
4594 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4595 gfc_array_index_type, tmp,
4596 gfc_index_one_node);
4597 gfc_conv_descriptor_ubound_set (&parmse->pre,
4598 parmse->expr,
4599 gfc_rank_cst[n],
4600 tmp);
4601 gfc_conv_descriptor_lbound_set (&parmse->pre,
4602 parmse->expr,
4603 gfc_rank_cst[n],
4604 gfc_index_one_node);
4605 size = gfc_evaluate_now (size, &parmse->pre);
4606 offset = fold_build2_loc (input_location, MINUS_EXPR,
4607 gfc_array_index_type,
4608 offset, size);
4609 offset = gfc_evaluate_now (offset, &parmse->pre);
4610 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4611 gfc_array_index_type,
4612 rse.loop->to[n], rse.loop->from[n]);
4613 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4614 gfc_array_index_type,
4615 tmp, gfc_index_one_node);
4616 size = fold_build2_loc (input_location, MULT_EXPR,
4617 gfc_array_index_type, size, tmp);
4620 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4621 offset);
4624 /* We want either the address for the data or the address of the descriptor,
4625 depending on the mode of passing array arguments. */
4626 if (g77)
4627 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4628 else
4629 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4631 return;
4635 /* Generate the code for argument list functions. */
4637 static void
4638 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4640 /* Pass by value for g77 %VAL(arg), pass the address
4641 indirectly for %LOC, else by reference. Thus %REF
4642 is a "do-nothing" and %LOC is the same as an F95
4643 pointer. */
4644 if (strncmp (name, "%VAL", 4) == 0)
4645 gfc_conv_expr (se, expr);
4646 else if (strncmp (name, "%LOC", 4) == 0)
4648 gfc_conv_expr_reference (se, expr);
4649 se->expr = gfc_build_addr_expr (NULL, se->expr);
4651 else if (strncmp (name, "%REF", 4) == 0)
4652 gfc_conv_expr_reference (se, expr);
4653 else
4654 gfc_error ("Unknown argument list function at %L", &expr->where);
4658 /* This function tells whether the middle-end representation of the expression
4659 E given as input may point to data otherwise accessible through a variable
4660 (sub-)reference.
4661 It is assumed that the only expressions that may alias are variables,
4662 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4663 may alias.
4664 This function is used to decide whether freeing an expression's allocatable
4665 components is safe or should be avoided.
4667 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4668 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4669 is necessary because for array constructors, aliasing depends on how
4670 the array is used:
4671 - If E is an array constructor used as argument to an elemental procedure,
4672 the array, which is generated through shallow copy by the scalarizer,
4673 is used directly and can alias the expressions it was copied from.
4674 - If E is an array constructor used as argument to a non-elemental
4675 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4676 the array as in the previous case, but then that array is used
4677 to initialize a new descriptor through deep copy. There is no alias
4678 possible in that case.
4679 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4680 above. */
4682 static bool
4683 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4685 gfc_constructor *c;
4687 if (e->expr_type == EXPR_VARIABLE)
4688 return true;
4689 else if (e->expr_type == EXPR_FUNCTION)
4691 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4693 if (proc_ifc->result != NULL
4694 && ((proc_ifc->result->ts.type == BT_CLASS
4695 && proc_ifc->result->ts.u.derived->attr.is_class
4696 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4697 || proc_ifc->result->attr.pointer))
4698 return true;
4699 else
4700 return false;
4702 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4703 return false;
4705 for (c = gfc_constructor_first (e->value.constructor);
4706 c; c = gfc_constructor_next (c))
4707 if (c->expr
4708 && expr_may_alias_variables (c->expr, array_may_alias))
4709 return true;
4711 return false;
4715 /* Generate code for a procedure call. Note can return se->post != NULL.
4716 If se->direct_byref is set then se->expr contains the return parameter.
4717 Return nonzero, if the call has alternate specifiers.
4718 'expr' is only needed for procedure pointer components. */
4721 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4722 gfc_actual_arglist * args, gfc_expr * expr,
4723 vec<tree, va_gc> *append_args)
4725 gfc_interface_mapping mapping;
4726 vec<tree, va_gc> *arglist;
4727 vec<tree, va_gc> *retargs;
4728 tree tmp;
4729 tree fntype;
4730 gfc_se parmse;
4731 gfc_array_info *info;
4732 int byref;
4733 int parm_kind;
4734 tree type;
4735 tree var;
4736 tree len;
4737 tree base_object;
4738 vec<tree, va_gc> *stringargs;
4739 vec<tree, va_gc> *optionalargs;
4740 tree result = NULL;
4741 gfc_formal_arglist *formal;
4742 gfc_actual_arglist *arg;
4743 int has_alternate_specifier = 0;
4744 bool need_interface_mapping;
4745 bool callee_alloc;
4746 bool ulim_copy;
4747 gfc_typespec ts;
4748 gfc_charlen cl;
4749 gfc_expr *e;
4750 gfc_symbol *fsym;
4751 stmtblock_t post;
4752 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4753 gfc_component *comp = NULL;
4754 int arglen;
4755 unsigned int argc;
4757 arglist = NULL;
4758 retargs = NULL;
4759 stringargs = NULL;
4760 optionalargs = NULL;
4761 var = NULL_TREE;
4762 len = NULL_TREE;
4763 gfc_clear_ts (&ts);
4765 comp = gfc_get_proc_ptr_comp (expr);
4767 bool elemental_proc = (comp
4768 && comp->ts.interface
4769 && comp->ts.interface->attr.elemental)
4770 || (comp && comp->attr.elemental)
4771 || sym->attr.elemental;
4773 if (se->ss != NULL)
4775 if (!elemental_proc)
4777 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4778 if (se->ss->info->useflags)
4780 gcc_assert ((!comp && gfc_return_by_reference (sym)
4781 && sym->result->attr.dimension)
4782 || (comp && comp->attr.dimension)
4783 || gfc_is_alloc_class_array_function (expr));
4784 gcc_assert (se->loop != NULL);
4785 /* Access the previously obtained result. */
4786 gfc_conv_tmp_array_ref (se);
4787 return 0;
4790 info = &se->ss->info->data.array;
4792 else
4793 info = NULL;
4795 gfc_init_block (&post);
4796 gfc_init_interface_mapping (&mapping);
4797 if (!comp)
4799 formal = gfc_sym_get_dummy_args (sym);
4800 need_interface_mapping = sym->attr.dimension ||
4801 (sym->ts.type == BT_CHARACTER
4802 && sym->ts.u.cl->length
4803 && sym->ts.u.cl->length->expr_type
4804 != EXPR_CONSTANT);
4806 else
4808 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4809 need_interface_mapping = comp->attr.dimension ||
4810 (comp->ts.type == BT_CHARACTER
4811 && comp->ts.u.cl->length
4812 && comp->ts.u.cl->length->expr_type
4813 != EXPR_CONSTANT);
4816 base_object = NULL_TREE;
4817 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4818 is the third and fourth argument to such a function call a value
4819 denoting the number of elements to copy (i.e., most of the time the
4820 length of a deferred length string). */
4821 ulim_copy = (formal == NULL)
4822 && UNLIMITED_POLY (sym)
4823 && comp && (strcmp ("_copy", comp->name) == 0);
4825 /* Evaluate the arguments. */
4826 for (arg = args, argc = 0; arg != NULL;
4827 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
4829 e = arg->expr;
4830 fsym = formal ? formal->sym : NULL;
4831 parm_kind = MISSING;
4833 /* If the procedure requires an explicit interface, the actual
4834 argument is passed according to the corresponding formal
4835 argument. If the corresponding formal argument is a POINTER,
4836 ALLOCATABLE or assumed shape, we do not use g77's calling
4837 convention, and pass the address of the array descriptor
4838 instead. Otherwise we use g77's calling convention, in other words
4839 pass the array data pointer without descriptor. */
4840 bool nodesc_arg = fsym != NULL
4841 && !(fsym->attr.pointer || fsym->attr.allocatable)
4842 && fsym->as
4843 && fsym->as->type != AS_ASSUMED_SHAPE
4844 && fsym->as->type != AS_ASSUMED_RANK;
4845 if (comp)
4846 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
4847 else
4848 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
4850 /* Class array expressions are sometimes coming completely unadorned
4851 with either arrayspec or _data component. Correct that here.
4852 OOP-TODO: Move this to the frontend. */
4853 if (e && e->expr_type == EXPR_VARIABLE
4854 && !e->ref
4855 && e->ts.type == BT_CLASS
4856 && (CLASS_DATA (e)->attr.codimension
4857 || CLASS_DATA (e)->attr.dimension))
4859 gfc_typespec temp_ts = e->ts;
4860 gfc_add_class_array_ref (e);
4861 e->ts = temp_ts;
4864 if (e == NULL)
4866 if (se->ignore_optional)
4868 /* Some intrinsics have already been resolved to the correct
4869 parameters. */
4870 continue;
4872 else if (arg->label)
4874 has_alternate_specifier = 1;
4875 continue;
4877 else
4879 gfc_init_se (&parmse, NULL);
4881 /* For scalar arguments with VALUE attribute which are passed by
4882 value, pass "0" and a hidden argument gives the optional
4883 status. */
4884 if (fsym && fsym->attr.optional && fsym->attr.value
4885 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
4886 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
4888 parmse.expr = fold_convert (gfc_sym_type (fsym),
4889 integer_zero_node);
4890 vec_safe_push (optionalargs, boolean_false_node);
4892 else
4894 /* Pass a NULL pointer for an absent arg. */
4895 parmse.expr = null_pointer_node;
4896 if (arg->missing_arg_type == BT_CHARACTER)
4897 parmse.string_length = build_int_cst (gfc_charlen_type_node,
4902 else if (arg->expr->expr_type == EXPR_NULL
4903 && fsym && !fsym->attr.pointer
4904 && (fsym->ts.type != BT_CLASS
4905 || !CLASS_DATA (fsym)->attr.class_pointer))
4907 /* Pass a NULL pointer to denote an absent arg. */
4908 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
4909 && (fsym->ts.type != BT_CLASS
4910 || !CLASS_DATA (fsym)->attr.allocatable));
4911 gfc_init_se (&parmse, NULL);
4912 parmse.expr = null_pointer_node;
4913 if (arg->missing_arg_type == BT_CHARACTER)
4914 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4916 else if (fsym && fsym->ts.type == BT_CLASS
4917 && e->ts.type == BT_DERIVED)
4919 /* The derived type needs to be converted to a temporary
4920 CLASS object. */
4921 gfc_init_se (&parmse, se);
4922 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
4923 fsym->attr.optional
4924 && e->expr_type == EXPR_VARIABLE
4925 && e->symtree->n.sym->attr.optional,
4926 CLASS_DATA (fsym)->attr.class_pointer
4927 || CLASS_DATA (fsym)->attr.allocatable);
4929 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
4931 /* The intrinsic type needs to be converted to a temporary
4932 CLASS object for the unlimited polymorphic formal. */
4933 gfc_init_se (&parmse, se);
4934 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
4936 else if (se->ss && se->ss->info->useflags)
4938 gfc_ss *ss;
4940 ss = se->ss;
4942 /* An elemental function inside a scalarized loop. */
4943 gfc_init_se (&parmse, se);
4944 parm_kind = ELEMENTAL;
4946 /* When no fsym is present, ulim_copy is set and this is a third or
4947 fourth argument, use call-by-value instead of by reference to
4948 hand the length properties to the copy routine (i.e., most of the
4949 time this will be a call to a __copy_character_* routine where the
4950 third and fourth arguments are the lengths of a deferred length
4951 char array). */
4952 if ((fsym && fsym->attr.value)
4953 || (ulim_copy && (argc == 2 || argc == 3)))
4954 gfc_conv_expr (&parmse, e);
4955 else
4956 gfc_conv_expr_reference (&parmse, e);
4958 if (e->ts.type == BT_CHARACTER && !e->rank
4959 && e->expr_type == EXPR_FUNCTION)
4960 parmse.expr = build_fold_indirect_ref_loc (input_location,
4961 parmse.expr);
4963 if (fsym && fsym->ts.type == BT_DERIVED
4964 && gfc_is_class_container_ref (e))
4966 parmse.expr = gfc_class_data_get (parmse.expr);
4968 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
4969 && e->symtree->n.sym->attr.optional)
4971 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
4972 parmse.expr = build3_loc (input_location, COND_EXPR,
4973 TREE_TYPE (parmse.expr),
4974 cond, parmse.expr,
4975 fold_convert (TREE_TYPE (parmse.expr),
4976 null_pointer_node));
4980 /* If we are passing an absent array as optional dummy to an
4981 elemental procedure, make sure that we pass NULL when the data
4982 pointer is NULL. We need this extra conditional because of
4983 scalarization which passes arrays elements to the procedure,
4984 ignoring the fact that the array can be absent/unallocated/... */
4985 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
4987 tree descriptor_data;
4989 descriptor_data = ss->info->data.array.data;
4990 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4991 descriptor_data,
4992 fold_convert (TREE_TYPE (descriptor_data),
4993 null_pointer_node));
4994 parmse.expr
4995 = fold_build3_loc (input_location, COND_EXPR,
4996 TREE_TYPE (parmse.expr),
4997 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
4998 fold_convert (TREE_TYPE (parmse.expr),
4999 null_pointer_node),
5000 parmse.expr);
5003 /* The scalarizer does not repackage the reference to a class
5004 array - instead it returns a pointer to the data element. */
5005 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5006 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5007 fsym->attr.intent != INTENT_IN
5008 && (CLASS_DATA (fsym)->attr.class_pointer
5009 || CLASS_DATA (fsym)->attr.allocatable),
5010 fsym->attr.optional
5011 && e->expr_type == EXPR_VARIABLE
5012 && e->symtree->n.sym->attr.optional,
5013 CLASS_DATA (fsym)->attr.class_pointer
5014 || CLASS_DATA (fsym)->attr.allocatable);
5016 else
5018 bool scalar;
5019 gfc_ss *argss;
5021 gfc_init_se (&parmse, NULL);
5023 /* Check whether the expression is a scalar or not; we cannot use
5024 e->rank as it can be nonzero for functions arguments. */
5025 argss = gfc_walk_expr (e);
5026 scalar = argss == gfc_ss_terminator;
5027 if (!scalar)
5028 gfc_free_ss_chain (argss);
5030 /* Special handling for passing scalar polymorphic coarrays;
5031 otherwise one passes "class->_data.data" instead of "&class". */
5032 if (e->rank == 0 && e->ts.type == BT_CLASS
5033 && fsym && fsym->ts.type == BT_CLASS
5034 && CLASS_DATA (fsym)->attr.codimension
5035 && !CLASS_DATA (fsym)->attr.dimension)
5037 gfc_add_class_array_ref (e);
5038 parmse.want_coarray = 1;
5039 scalar = false;
5042 /* A scalar or transformational function. */
5043 if (scalar)
5045 if (e->expr_type == EXPR_VARIABLE
5046 && e->symtree->n.sym->attr.cray_pointee
5047 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5049 /* The Cray pointer needs to be converted to a pointer to
5050 a type given by the expression. */
5051 gfc_conv_expr (&parmse, e);
5052 type = build_pointer_type (TREE_TYPE (parmse.expr));
5053 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5054 parmse.expr = convert (type, tmp);
5056 else if (fsym && fsym->attr.value)
5058 if (fsym->ts.type == BT_CHARACTER
5059 && fsym->ts.is_c_interop
5060 && fsym->ns->proc_name != NULL
5061 && fsym->ns->proc_name->attr.is_bind_c)
5063 parmse.expr = NULL;
5064 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5065 if (parmse.expr == NULL)
5066 gfc_conv_expr (&parmse, e);
5068 else
5070 gfc_conv_expr (&parmse, e);
5071 if (fsym->attr.optional
5072 && fsym->ts.type != BT_CLASS
5073 && fsym->ts.type != BT_DERIVED)
5075 if (e->expr_type != EXPR_VARIABLE
5076 || !e->symtree->n.sym->attr.optional
5077 || e->ref != NULL)
5078 vec_safe_push (optionalargs, boolean_true_node);
5079 else
5081 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5082 if (!e->symtree->n.sym->attr.value)
5083 parmse.expr
5084 = fold_build3_loc (input_location, COND_EXPR,
5085 TREE_TYPE (parmse.expr),
5086 tmp, parmse.expr,
5087 fold_convert (TREE_TYPE (parmse.expr),
5088 integer_zero_node));
5090 vec_safe_push (optionalargs, tmp);
5095 else if (arg->name && arg->name[0] == '%')
5096 /* Argument list functions %VAL, %LOC and %REF are signalled
5097 through arg->name. */
5098 conv_arglist_function (&parmse, arg->expr, arg->name);
5099 else if ((e->expr_type == EXPR_FUNCTION)
5100 && ((e->value.function.esym
5101 && e->value.function.esym->result->attr.pointer)
5102 || (!e->value.function.esym
5103 && e->symtree->n.sym->attr.pointer))
5104 && fsym && fsym->attr.target)
5106 gfc_conv_expr (&parmse, e);
5107 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5109 else if (e->expr_type == EXPR_FUNCTION
5110 && e->symtree->n.sym->result
5111 && e->symtree->n.sym->result != e->symtree->n.sym
5112 && e->symtree->n.sym->result->attr.proc_pointer)
5114 /* Functions returning procedure pointers. */
5115 gfc_conv_expr (&parmse, e);
5116 if (fsym && fsym->attr.proc_pointer)
5117 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5119 else
5121 if (e->ts.type == BT_CLASS && fsym
5122 && fsym->ts.type == BT_CLASS
5123 && (!CLASS_DATA (fsym)->as
5124 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5125 && CLASS_DATA (e)->attr.codimension)
5127 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5128 gcc_assert (!CLASS_DATA (fsym)->as);
5129 gfc_add_class_array_ref (e);
5130 parmse.want_coarray = 1;
5131 gfc_conv_expr_reference (&parmse, e);
5132 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5133 fsym->attr.optional
5134 && e->expr_type == EXPR_VARIABLE);
5136 else if (e->ts.type == BT_CLASS && fsym
5137 && fsym->ts.type == BT_CLASS
5138 && !CLASS_DATA (fsym)->as
5139 && !CLASS_DATA (e)->as
5140 && strcmp (fsym->ts.u.derived->name,
5141 e->ts.u.derived->name))
5143 type = gfc_typenode_for_spec (&fsym->ts);
5144 var = gfc_create_var (type, fsym->name);
5145 gfc_conv_expr (&parmse, e);
5146 if (fsym->attr.optional
5147 && e->expr_type == EXPR_VARIABLE
5148 && e->symtree->n.sym->attr.optional)
5150 stmtblock_t block;
5151 tree cond;
5152 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5153 cond = fold_build2_loc (input_location, NE_EXPR,
5154 boolean_type_node, tmp,
5155 fold_convert (TREE_TYPE (tmp),
5156 null_pointer_node));
5157 gfc_start_block (&block);
5158 gfc_add_modify (&block, var,
5159 fold_build1_loc (input_location,
5160 VIEW_CONVERT_EXPR,
5161 type, parmse.expr));
5162 gfc_add_expr_to_block (&parmse.pre,
5163 fold_build3_loc (input_location,
5164 COND_EXPR, void_type_node,
5165 cond, gfc_finish_block (&block),
5166 build_empty_stmt (input_location)));
5167 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5168 parmse.expr = build3_loc (input_location, COND_EXPR,
5169 TREE_TYPE (parmse.expr),
5170 cond, parmse.expr,
5171 fold_convert (TREE_TYPE (parmse.expr),
5172 null_pointer_node));
5174 else
5176 gfc_add_modify (&parmse.pre, var,
5177 fold_build1_loc (input_location,
5178 VIEW_CONVERT_EXPR,
5179 type, parmse.expr));
5180 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5183 else
5184 gfc_conv_expr_reference (&parmse, e);
5186 /* Catch base objects that are not variables. */
5187 if (e->ts.type == BT_CLASS
5188 && e->expr_type != EXPR_VARIABLE
5189 && expr && e == expr->base_expr)
5190 base_object = build_fold_indirect_ref_loc (input_location,
5191 parmse.expr);
5193 /* A class array element needs converting back to be a
5194 class object, if the formal argument is a class object. */
5195 if (fsym && fsym->ts.type == BT_CLASS
5196 && e->ts.type == BT_CLASS
5197 && ((CLASS_DATA (fsym)->as
5198 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5199 || CLASS_DATA (e)->attr.dimension))
5200 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5201 fsym->attr.intent != INTENT_IN
5202 && (CLASS_DATA (fsym)->attr.class_pointer
5203 || CLASS_DATA (fsym)->attr.allocatable),
5204 fsym->attr.optional
5205 && e->expr_type == EXPR_VARIABLE
5206 && e->symtree->n.sym->attr.optional,
5207 CLASS_DATA (fsym)->attr.class_pointer
5208 || CLASS_DATA (fsym)->attr.allocatable);
5210 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5211 allocated on entry, it must be deallocated. */
5212 if (fsym && fsym->attr.intent == INTENT_OUT
5213 && (fsym->attr.allocatable
5214 || (fsym->ts.type == BT_CLASS
5215 && CLASS_DATA (fsym)->attr.allocatable)))
5217 stmtblock_t block;
5218 tree ptr;
5220 gfc_init_block (&block);
5221 ptr = parmse.expr;
5222 if (e->ts.type == BT_CLASS)
5223 ptr = gfc_class_data_get (ptr);
5225 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5226 NULL_TREE, true,
5227 e, e->ts);
5228 gfc_add_expr_to_block (&block, tmp);
5229 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5230 void_type_node, ptr,
5231 null_pointer_node);
5232 gfc_add_expr_to_block (&block, tmp);
5234 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5236 gfc_add_modify (&block, ptr,
5237 fold_convert (TREE_TYPE (ptr),
5238 null_pointer_node));
5239 gfc_add_expr_to_block (&block, tmp);
5241 else if (fsym->ts.type == BT_CLASS)
5243 gfc_symbol *vtab;
5244 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5245 tmp = gfc_get_symbol_decl (vtab);
5246 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5247 ptr = gfc_class_vptr_get (parmse.expr);
5248 gfc_add_modify (&block, ptr,
5249 fold_convert (TREE_TYPE (ptr), tmp));
5250 gfc_add_expr_to_block (&block, tmp);
5253 if (fsym->attr.optional
5254 && e->expr_type == EXPR_VARIABLE
5255 && e->symtree->n.sym->attr.optional)
5257 tmp = fold_build3_loc (input_location, COND_EXPR,
5258 void_type_node,
5259 gfc_conv_expr_present (e->symtree->n.sym),
5260 gfc_finish_block (&block),
5261 build_empty_stmt (input_location));
5263 else
5264 tmp = gfc_finish_block (&block);
5266 gfc_add_expr_to_block (&se->pre, tmp);
5269 if (fsym && (fsym->ts.type == BT_DERIVED
5270 || fsym->ts.type == BT_ASSUMED)
5271 && e->ts.type == BT_CLASS
5272 && !CLASS_DATA (e)->attr.dimension
5273 && !CLASS_DATA (e)->attr.codimension)
5274 parmse.expr = gfc_class_data_get (parmse.expr);
5276 /* Wrap scalar variable in a descriptor. We need to convert
5277 the address of a pointer back to the pointer itself before,
5278 we can assign it to the data field. */
5280 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5281 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5283 tmp = parmse.expr;
5284 if (TREE_CODE (tmp) == ADDR_EXPR
5285 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
5286 tmp = TREE_OPERAND (tmp, 0);
5287 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5288 fsym->attr);
5289 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5290 parmse.expr);
5292 else if (fsym && e->expr_type != EXPR_NULL
5293 && ((fsym->attr.pointer
5294 && fsym->attr.flavor != FL_PROCEDURE)
5295 || (fsym->attr.proc_pointer
5296 && !(e->expr_type == EXPR_VARIABLE
5297 && e->symtree->n.sym->attr.dummy))
5298 || (fsym->attr.proc_pointer
5299 && e->expr_type == EXPR_VARIABLE
5300 && gfc_is_proc_ptr_comp (e))
5301 || (fsym->attr.allocatable
5302 && fsym->attr.flavor != FL_PROCEDURE)))
5304 /* Scalar pointer dummy args require an extra level of
5305 indirection. The null pointer already contains
5306 this level of indirection. */
5307 parm_kind = SCALAR_POINTER;
5308 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5312 else if (e->ts.type == BT_CLASS
5313 && fsym && fsym->ts.type == BT_CLASS
5314 && (CLASS_DATA (fsym)->attr.dimension
5315 || CLASS_DATA (fsym)->attr.codimension))
5317 /* Pass a class array. */
5318 parmse.use_offset = 1;
5319 gfc_conv_expr_descriptor (&parmse, e);
5321 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5322 allocated on entry, it must be deallocated. */
5323 if (fsym->attr.intent == INTENT_OUT
5324 && CLASS_DATA (fsym)->attr.allocatable)
5326 stmtblock_t block;
5327 tree ptr;
5329 gfc_init_block (&block);
5330 ptr = parmse.expr;
5331 ptr = gfc_class_data_get (ptr);
5333 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5334 NULL_TREE, NULL_TREE,
5335 NULL_TREE, true, e,
5336 GFC_CAF_COARRAY_NOCOARRAY);
5337 gfc_add_expr_to_block (&block, tmp);
5338 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5339 void_type_node, ptr,
5340 null_pointer_node);
5341 gfc_add_expr_to_block (&block, tmp);
5342 gfc_reset_vptr (&block, e);
5344 if (fsym->attr.optional
5345 && e->expr_type == EXPR_VARIABLE
5346 && (!e->ref
5347 || (e->ref->type == REF_ARRAY
5348 && e->ref->u.ar.type != AR_FULL))
5349 && e->symtree->n.sym->attr.optional)
5351 tmp = fold_build3_loc (input_location, COND_EXPR,
5352 void_type_node,
5353 gfc_conv_expr_present (e->symtree->n.sym),
5354 gfc_finish_block (&block),
5355 build_empty_stmt (input_location));
5357 else
5358 tmp = gfc_finish_block (&block);
5360 gfc_add_expr_to_block (&se->pre, tmp);
5363 /* The conversion does not repackage the reference to a class
5364 array - _data descriptor. */
5365 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5366 fsym->attr.intent != INTENT_IN
5367 && (CLASS_DATA (fsym)->attr.class_pointer
5368 || CLASS_DATA (fsym)->attr.allocatable),
5369 fsym->attr.optional
5370 && e->expr_type == EXPR_VARIABLE
5371 && e->symtree->n.sym->attr.optional,
5372 CLASS_DATA (fsym)->attr.class_pointer
5373 || CLASS_DATA (fsym)->attr.allocatable);
5375 else
5377 /* If the argument is a function call that may not create
5378 a temporary for the result, we have to check that we
5379 can do it, i.e. that there is no alias between this
5380 argument and another one. */
5381 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5383 gfc_expr *iarg;
5384 sym_intent intent;
5386 if (fsym != NULL)
5387 intent = fsym->attr.intent;
5388 else
5389 intent = INTENT_UNKNOWN;
5391 if (gfc_check_fncall_dependency (e, intent, sym, args,
5392 NOT_ELEMENTAL))
5393 parmse.force_tmp = 1;
5395 iarg = e->value.function.actual->expr;
5397 /* Temporary needed if aliasing due to host association. */
5398 if (sym->attr.contained
5399 && !sym->attr.pure
5400 && !sym->attr.implicit_pure
5401 && !sym->attr.use_assoc
5402 && iarg->expr_type == EXPR_VARIABLE
5403 && sym->ns == iarg->symtree->n.sym->ns)
5404 parmse.force_tmp = 1;
5406 /* Ditto within module. */
5407 if (sym->attr.use_assoc
5408 && !sym->attr.pure
5409 && !sym->attr.implicit_pure
5410 && iarg->expr_type == EXPR_VARIABLE
5411 && sym->module == iarg->symtree->n.sym->module)
5412 parmse.force_tmp = 1;
5415 if (e->expr_type == EXPR_VARIABLE
5416 && is_subref_array (e))
5417 /* The actual argument is a component reference to an
5418 array of derived types. In this case, the argument
5419 is converted to a temporary, which is passed and then
5420 written back after the procedure call. */
5421 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5422 fsym ? fsym->attr.intent : INTENT_INOUT,
5423 fsym && fsym->attr.pointer);
5424 else if (gfc_is_class_array_ref (e, NULL)
5425 && fsym && fsym->ts.type == BT_DERIVED)
5426 /* The actual argument is a component reference to an
5427 array of derived types. In this case, the argument
5428 is converted to a temporary, which is passed and then
5429 written back after the procedure call.
5430 OOP-TODO: Insert code so that if the dynamic type is
5431 the same as the declared type, copy-in/copy-out does
5432 not occur. */
5433 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5434 fsym ? fsym->attr.intent : INTENT_INOUT,
5435 fsym && fsym->attr.pointer);
5437 else if (gfc_is_alloc_class_array_function (e)
5438 && fsym && fsym->ts.type == BT_DERIVED)
5439 /* See previous comment. For function actual argument,
5440 the write out is not needed so the intent is set as
5441 intent in. */
5443 e->must_finalize = 1;
5444 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5445 INTENT_IN,
5446 fsym && fsym->attr.pointer);
5448 else
5449 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5450 sym->name, NULL);
5452 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5453 allocated on entry, it must be deallocated. */
5454 if (fsym && fsym->attr.allocatable
5455 && fsym->attr.intent == INTENT_OUT)
5457 if (fsym->ts.type == BT_DERIVED
5458 && fsym->ts.u.derived->attr.alloc_comp)
5460 // deallocate the components first
5461 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5462 parmse.expr, e->rank);
5463 if (tmp != NULL_TREE)
5464 gfc_add_expr_to_block (&se->pre, tmp);
5467 tmp = build_fold_indirect_ref_loc (input_location,
5468 parmse.expr);
5469 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5470 tmp = gfc_conv_descriptor_data_get (tmp);
5471 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5472 NULL_TREE, NULL_TREE, true,
5474 GFC_CAF_COARRAY_NOCOARRAY);
5475 if (fsym->attr.optional
5476 && e->expr_type == EXPR_VARIABLE
5477 && e->symtree->n.sym->attr.optional)
5478 tmp = fold_build3_loc (input_location, COND_EXPR,
5479 void_type_node,
5480 gfc_conv_expr_present (e->symtree->n.sym),
5481 tmp, build_empty_stmt (input_location));
5482 gfc_add_expr_to_block (&se->pre, tmp);
5487 /* The case with fsym->attr.optional is that of a user subroutine
5488 with an interface indicating an optional argument. When we call
5489 an intrinsic subroutine, however, fsym is NULL, but we might still
5490 have an optional argument, so we proceed to the substitution
5491 just in case. */
5492 if (e && (fsym == NULL || fsym->attr.optional))
5494 /* If an optional argument is itself an optional dummy argument,
5495 check its presence and substitute a null if absent. This is
5496 only needed when passing an array to an elemental procedure
5497 as then array elements are accessed - or no NULL pointer is
5498 allowed and a "1" or "0" should be passed if not present.
5499 When passing a non-array-descriptor full array to a
5500 non-array-descriptor dummy, no check is needed. For
5501 array-descriptor actual to array-descriptor dummy, see
5502 PR 41911 for why a check has to be inserted.
5503 fsym == NULL is checked as intrinsics required the descriptor
5504 but do not always set fsym. */
5505 if (e->expr_type == EXPR_VARIABLE
5506 && e->symtree->n.sym->attr.optional
5507 && ((e->rank != 0 && elemental_proc)
5508 || e->representation.length || e->ts.type == BT_CHARACTER
5509 || (e->rank != 0
5510 && (fsym == NULL
5511 || (fsym-> as
5512 && (fsym->as->type == AS_ASSUMED_SHAPE
5513 || fsym->as->type == AS_ASSUMED_RANK
5514 || fsym->as->type == AS_DEFERRED))))))
5515 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5516 e->representation.length);
5519 if (fsym && e)
5521 /* Obtain the character length of an assumed character length
5522 length procedure from the typespec. */
5523 if (fsym->ts.type == BT_CHARACTER
5524 && parmse.string_length == NULL_TREE
5525 && e->ts.type == BT_PROCEDURE
5526 && e->symtree->n.sym->ts.type == BT_CHARACTER
5527 && e->symtree->n.sym->ts.u.cl->length != NULL
5528 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5530 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5531 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5535 if (fsym && need_interface_mapping && e)
5536 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5538 gfc_add_block_to_block (&se->pre, &parmse.pre);
5539 gfc_add_block_to_block (&post, &parmse.post);
5541 /* Allocated allocatable components of derived types must be
5542 deallocated for non-variable scalars, array arguments to elemental
5543 procedures, and array arguments with descriptor to non-elemental
5544 procedures. As bounds information for descriptorless arrays is no
5545 longer available here, they are dealt with in trans-array.c
5546 (gfc_conv_array_parameter). */
5547 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5548 && e->ts.u.derived->attr.alloc_comp
5549 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5550 && !expr_may_alias_variables (e, elemental_proc))
5552 int parm_rank;
5553 /* It is known the e returns a structure type with at least one
5554 allocatable component. When e is a function, ensure that the
5555 function is called once only by using a temporary variable. */
5556 if (!DECL_P (parmse.expr))
5557 parmse.expr = gfc_evaluate_now_loc (input_location,
5558 parmse.expr, &se->pre);
5560 if (fsym && fsym->attr.value)
5561 tmp = parmse.expr;
5562 else
5563 tmp = build_fold_indirect_ref_loc (input_location,
5564 parmse.expr);
5566 parm_rank = e->rank;
5567 switch (parm_kind)
5569 case (ELEMENTAL):
5570 case (SCALAR):
5571 parm_rank = 0;
5572 break;
5574 case (SCALAR_POINTER):
5575 tmp = build_fold_indirect_ref_loc (input_location,
5576 tmp);
5577 break;
5580 if (e->expr_type == EXPR_OP
5581 && e->value.op.op == INTRINSIC_PARENTHESES
5582 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5584 tree local_tmp;
5585 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5586 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5587 parm_rank, 0);
5588 gfc_add_expr_to_block (&se->post, local_tmp);
5591 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5593 /* The derived type is passed to gfc_deallocate_alloc_comp.
5594 Therefore, class actuals can handled correctly but derived
5595 types passed to class formals need the _data component. */
5596 tmp = gfc_class_data_get (tmp);
5597 if (!CLASS_DATA (fsym)->attr.dimension)
5598 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5601 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
5603 gfc_prepend_expr_to_block (&post, tmp);
5606 /* Add argument checking of passing an unallocated/NULL actual to
5607 a nonallocatable/nonpointer dummy. */
5609 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5611 symbol_attribute attr;
5612 char *msg;
5613 tree cond;
5615 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5616 attr = gfc_expr_attr (e);
5617 else
5618 goto end_pointer_check;
5620 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5621 allocatable to an optional dummy, cf. 12.5.2.12. */
5622 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5623 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5624 goto end_pointer_check;
5626 if (attr.optional)
5628 /* If the actual argument is an optional pointer/allocatable and
5629 the formal argument takes an nonpointer optional value,
5630 it is invalid to pass a non-present argument on, even
5631 though there is no technical reason for this in gfortran.
5632 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5633 tree present, null_ptr, type;
5635 if (attr.allocatable
5636 && (fsym == NULL || !fsym->attr.allocatable))
5637 msg = xasprintf ("Allocatable actual argument '%s' is not "
5638 "allocated or not present",
5639 e->symtree->n.sym->name);
5640 else if (attr.pointer
5641 && (fsym == NULL || !fsym->attr.pointer))
5642 msg = xasprintf ("Pointer actual argument '%s' is not "
5643 "associated or not present",
5644 e->symtree->n.sym->name);
5645 else if (attr.proc_pointer
5646 && (fsym == NULL || !fsym->attr.proc_pointer))
5647 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5648 "associated or not present",
5649 e->symtree->n.sym->name);
5650 else
5651 goto end_pointer_check;
5653 present = gfc_conv_expr_present (e->symtree->n.sym);
5654 type = TREE_TYPE (present);
5655 present = fold_build2_loc (input_location, EQ_EXPR,
5656 boolean_type_node, present,
5657 fold_convert (type,
5658 null_pointer_node));
5659 type = TREE_TYPE (parmse.expr);
5660 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5661 boolean_type_node, parmse.expr,
5662 fold_convert (type,
5663 null_pointer_node));
5664 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5665 boolean_type_node, present, null_ptr);
5667 else
5669 if (attr.allocatable
5670 && (fsym == NULL || !fsym->attr.allocatable))
5671 msg = xasprintf ("Allocatable actual argument '%s' is not "
5672 "allocated", e->symtree->n.sym->name);
5673 else if (attr.pointer
5674 && (fsym == NULL || !fsym->attr.pointer))
5675 msg = xasprintf ("Pointer actual argument '%s' is not "
5676 "associated", e->symtree->n.sym->name);
5677 else if (attr.proc_pointer
5678 && (fsym == NULL || !fsym->attr.proc_pointer))
5679 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5680 "associated", e->symtree->n.sym->name);
5681 else
5682 goto end_pointer_check;
5684 tmp = parmse.expr;
5686 /* If the argument is passed by value, we need to strip the
5687 INDIRECT_REF. */
5688 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5689 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5691 cond = fold_build2_loc (input_location, EQ_EXPR,
5692 boolean_type_node, tmp,
5693 fold_convert (TREE_TYPE (tmp),
5694 null_pointer_node));
5697 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5698 msg);
5699 free (msg);
5701 end_pointer_check:
5703 /* Deferred length dummies pass the character length by reference
5704 so that the value can be returned. */
5705 if (parmse.string_length && fsym && fsym->ts.deferred)
5707 if (INDIRECT_REF_P (parmse.string_length))
5708 /* In chains of functions/procedure calls the string_length already
5709 is a pointer to the variable holding the length. Therefore
5710 remove the deref on call. */
5711 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5712 else
5714 tmp = parmse.string_length;
5715 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5716 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5717 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5721 /* Character strings are passed as two parameters, a length and a
5722 pointer - except for Bind(c) which only passes the pointer.
5723 An unlimited polymorphic formal argument likewise does not
5724 need the length. */
5725 if (parmse.string_length != NULL_TREE
5726 && !sym->attr.is_bind_c
5727 && !(fsym && UNLIMITED_POLY (fsym)))
5728 vec_safe_push (stringargs, parmse.string_length);
5730 /* When calling __copy for character expressions to unlimited
5731 polymorphic entities, the dst argument needs a string length. */
5732 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
5733 && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
5734 && arg->next && arg->next->expr
5735 && (arg->next->expr->ts.type == BT_DERIVED
5736 || arg->next->expr->ts.type == BT_CLASS)
5737 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
5738 vec_safe_push (stringargs, parmse.string_length);
5740 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5741 pass the token and the offset as additional arguments. */
5742 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
5743 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5744 && !fsym->attr.allocatable)
5745 || (fsym->ts.type == BT_CLASS
5746 && CLASS_DATA (fsym)->attr.codimension
5747 && !CLASS_DATA (fsym)->attr.allocatable)))
5749 /* Token and offset. */
5750 vec_safe_push (stringargs, null_pointer_node);
5751 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
5752 gcc_assert (fsym->attr.optional);
5754 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
5755 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5756 && !fsym->attr.allocatable)
5757 || (fsym->ts.type == BT_CLASS
5758 && CLASS_DATA (fsym)->attr.codimension
5759 && !CLASS_DATA (fsym)->attr.allocatable)))
5761 tree caf_decl, caf_type;
5762 tree offset, tmp2;
5764 caf_decl = gfc_get_tree_for_caf_expr (e);
5765 caf_type = TREE_TYPE (caf_decl);
5767 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5768 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
5769 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
5770 tmp = gfc_conv_descriptor_token (caf_decl);
5771 else if (DECL_LANG_SPECIFIC (caf_decl)
5772 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
5773 tmp = GFC_DECL_TOKEN (caf_decl);
5774 else
5776 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
5777 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
5778 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
5781 vec_safe_push (stringargs, tmp);
5783 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5784 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
5785 offset = build_int_cst (gfc_array_index_type, 0);
5786 else if (DECL_LANG_SPECIFIC (caf_decl)
5787 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
5788 offset = GFC_DECL_CAF_OFFSET (caf_decl);
5789 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
5790 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
5791 else
5792 offset = build_int_cst (gfc_array_index_type, 0);
5794 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
5795 tmp = gfc_conv_descriptor_data_get (caf_decl);
5796 else
5798 gcc_assert (POINTER_TYPE_P (caf_type));
5799 tmp = caf_decl;
5802 tmp2 = fsym->ts.type == BT_CLASS
5803 ? gfc_class_data_get (parmse.expr) : parmse.expr;
5804 if ((fsym->ts.type != BT_CLASS
5805 && (fsym->as->type == AS_ASSUMED_SHAPE
5806 || fsym->as->type == AS_ASSUMED_RANK))
5807 || (fsym->ts.type == BT_CLASS
5808 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
5809 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
5811 if (fsym->ts.type == BT_CLASS)
5812 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
5813 else
5815 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5816 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
5818 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
5819 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5821 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
5822 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5823 else
5825 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5828 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5829 gfc_array_index_type,
5830 fold_convert (gfc_array_index_type, tmp2),
5831 fold_convert (gfc_array_index_type, tmp));
5832 offset = fold_build2_loc (input_location, PLUS_EXPR,
5833 gfc_array_index_type, offset, tmp);
5835 vec_safe_push (stringargs, offset);
5838 vec_safe_push (arglist, parmse.expr);
5840 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
5842 if (comp)
5843 ts = comp->ts;
5844 else if (sym->ts.type == BT_CLASS)
5845 ts = CLASS_DATA (sym)->ts;
5846 else
5847 ts = sym->ts;
5849 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
5850 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
5851 else if (ts.type == BT_CHARACTER)
5853 if (ts.u.cl->length == NULL)
5855 /* Assumed character length results are not allowed by 5.1.1.5 of the
5856 standard and are trapped in resolve.c; except in the case of SPREAD
5857 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5858 we take the character length of the first argument for the result.
5859 For dummies, we have to look through the formal argument list for
5860 this function and use the character length found there.*/
5861 if (ts.deferred)
5862 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
5863 else if (!sym->attr.dummy)
5864 cl.backend_decl = (*stringargs)[0];
5865 else
5867 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
5868 for (; formal; formal = formal->next)
5869 if (strcmp (formal->sym->name, sym->name) == 0)
5870 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
5872 len = cl.backend_decl;
5874 else
5876 tree tmp;
5878 /* Calculate the length of the returned string. */
5879 gfc_init_se (&parmse, NULL);
5880 if (need_interface_mapping)
5881 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
5882 else
5883 gfc_conv_expr (&parmse, ts.u.cl->length);
5884 gfc_add_block_to_block (&se->pre, &parmse.pre);
5885 gfc_add_block_to_block (&se->post, &parmse.post);
5887 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
5888 tmp = fold_build2_loc (input_location, MAX_EXPR,
5889 gfc_charlen_type_node, tmp,
5890 build_int_cst (gfc_charlen_type_node, 0));
5891 cl.backend_decl = tmp;
5894 /* Set up a charlen structure for it. */
5895 cl.next = NULL;
5896 cl.length = NULL;
5897 ts.u.cl = &cl;
5899 len = cl.backend_decl;
5902 byref = (comp && (comp->attr.dimension
5903 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
5904 || (!comp && gfc_return_by_reference (sym));
5905 if (byref)
5907 if (se->direct_byref)
5909 /* Sometimes, too much indirection can be applied; e.g. for
5910 function_result = array_valued_recursive_function. */
5911 if (TREE_TYPE (TREE_TYPE (se->expr))
5912 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
5913 && GFC_DESCRIPTOR_TYPE_P
5914 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
5915 se->expr = build_fold_indirect_ref_loc (input_location,
5916 se->expr);
5918 /* If the lhs of an assignment x = f(..) is allocatable and
5919 f2003 is allowed, we must do the automatic reallocation.
5920 TODO - deal with intrinsics, without using a temporary. */
5921 if (flag_realloc_lhs
5922 && se->ss && se->ss->loop_chain
5923 && se->ss->loop_chain->is_alloc_lhs
5924 && !expr->value.function.isym
5925 && sym->result->as != NULL)
5927 /* Evaluate the bounds of the result, if known. */
5928 gfc_set_loop_bounds_from_array_spec (&mapping, se,
5929 sym->result->as);
5931 /* Perform the automatic reallocation. */
5932 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
5933 expr, NULL);
5934 gfc_add_expr_to_block (&se->pre, tmp);
5936 /* Pass the temporary as the first argument. */
5937 result = info->descriptor;
5939 else
5940 result = build_fold_indirect_ref_loc (input_location,
5941 se->expr);
5942 vec_safe_push (retargs, se->expr);
5944 else if (comp && comp->attr.dimension)
5946 gcc_assert (se->loop && info);
5948 /* Set the type of the array. */
5949 tmp = gfc_typenode_for_spec (&comp->ts);
5950 gcc_assert (se->ss->dimen == se->loop->dimen);
5952 /* Evaluate the bounds of the result, if known. */
5953 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
5955 /* If the lhs of an assignment x = f(..) is allocatable and
5956 f2003 is allowed, we must not generate the function call
5957 here but should just send back the results of the mapping.
5958 This is signalled by the function ss being flagged. */
5959 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
5961 gfc_free_interface_mapping (&mapping);
5962 return has_alternate_specifier;
5965 /* Create a temporary to store the result. In case the function
5966 returns a pointer, the temporary will be a shallow copy and
5967 mustn't be deallocated. */
5968 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
5969 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
5970 tmp, NULL_TREE, false,
5971 !comp->attr.pointer, callee_alloc,
5972 &se->ss->info->expr->where);
5974 /* Pass the temporary as the first argument. */
5975 result = info->descriptor;
5976 tmp = gfc_build_addr_expr (NULL_TREE, result);
5977 vec_safe_push (retargs, tmp);
5979 else if (!comp && sym->result->attr.dimension)
5981 gcc_assert (se->loop && info);
5983 /* Set the type of the array. */
5984 tmp = gfc_typenode_for_spec (&ts);
5985 gcc_assert (se->ss->dimen == se->loop->dimen);
5987 /* Evaluate the bounds of the result, if known. */
5988 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
5990 /* If the lhs of an assignment x = f(..) is allocatable and
5991 f2003 is allowed, we must not generate the function call
5992 here but should just send back the results of the mapping.
5993 This is signalled by the function ss being flagged. */
5994 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
5996 gfc_free_interface_mapping (&mapping);
5997 return has_alternate_specifier;
6000 /* Create a temporary to store the result. In case the function
6001 returns a pointer, the temporary will be a shallow copy and
6002 mustn't be deallocated. */
6003 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6004 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6005 tmp, NULL_TREE, false,
6006 !sym->attr.pointer, callee_alloc,
6007 &se->ss->info->expr->where);
6009 /* Pass the temporary as the first argument. */
6010 result = info->descriptor;
6011 tmp = gfc_build_addr_expr (NULL_TREE, result);
6012 vec_safe_push (retargs, tmp);
6014 else if (ts.type == BT_CHARACTER)
6016 /* Pass the string length. */
6017 type = gfc_get_character_type (ts.kind, ts.u.cl);
6018 type = build_pointer_type (type);
6020 /* Emit a DECL_EXPR for the VLA type. */
6021 tmp = TREE_TYPE (type);
6022 if (TYPE_SIZE (tmp)
6023 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6025 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6026 DECL_ARTIFICIAL (tmp) = 1;
6027 DECL_IGNORED_P (tmp) = 1;
6028 tmp = fold_build1_loc (input_location, DECL_EXPR,
6029 TREE_TYPE (tmp), tmp);
6030 gfc_add_expr_to_block (&se->pre, tmp);
6033 /* Return an address to a char[0:len-1]* temporary for
6034 character pointers. */
6035 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6036 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6038 var = gfc_create_var (type, "pstr");
6040 if ((!comp && sym->attr.allocatable)
6041 || (comp && comp->attr.allocatable))
6043 gfc_add_modify (&se->pre, var,
6044 fold_convert (TREE_TYPE (var),
6045 null_pointer_node));
6046 tmp = gfc_call_free (var);
6047 gfc_add_expr_to_block (&se->post, tmp);
6050 /* Provide an address expression for the function arguments. */
6051 var = gfc_build_addr_expr (NULL_TREE, var);
6053 else
6054 var = gfc_conv_string_tmp (se, type, len);
6056 vec_safe_push (retargs, var);
6058 else
6060 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6062 type = gfc_get_complex_type (ts.kind);
6063 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6064 vec_safe_push (retargs, var);
6067 /* Add the string length to the argument list. */
6068 if (ts.type == BT_CHARACTER && ts.deferred)
6070 tmp = len;
6071 if (!VAR_P (tmp))
6072 tmp = gfc_evaluate_now (len, &se->pre);
6073 TREE_STATIC (tmp) = 1;
6074 gfc_add_modify (&se->pre, tmp,
6075 build_int_cst (TREE_TYPE (tmp), 0));
6076 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6077 vec_safe_push (retargs, tmp);
6079 else if (ts.type == BT_CHARACTER)
6080 vec_safe_push (retargs, len);
6082 gfc_free_interface_mapping (&mapping);
6084 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6085 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6086 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6087 vec_safe_reserve (retargs, arglen);
6089 /* Add the return arguments. */
6090 vec_safe_splice (retargs, arglist);
6092 /* Add the hidden present status for optional+value to the arguments. */
6093 vec_safe_splice (retargs, optionalargs);
6095 /* Add the hidden string length parameters to the arguments. */
6096 vec_safe_splice (retargs, stringargs);
6098 /* We may want to append extra arguments here. This is used e.g. for
6099 calls to libgfortran_matmul_??, which need extra information. */
6100 vec_safe_splice (retargs, append_args);
6102 arglist = retargs;
6104 /* Generate the actual call. */
6105 if (base_object == NULL_TREE)
6106 conv_function_val (se, sym, expr);
6107 else
6108 conv_base_obj_fcn_val (se, base_object, expr);
6110 /* If there are alternate return labels, function type should be
6111 integer. Can't modify the type in place though, since it can be shared
6112 with other functions. For dummy arguments, the typing is done to
6113 this result, even if it has to be repeated for each call. */
6114 if (has_alternate_specifier
6115 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6117 if (!sym->attr.dummy)
6119 TREE_TYPE (sym->backend_decl)
6120 = build_function_type (integer_type_node,
6121 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6122 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6124 else
6125 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6128 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6129 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6131 /* Allocatable scalar function results must be freed and nullified
6132 after use. This necessitates the creation of a temporary to
6133 hold the result to prevent duplicate calls. */
6134 if (!byref && sym->ts.type != BT_CHARACTER
6135 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6136 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6138 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6139 gfc_add_modify (&se->pre, tmp, se->expr);
6140 se->expr = tmp;
6141 tmp = gfc_call_free (tmp);
6142 gfc_add_expr_to_block (&post, tmp);
6143 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6146 /* If we have a pointer function, but we don't want a pointer, e.g.
6147 something like
6148 x = f()
6149 where f is pointer valued, we have to dereference the result. */
6150 if (!se->want_pointer && !byref
6151 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6152 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6153 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6155 /* f2c calling conventions require a scalar default real function to
6156 return a double precision result. Convert this back to default
6157 real. We only care about the cases that can happen in Fortran 77.
6159 if (flag_f2c && sym->ts.type == BT_REAL
6160 && sym->ts.kind == gfc_default_real_kind
6161 && !sym->attr.always_explicit)
6162 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6164 /* A pure function may still have side-effects - it may modify its
6165 parameters. */
6166 TREE_SIDE_EFFECTS (se->expr) = 1;
6167 #if 0
6168 if (!sym->attr.pure)
6169 TREE_SIDE_EFFECTS (se->expr) = 1;
6170 #endif
6172 if (byref)
6174 /* Add the function call to the pre chain. There is no expression. */
6175 gfc_add_expr_to_block (&se->pre, se->expr);
6176 se->expr = NULL_TREE;
6178 if (!se->direct_byref)
6180 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6182 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6184 /* Check the data pointer hasn't been modified. This would
6185 happen in a function returning a pointer. */
6186 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6187 tmp = fold_build2_loc (input_location, NE_EXPR,
6188 boolean_type_node,
6189 tmp, info->data);
6190 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6191 gfc_msg_fault);
6193 se->expr = info->descriptor;
6194 /* Bundle in the string length. */
6195 se->string_length = len;
6197 else if (ts.type == BT_CHARACTER)
6199 /* Dereference for character pointer results. */
6200 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6201 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6202 se->expr = build_fold_indirect_ref_loc (input_location, var);
6203 else
6204 se->expr = var;
6206 se->string_length = len;
6208 else
6210 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6211 se->expr = build_fold_indirect_ref_loc (input_location, var);
6216 /* Associate the rhs class object's meta-data with the result, when the
6217 result is a temporary. */
6218 if (args && args->expr && args->expr->ts.type == BT_CLASS
6219 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6220 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6222 gfc_se parmse;
6223 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6225 gfc_init_se (&parmse, NULL);
6226 parmse.data_not_needed = 1;
6227 gfc_conv_expr (&parmse, class_expr);
6228 if (!DECL_LANG_SPECIFIC (result))
6229 gfc_allocate_lang_decl (result);
6230 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6231 gfc_free_expr (class_expr);
6232 gcc_assert (parmse.pre.head == NULL_TREE
6233 && parmse.post.head == NULL_TREE);
6236 /* Follow the function call with the argument post block. */
6237 if (byref)
6239 gfc_add_block_to_block (&se->pre, &post);
6241 /* Transformational functions of derived types with allocatable
6242 components must have the result allocatable components copied when the
6243 argument is actually given. */
6244 arg = expr->value.function.actual;
6245 if (result && arg && expr->rank
6246 && expr->value.function.isym
6247 && expr->value.function.isym->transformational
6248 && arg->expr
6249 && arg->expr->ts.type == BT_DERIVED
6250 && arg->expr->ts.u.derived->attr.alloc_comp)
6252 tree tmp2;
6253 /* Copy the allocatable components. We have to use a
6254 temporary here to prevent source allocatable components
6255 from being corrupted. */
6256 tmp2 = gfc_evaluate_now (result, &se->pre);
6257 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6258 result, tmp2, expr->rank, 0);
6259 gfc_add_expr_to_block (&se->pre, tmp);
6260 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6261 expr->rank);
6262 gfc_add_expr_to_block (&se->pre, tmp);
6264 /* Finally free the temporary's data field. */
6265 tmp = gfc_conv_descriptor_data_get (tmp2);
6266 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6267 NULL_TREE, NULL_TREE, true,
6268 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6269 gfc_add_expr_to_block (&se->pre, tmp);
6272 else
6274 /* For a function with a class array result, save the result as
6275 a temporary, set the info fields needed by the scalarizer and
6276 call the finalization function of the temporary. Note that the
6277 nullification of allocatable components needed by the result
6278 is done in gfc_trans_assignment_1. */
6279 if (expr && ((gfc_is_alloc_class_array_function (expr)
6280 && se->ss && se->ss->loop)
6281 || gfc_is_alloc_class_scalar_function (expr))
6282 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6283 && expr->must_finalize)
6285 tree final_fndecl;
6286 tree is_final;
6287 int n;
6288 if (se->ss && se->ss->loop)
6290 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6291 tmp = gfc_class_data_get (se->expr);
6292 info->descriptor = tmp;
6293 info->data = gfc_conv_descriptor_data_get (tmp);
6294 info->offset = gfc_conv_descriptor_offset_get (tmp);
6295 for (n = 0; n < se->ss->loop->dimen; n++)
6297 tree dim = gfc_rank_cst[n];
6298 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6299 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6302 else
6304 /* TODO Eliminate the doubling of temporaries. This
6305 one is necessary to ensure no memory leakage. */
6306 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6307 tmp = gfc_class_data_get (se->expr);
6308 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6309 CLASS_DATA (expr->value.function.esym->result)->attr);
6312 final_fndecl = gfc_class_vtab_final_get (se->expr);
6313 is_final = fold_build2_loc (input_location, NE_EXPR,
6314 boolean_type_node,
6315 final_fndecl,
6316 fold_convert (TREE_TYPE (final_fndecl),
6317 null_pointer_node));
6318 final_fndecl = build_fold_indirect_ref_loc (input_location,
6319 final_fndecl);
6320 tmp = build_call_expr_loc (input_location,
6321 final_fndecl, 3,
6322 gfc_build_addr_expr (NULL, tmp),
6323 gfc_class_vtab_size_get (se->expr),
6324 boolean_false_node);
6325 tmp = fold_build3_loc (input_location, COND_EXPR,
6326 void_type_node, is_final, tmp,
6327 build_empty_stmt (input_location));
6329 if (se->ss && se->ss->loop)
6331 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6332 tmp = gfc_call_free (info->data);
6333 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6335 else
6337 gfc_add_expr_to_block (&se->post, tmp);
6338 tmp = gfc_class_data_get (se->expr);
6339 tmp = gfc_call_free (tmp);
6340 gfc_add_expr_to_block (&se->post, tmp);
6342 expr->must_finalize = 0;
6345 gfc_add_block_to_block (&se->post, &post);
6348 return has_alternate_specifier;
6352 /* Fill a character string with spaces. */
6354 static tree
6355 fill_with_spaces (tree start, tree type, tree size)
6357 stmtblock_t block, loop;
6358 tree i, el, exit_label, cond, tmp;
6360 /* For a simple char type, we can call memset(). */
6361 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6362 return build_call_expr_loc (input_location,
6363 builtin_decl_explicit (BUILT_IN_MEMSET),
6364 3, start,
6365 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6366 lang_hooks.to_target_charset (' ')),
6367 size);
6369 /* Otherwise, we use a loop:
6370 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6371 *el = (type) ' ';
6374 /* Initialize variables. */
6375 gfc_init_block (&block);
6376 i = gfc_create_var (sizetype, "i");
6377 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6378 el = gfc_create_var (build_pointer_type (type), "el");
6379 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6380 exit_label = gfc_build_label_decl (NULL_TREE);
6381 TREE_USED (exit_label) = 1;
6384 /* Loop body. */
6385 gfc_init_block (&loop);
6387 /* Exit condition. */
6388 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
6389 build_zero_cst (sizetype));
6390 tmp = build1_v (GOTO_EXPR, exit_label);
6391 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6392 build_empty_stmt (input_location));
6393 gfc_add_expr_to_block (&loop, tmp);
6395 /* Assignment. */
6396 gfc_add_modify (&loop,
6397 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6398 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6400 /* Increment loop variables. */
6401 gfc_add_modify (&loop, i,
6402 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6403 TYPE_SIZE_UNIT (type)));
6404 gfc_add_modify (&loop, el,
6405 fold_build_pointer_plus_loc (input_location,
6406 el, TYPE_SIZE_UNIT (type)));
6408 /* Making the loop... actually loop! */
6409 tmp = gfc_finish_block (&loop);
6410 tmp = build1_v (LOOP_EXPR, tmp);
6411 gfc_add_expr_to_block (&block, tmp);
6413 /* The exit label. */
6414 tmp = build1_v (LABEL_EXPR, exit_label);
6415 gfc_add_expr_to_block (&block, tmp);
6418 return gfc_finish_block (&block);
6422 /* Generate code to copy a string. */
6424 void
6425 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6426 int dkind, tree slength, tree src, int skind)
6428 tree tmp, dlen, slen;
6429 tree dsc;
6430 tree ssc;
6431 tree cond;
6432 tree cond2;
6433 tree tmp2;
6434 tree tmp3;
6435 tree tmp4;
6436 tree chartype;
6437 stmtblock_t tempblock;
6439 gcc_assert (dkind == skind);
6441 if (slength != NULL_TREE)
6443 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
6444 ssc = gfc_string_to_single_character (slen, src, skind);
6446 else
6448 slen = build_int_cst (size_type_node, 1);
6449 ssc = src;
6452 if (dlength != NULL_TREE)
6454 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
6455 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6457 else
6459 dlen = build_int_cst (size_type_node, 1);
6460 dsc = dest;
6463 /* Assign directly if the types are compatible. */
6464 if (dsc != NULL_TREE && ssc != NULL_TREE
6465 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6467 gfc_add_modify (block, dsc, ssc);
6468 return;
6471 /* The string copy algorithm below generates code like
6473 if (dlen > 0) {
6474 memmove (dest, src, min(dlen, slen));
6475 if (slen < dlen)
6476 memset(&dest[slen], ' ', dlen - slen);
6480 /* Do nothing if the destination length is zero. */
6481 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
6482 build_int_cst (size_type_node, 0));
6484 /* For non-default character kinds, we have to multiply the string
6485 length by the base type size. */
6486 chartype = gfc_get_char_type (dkind);
6487 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6488 fold_convert (size_type_node, slen),
6489 fold_convert (size_type_node,
6490 TYPE_SIZE_UNIT (chartype)));
6491 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6492 fold_convert (size_type_node, dlen),
6493 fold_convert (size_type_node,
6494 TYPE_SIZE_UNIT (chartype)));
6496 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6497 dest = fold_convert (pvoid_type_node, dest);
6498 else
6499 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6501 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6502 src = fold_convert (pvoid_type_node, src);
6503 else
6504 src = gfc_build_addr_expr (pvoid_type_node, src);
6506 /* First do the memmove. */
6507 tmp2 = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (dlen), dlen,
6508 slen);
6509 tmp2 = build_call_expr_loc (input_location,
6510 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6511 3, dest, src, tmp2);
6512 stmtblock_t tmpblock2;
6513 gfc_init_block (&tmpblock2);
6514 gfc_add_expr_to_block (&tmpblock2, tmp2);
6516 /* If the destination is longer, fill the end with spaces. */
6517 cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen,
6518 dlen);
6520 /* Wstringop-overflow appears at -O3 even though this warning is not
6521 explicitly available in fortran nor can it be switched off. If the
6522 source length is a constant, its negative appears as a very large
6523 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6524 the result of the MINUS_EXPR suppresses this spurious warning. */
6525 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6526 TREE_TYPE(dlen), dlen, slen);
6527 if (slength && TREE_CONSTANT (slength))
6528 tmp = gfc_evaluate_now (tmp, block);
6530 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6531 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6533 gfc_init_block (&tempblock);
6534 gfc_add_expr_to_block (&tempblock, tmp4);
6535 tmp3 = gfc_finish_block (&tempblock);
6537 /* The whole copy_string function is there. */
6538 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6539 tmp3, build_empty_stmt (input_location));
6540 gfc_add_expr_to_block (&tmpblock2, tmp);
6541 tmp = gfc_finish_block (&tmpblock2);
6542 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6543 build_empty_stmt (input_location));
6544 gfc_add_expr_to_block (block, tmp);
6548 /* Translate a statement function.
6549 The value of a statement function reference is obtained by evaluating the
6550 expression using the values of the actual arguments for the values of the
6551 corresponding dummy arguments. */
6553 static void
6554 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6556 gfc_symbol *sym;
6557 gfc_symbol *fsym;
6558 gfc_formal_arglist *fargs;
6559 gfc_actual_arglist *args;
6560 gfc_se lse;
6561 gfc_se rse;
6562 gfc_saved_var *saved_vars;
6563 tree *temp_vars;
6564 tree type;
6565 tree tmp;
6566 int n;
6568 sym = expr->symtree->n.sym;
6569 args = expr->value.function.actual;
6570 gfc_init_se (&lse, NULL);
6571 gfc_init_se (&rse, NULL);
6573 n = 0;
6574 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6575 n++;
6576 saved_vars = XCNEWVEC (gfc_saved_var, n);
6577 temp_vars = XCNEWVEC (tree, n);
6579 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6580 fargs = fargs->next, n++)
6582 /* Each dummy shall be specified, explicitly or implicitly, to be
6583 scalar. */
6584 gcc_assert (fargs->sym->attr.dimension == 0);
6585 fsym = fargs->sym;
6587 if (fsym->ts.type == BT_CHARACTER)
6589 /* Copy string arguments. */
6590 tree arglen;
6592 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6593 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6595 /* Create a temporary to hold the value. */
6596 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6597 fsym->ts.u.cl->backend_decl
6598 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6600 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6601 temp_vars[n] = gfc_create_var (type, fsym->name);
6603 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6605 gfc_conv_expr (&rse, args->expr);
6606 gfc_conv_string_parameter (&rse);
6607 gfc_add_block_to_block (&se->pre, &lse.pre);
6608 gfc_add_block_to_block (&se->pre, &rse.pre);
6610 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6611 rse.string_length, rse.expr, fsym->ts.kind);
6612 gfc_add_block_to_block (&se->pre, &lse.post);
6613 gfc_add_block_to_block (&se->pre, &rse.post);
6615 else
6617 /* For everything else, just evaluate the expression. */
6619 /* Create a temporary to hold the value. */
6620 type = gfc_typenode_for_spec (&fsym->ts);
6621 temp_vars[n] = gfc_create_var (type, fsym->name);
6623 gfc_conv_expr (&lse, args->expr);
6625 gfc_add_block_to_block (&se->pre, &lse.pre);
6626 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6627 gfc_add_block_to_block (&se->pre, &lse.post);
6630 args = args->next;
6633 /* Use the temporary variables in place of the real ones. */
6634 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6635 fargs = fargs->next, n++)
6636 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6638 gfc_conv_expr (se, sym->value);
6640 if (sym->ts.type == BT_CHARACTER)
6642 gfc_conv_const_charlen (sym->ts.u.cl);
6644 /* Force the expression to the correct length. */
6645 if (!INTEGER_CST_P (se->string_length)
6646 || tree_int_cst_lt (se->string_length,
6647 sym->ts.u.cl->backend_decl))
6649 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6650 tmp = gfc_create_var (type, sym->name);
6651 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6652 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6653 sym->ts.kind, se->string_length, se->expr,
6654 sym->ts.kind);
6655 se->expr = tmp;
6657 se->string_length = sym->ts.u.cl->backend_decl;
6660 /* Restore the original variables. */
6661 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6662 fargs = fargs->next, n++)
6663 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6664 free (temp_vars);
6665 free (saved_vars);
6669 /* Translate a function expression. */
6671 static void
6672 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6674 gfc_symbol *sym;
6676 if (expr->value.function.isym)
6678 gfc_conv_intrinsic_function (se, expr);
6679 return;
6682 /* expr.value.function.esym is the resolved (specific) function symbol for
6683 most functions. However this isn't set for dummy procedures. */
6684 sym = expr->value.function.esym;
6685 if (!sym)
6686 sym = expr->symtree->n.sym;
6688 /* The IEEE_ARITHMETIC functions are caught here. */
6689 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6690 if (gfc_conv_ieee_arithmetic_function (se, expr))
6691 return;
6693 /* We distinguish statement functions from general functions to improve
6694 runtime performance. */
6695 if (sym->attr.proc == PROC_ST_FUNCTION)
6697 gfc_conv_statement_function (se, expr);
6698 return;
6701 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6702 NULL);
6706 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6708 static bool
6709 is_zero_initializer_p (gfc_expr * expr)
6711 if (expr->expr_type != EXPR_CONSTANT)
6712 return false;
6714 /* We ignore constants with prescribed memory representations for now. */
6715 if (expr->representation.string)
6716 return false;
6718 switch (expr->ts.type)
6720 case BT_INTEGER:
6721 return mpz_cmp_si (expr->value.integer, 0) == 0;
6723 case BT_REAL:
6724 return mpfr_zero_p (expr->value.real)
6725 && MPFR_SIGN (expr->value.real) >= 0;
6727 case BT_LOGICAL:
6728 return expr->value.logical == 0;
6730 case BT_COMPLEX:
6731 return mpfr_zero_p (mpc_realref (expr->value.complex))
6732 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
6733 && mpfr_zero_p (mpc_imagref (expr->value.complex))
6734 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
6736 default:
6737 break;
6739 return false;
6743 static void
6744 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
6746 gfc_ss *ss;
6748 ss = se->ss;
6749 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
6750 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
6752 gfc_conv_tmp_array_ref (se);
6756 /* Build a static initializer. EXPR is the expression for the initial value.
6757 The other parameters describe the variable of the component being
6758 initialized. EXPR may be null. */
6760 tree
6761 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
6762 bool array, bool pointer, bool procptr)
6764 gfc_se se;
6766 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
6767 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6768 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
6769 return build_constructor (type, NULL);
6771 if (!(expr || pointer || procptr))
6772 return NULL_TREE;
6774 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6775 (these are the only two iso_c_binding derived types that can be
6776 used as initialization expressions). If so, we need to modify
6777 the 'expr' to be that for a (void *). */
6778 if (expr != NULL && expr->ts.type == BT_DERIVED
6779 && expr->ts.is_iso_c && expr->ts.u.derived)
6781 gfc_symbol *derived = expr->ts.u.derived;
6783 /* The derived symbol has already been converted to a (void *). Use
6784 its kind. */
6785 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
6786 expr->ts.f90_type = derived->ts.f90_type;
6788 gfc_init_se (&se, NULL);
6789 gfc_conv_constant (&se, expr);
6790 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6791 return se.expr;
6794 if (array && !procptr)
6796 tree ctor;
6797 /* Arrays need special handling. */
6798 if (pointer)
6799 ctor = gfc_build_null_descriptor (type);
6800 /* Special case assigning an array to zero. */
6801 else if (is_zero_initializer_p (expr))
6802 ctor = build_constructor (type, NULL);
6803 else
6804 ctor = gfc_conv_array_initializer (type, expr);
6805 TREE_STATIC (ctor) = 1;
6806 return ctor;
6808 else if (pointer || procptr)
6810 if (ts->type == BT_CLASS && !procptr)
6812 gfc_init_se (&se, NULL);
6813 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
6814 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
6815 TREE_STATIC (se.expr) = 1;
6816 return se.expr;
6818 else if (!expr || expr->expr_type == EXPR_NULL)
6819 return fold_convert (type, null_pointer_node);
6820 else
6822 gfc_init_se (&se, NULL);
6823 se.want_pointer = 1;
6824 gfc_conv_expr (&se, expr);
6825 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6826 return se.expr;
6829 else
6831 switch (ts->type)
6833 case_bt_struct:
6834 case BT_CLASS:
6835 gfc_init_se (&se, NULL);
6836 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
6837 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
6838 else
6839 gfc_conv_structure (&se, expr, 1);
6840 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
6841 TREE_STATIC (se.expr) = 1;
6842 return se.expr;
6844 case BT_CHARACTER:
6846 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
6847 TREE_STATIC (ctor) = 1;
6848 return ctor;
6851 default:
6852 gfc_init_se (&se, NULL);
6853 gfc_conv_constant (&se, expr);
6854 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6855 return se.expr;
6860 static tree
6861 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
6863 gfc_se rse;
6864 gfc_se lse;
6865 gfc_ss *rss;
6866 gfc_ss *lss;
6867 gfc_array_info *lss_array;
6868 stmtblock_t body;
6869 stmtblock_t block;
6870 gfc_loopinfo loop;
6871 int n;
6872 tree tmp;
6874 gfc_start_block (&block);
6876 /* Initialize the scalarizer. */
6877 gfc_init_loopinfo (&loop);
6879 gfc_init_se (&lse, NULL);
6880 gfc_init_se (&rse, NULL);
6882 /* Walk the rhs. */
6883 rss = gfc_walk_expr (expr);
6884 if (rss == gfc_ss_terminator)
6885 /* The rhs is scalar. Add a ss for the expression. */
6886 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
6888 /* Create a SS for the destination. */
6889 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
6890 GFC_SS_COMPONENT);
6891 lss_array = &lss->info->data.array;
6892 lss_array->shape = gfc_get_shape (cm->as->rank);
6893 lss_array->descriptor = dest;
6894 lss_array->data = gfc_conv_array_data (dest);
6895 lss_array->offset = gfc_conv_array_offset (dest);
6896 for (n = 0; n < cm->as->rank; n++)
6898 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
6899 lss_array->stride[n] = gfc_index_one_node;
6901 mpz_init (lss_array->shape[n]);
6902 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
6903 cm->as->lower[n]->value.integer);
6904 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
6907 /* Associate the SS with the loop. */
6908 gfc_add_ss_to_loop (&loop, lss);
6909 gfc_add_ss_to_loop (&loop, rss);
6911 /* Calculate the bounds of the scalarization. */
6912 gfc_conv_ss_startstride (&loop);
6914 /* Setup the scalarizing loops. */
6915 gfc_conv_loop_setup (&loop, &expr->where);
6917 /* Setup the gfc_se structures. */
6918 gfc_copy_loopinfo_to_se (&lse, &loop);
6919 gfc_copy_loopinfo_to_se (&rse, &loop);
6921 rse.ss = rss;
6922 gfc_mark_ss_chain_used (rss, 1);
6923 lse.ss = lss;
6924 gfc_mark_ss_chain_used (lss, 1);
6926 /* Start the scalarized loop body. */
6927 gfc_start_scalarized_body (&loop, &body);
6929 gfc_conv_tmp_array_ref (&lse);
6930 if (cm->ts.type == BT_CHARACTER)
6931 lse.string_length = cm->ts.u.cl->backend_decl;
6933 gfc_conv_expr (&rse, expr);
6935 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
6936 gfc_add_expr_to_block (&body, tmp);
6938 gcc_assert (rse.ss == gfc_ss_terminator);
6940 /* Generate the copying loops. */
6941 gfc_trans_scalarizing_loops (&loop, &body);
6943 /* Wrap the whole thing up. */
6944 gfc_add_block_to_block (&block, &loop.pre);
6945 gfc_add_block_to_block (&block, &loop.post);
6947 gcc_assert (lss_array->shape != NULL);
6948 gfc_free_shape (&lss_array->shape, cm->as->rank);
6949 gfc_cleanup_loop (&loop);
6951 return gfc_finish_block (&block);
6955 static tree
6956 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
6957 gfc_expr * expr)
6959 gfc_se se;
6960 stmtblock_t block;
6961 tree offset;
6962 int n;
6963 tree tmp;
6964 tree tmp2;
6965 gfc_array_spec *as;
6966 gfc_expr *arg = NULL;
6968 gfc_start_block (&block);
6969 gfc_init_se (&se, NULL);
6971 /* Get the descriptor for the expressions. */
6972 se.want_pointer = 0;
6973 gfc_conv_expr_descriptor (&se, expr);
6974 gfc_add_block_to_block (&block, &se.pre);
6975 gfc_add_modify (&block, dest, se.expr);
6977 /* Deal with arrays of derived types with allocatable components. */
6978 if (gfc_bt_struct (cm->ts.type)
6979 && cm->ts.u.derived->attr.alloc_comp)
6980 // TODO: Fix caf_mode
6981 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
6982 se.expr, dest,
6983 cm->as->rank, 0);
6984 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
6985 && CLASS_DATA(cm)->attr.allocatable)
6987 if (cm->ts.u.derived->attr.alloc_comp)
6988 // TODO: Fix caf_mode
6989 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
6990 se.expr, dest,
6991 expr->rank, 0);
6992 else
6994 tmp = TREE_TYPE (dest);
6995 tmp = gfc_duplicate_allocatable (dest, se.expr,
6996 tmp, expr->rank, NULL_TREE);
6999 else
7000 tmp = gfc_duplicate_allocatable (dest, se.expr,
7001 TREE_TYPE(cm->backend_decl),
7002 cm->as->rank, NULL_TREE);
7004 gfc_add_expr_to_block (&block, tmp);
7005 gfc_add_block_to_block (&block, &se.post);
7007 if (expr->expr_type != EXPR_VARIABLE)
7008 gfc_conv_descriptor_data_set (&block, se.expr,
7009 null_pointer_node);
7011 /* We need to know if the argument of a conversion function is a
7012 variable, so that the correct lower bound can be used. */
7013 if (expr->expr_type == EXPR_FUNCTION
7014 && expr->value.function.isym
7015 && expr->value.function.isym->conversion
7016 && expr->value.function.actual->expr
7017 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7018 arg = expr->value.function.actual->expr;
7020 /* Obtain the array spec of full array references. */
7021 if (arg)
7022 as = gfc_get_full_arrayspec_from_expr (arg);
7023 else
7024 as = gfc_get_full_arrayspec_from_expr (expr);
7026 /* Shift the lbound and ubound of temporaries to being unity,
7027 rather than zero, based. Always calculate the offset. */
7028 offset = gfc_conv_descriptor_offset_get (dest);
7029 gfc_add_modify (&block, offset, gfc_index_zero_node);
7030 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7032 for (n = 0; n < expr->rank; n++)
7034 tree span;
7035 tree lbound;
7037 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7038 TODO It looks as if gfc_conv_expr_descriptor should return
7039 the correct bounds and that the following should not be
7040 necessary. This would simplify gfc_conv_intrinsic_bound
7041 as well. */
7042 if (as && as->lower[n])
7044 gfc_se lbse;
7045 gfc_init_se (&lbse, NULL);
7046 gfc_conv_expr (&lbse, as->lower[n]);
7047 gfc_add_block_to_block (&block, &lbse.pre);
7048 lbound = gfc_evaluate_now (lbse.expr, &block);
7050 else if (as && arg)
7052 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7053 lbound = gfc_conv_descriptor_lbound_get (tmp,
7054 gfc_rank_cst[n]);
7056 else if (as)
7057 lbound = gfc_conv_descriptor_lbound_get (dest,
7058 gfc_rank_cst[n]);
7059 else
7060 lbound = gfc_index_one_node;
7062 lbound = fold_convert (gfc_array_index_type, lbound);
7064 /* Shift the bounds and set the offset accordingly. */
7065 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7066 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7067 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7068 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7069 span, lbound);
7070 gfc_conv_descriptor_ubound_set (&block, dest,
7071 gfc_rank_cst[n], tmp);
7072 gfc_conv_descriptor_lbound_set (&block, dest,
7073 gfc_rank_cst[n], lbound);
7075 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7076 gfc_conv_descriptor_lbound_get (dest,
7077 gfc_rank_cst[n]),
7078 gfc_conv_descriptor_stride_get (dest,
7079 gfc_rank_cst[n]));
7080 gfc_add_modify (&block, tmp2, tmp);
7081 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7082 offset, tmp2);
7083 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7086 if (arg)
7088 /* If a conversion expression has a null data pointer
7089 argument, nullify the allocatable component. */
7090 tree non_null_expr;
7091 tree null_expr;
7093 if (arg->symtree->n.sym->attr.allocatable
7094 || arg->symtree->n.sym->attr.pointer)
7096 non_null_expr = gfc_finish_block (&block);
7097 gfc_start_block (&block);
7098 gfc_conv_descriptor_data_set (&block, dest,
7099 null_pointer_node);
7100 null_expr = gfc_finish_block (&block);
7101 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7102 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
7103 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7104 return build3_v (COND_EXPR, tmp,
7105 null_expr, non_null_expr);
7109 return gfc_finish_block (&block);
7113 /* Allocate or reallocate scalar component, as necessary. */
7115 static void
7116 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7117 tree comp,
7118 gfc_component *cm,
7119 gfc_expr *expr2,
7120 gfc_symbol *sym)
7122 tree tmp;
7123 tree ptr;
7124 tree size;
7125 tree size_in_bytes;
7126 tree lhs_cl_size = NULL_TREE;
7128 if (!comp)
7129 return;
7131 if (!expr2 || expr2->rank)
7132 return;
7134 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7136 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7138 char name[GFC_MAX_SYMBOL_LEN+9];
7139 gfc_component *strlen;
7140 /* Use the rhs string length and the lhs element size. */
7141 gcc_assert (expr2->ts.type == BT_CHARACTER);
7142 if (!expr2->ts.u.cl->backend_decl)
7144 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7145 gcc_assert (expr2->ts.u.cl->backend_decl);
7148 size = expr2->ts.u.cl->backend_decl;
7150 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7151 component. */
7152 sprintf (name, "_%s_length", cm->name);
7153 strlen = gfc_find_component (sym, name, true, true, NULL);
7154 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7155 gfc_charlen_type_node,
7156 TREE_OPERAND (comp, 0),
7157 strlen->backend_decl, NULL_TREE);
7159 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7160 tmp = TYPE_SIZE_UNIT (tmp);
7161 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7162 TREE_TYPE (tmp), tmp,
7163 fold_convert (TREE_TYPE (tmp), size));
7165 else if (cm->ts.type == BT_CLASS)
7167 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7168 if (expr2->ts.type == BT_DERIVED)
7170 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7171 size = TYPE_SIZE_UNIT (tmp);
7173 else
7175 gfc_expr *e2vtab;
7176 gfc_se se;
7177 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7178 gfc_add_vptr_component (e2vtab);
7179 gfc_add_size_component (e2vtab);
7180 gfc_init_se (&se, NULL);
7181 gfc_conv_expr (&se, e2vtab);
7182 gfc_add_block_to_block (block, &se.pre);
7183 size = fold_convert (size_type_node, se.expr);
7184 gfc_free_expr (e2vtab);
7186 size_in_bytes = size;
7188 else
7190 /* Otherwise use the length in bytes of the rhs. */
7191 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7192 size_in_bytes = size;
7195 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7196 size_in_bytes, size_one_node);
7198 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7200 tmp = build_call_expr_loc (input_location,
7201 builtin_decl_explicit (BUILT_IN_CALLOC),
7202 2, build_one_cst (size_type_node),
7203 size_in_bytes);
7204 tmp = fold_convert (TREE_TYPE (comp), tmp);
7205 gfc_add_modify (block, comp, tmp);
7207 else
7209 tmp = build_call_expr_loc (input_location,
7210 builtin_decl_explicit (BUILT_IN_MALLOC),
7211 1, size_in_bytes);
7212 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7213 ptr = gfc_class_data_get (comp);
7214 else
7215 ptr = comp;
7216 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7217 gfc_add_modify (block, ptr, tmp);
7220 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7221 /* Update the lhs character length. */
7222 gfc_add_modify (block, lhs_cl_size, size);
7226 /* Assign a single component of a derived type constructor. */
7228 static tree
7229 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7230 gfc_symbol *sym, bool init)
7232 gfc_se se;
7233 gfc_se lse;
7234 stmtblock_t block;
7235 tree tmp;
7236 tree vtab;
7238 gfc_start_block (&block);
7240 if (cm->attr.pointer || cm->attr.proc_pointer)
7242 /* Only care about pointers here, not about allocatables. */
7243 gfc_init_se (&se, NULL);
7244 /* Pointer component. */
7245 if ((cm->attr.dimension || cm->attr.codimension)
7246 && !cm->attr.proc_pointer)
7248 /* Array pointer. */
7249 if (expr->expr_type == EXPR_NULL)
7250 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7251 else
7253 se.direct_byref = 1;
7254 se.expr = dest;
7255 gfc_conv_expr_descriptor (&se, expr);
7256 gfc_add_block_to_block (&block, &se.pre);
7257 gfc_add_block_to_block (&block, &se.post);
7260 else
7262 /* Scalar pointers. */
7263 se.want_pointer = 1;
7264 gfc_conv_expr (&se, expr);
7265 gfc_add_block_to_block (&block, &se.pre);
7267 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7268 && expr->symtree->n.sym->attr.dummy)
7269 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7271 gfc_add_modify (&block, dest,
7272 fold_convert (TREE_TYPE (dest), se.expr));
7273 gfc_add_block_to_block (&block, &se.post);
7276 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7278 /* NULL initialization for CLASS components. */
7279 tmp = gfc_trans_structure_assign (dest,
7280 gfc_class_initializer (&cm->ts, expr),
7281 false);
7282 gfc_add_expr_to_block (&block, tmp);
7284 else if ((cm->attr.dimension || cm->attr.codimension)
7285 && !cm->attr.proc_pointer)
7287 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7288 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7289 else if (cm->attr.allocatable)
7291 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7292 gfc_add_expr_to_block (&block, tmp);
7294 else
7296 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7297 gfc_add_expr_to_block (&block, tmp);
7300 else if (cm->ts.type == BT_CLASS
7301 && CLASS_DATA (cm)->attr.dimension
7302 && CLASS_DATA (cm)->attr.allocatable
7303 && expr->ts.type == BT_DERIVED)
7305 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7306 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7307 tmp = gfc_class_vptr_get (dest);
7308 gfc_add_modify (&block, tmp,
7309 fold_convert (TREE_TYPE (tmp), vtab));
7310 tmp = gfc_class_data_get (dest);
7311 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7312 gfc_add_expr_to_block (&block, tmp);
7314 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7316 /* NULL initialization for allocatable components. */
7317 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7318 null_pointer_node));
7320 else if (init && (cm->attr.allocatable
7321 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7322 && expr->ts.type != BT_CLASS)))
7324 /* Take care about non-array allocatable components here. The alloc_*
7325 routine below is motivated by the alloc_scalar_allocatable_for_
7326 assignment() routine, but with the realloc portions removed and
7327 different input. */
7328 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7329 dest,
7331 expr,
7332 sym);
7333 /* The remainder of these instructions follow the if (cm->attr.pointer)
7334 if (!cm->attr.dimension) part above. */
7335 gfc_init_se (&se, NULL);
7336 gfc_conv_expr (&se, expr);
7337 gfc_add_block_to_block (&block, &se.pre);
7339 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7340 && expr->symtree->n.sym->attr.dummy)
7341 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7343 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7345 tmp = gfc_class_data_get (dest);
7346 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7347 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7348 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7349 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7350 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7352 else
7353 tmp = build_fold_indirect_ref_loc (input_location, dest);
7355 /* For deferred strings insert a memcpy. */
7356 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7358 tree size;
7359 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7360 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7361 ? se.string_length
7362 : expr->ts.u.cl->backend_decl);
7363 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7364 gfc_add_expr_to_block (&block, tmp);
7366 else
7367 gfc_add_modify (&block, tmp,
7368 fold_convert (TREE_TYPE (tmp), se.expr));
7369 gfc_add_block_to_block (&block, &se.post);
7371 else if (expr->ts.type == BT_UNION)
7373 tree tmp;
7374 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7375 /* We mark that the entire union should be initialized with a contrived
7376 EXPR_NULL expression at the beginning. */
7377 if (c != NULL && c->n.component == NULL
7378 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7380 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7381 dest, build_constructor (TREE_TYPE (dest), NULL));
7382 gfc_add_expr_to_block (&block, tmp);
7383 c = gfc_constructor_next (c);
7385 /* The following constructor expression, if any, represents a specific
7386 map intializer, as given by the user. */
7387 if (c != NULL && c->expr != NULL)
7389 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7390 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7391 gfc_add_expr_to_block (&block, tmp);
7394 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7396 if (expr->expr_type != EXPR_STRUCTURE)
7398 tree dealloc = NULL_TREE;
7399 gfc_init_se (&se, NULL);
7400 gfc_conv_expr (&se, expr);
7401 gfc_add_block_to_block (&block, &se.pre);
7402 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7403 expression in a temporary variable and deallocate the allocatable
7404 components. Then we can the copy the expression to the result. */
7405 if (cm->ts.u.derived->attr.alloc_comp
7406 && expr->expr_type != EXPR_VARIABLE)
7408 se.expr = gfc_evaluate_now (se.expr, &block);
7409 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7410 expr->rank);
7412 gfc_add_modify (&block, dest,
7413 fold_convert (TREE_TYPE (dest), se.expr));
7414 if (cm->ts.u.derived->attr.alloc_comp
7415 && expr->expr_type != EXPR_NULL)
7417 // TODO: Fix caf_mode
7418 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7419 dest, expr->rank, 0);
7420 gfc_add_expr_to_block (&block, tmp);
7421 if (dealloc != NULL_TREE)
7422 gfc_add_expr_to_block (&block, dealloc);
7424 gfc_add_block_to_block (&block, &se.post);
7426 else
7428 /* Nested constructors. */
7429 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7430 gfc_add_expr_to_block (&block, tmp);
7433 else if (gfc_deferred_strlen (cm, &tmp))
7435 tree strlen;
7436 strlen = tmp;
7437 gcc_assert (strlen);
7438 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7439 TREE_TYPE (strlen),
7440 TREE_OPERAND (dest, 0),
7441 strlen, NULL_TREE);
7443 if (expr->expr_type == EXPR_NULL)
7445 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7446 gfc_add_modify (&block, dest, tmp);
7447 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7448 gfc_add_modify (&block, strlen, tmp);
7450 else
7452 tree size;
7453 gfc_init_se (&se, NULL);
7454 gfc_conv_expr (&se, expr);
7455 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7456 tmp = build_call_expr_loc (input_location,
7457 builtin_decl_explicit (BUILT_IN_MALLOC),
7458 1, size);
7459 gfc_add_modify (&block, dest,
7460 fold_convert (TREE_TYPE (dest), tmp));
7461 gfc_add_modify (&block, strlen, se.string_length);
7462 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7463 gfc_add_expr_to_block (&block, tmp);
7466 else if (!cm->attr.artificial)
7468 /* Scalar component (excluding deferred parameters). */
7469 gfc_init_se (&se, NULL);
7470 gfc_init_se (&lse, NULL);
7472 gfc_conv_expr (&se, expr);
7473 if (cm->ts.type == BT_CHARACTER)
7474 lse.string_length = cm->ts.u.cl->backend_decl;
7475 lse.expr = dest;
7476 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7477 gfc_add_expr_to_block (&block, tmp);
7479 return gfc_finish_block (&block);
7482 /* Assign a derived type constructor to a variable. */
7484 tree
7485 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7487 gfc_constructor *c;
7488 gfc_component *cm;
7489 stmtblock_t block;
7490 tree field;
7491 tree tmp;
7492 gfc_se se;
7494 gfc_start_block (&block);
7495 cm = expr->ts.u.derived->components;
7497 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7498 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7499 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7501 gfc_se lse;
7503 gfc_init_se (&se, NULL);
7504 gfc_init_se (&lse, NULL);
7505 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7506 lse.expr = dest;
7507 gfc_add_modify (&block, lse.expr,
7508 fold_convert (TREE_TYPE (lse.expr), se.expr));
7510 return gfc_finish_block (&block);
7513 if (coarray)
7514 gfc_init_se (&se, NULL);
7516 for (c = gfc_constructor_first (expr->value.constructor);
7517 c; c = gfc_constructor_next (c), cm = cm->next)
7519 /* Skip absent members in default initializers. */
7520 if (!c->expr && !cm->attr.allocatable)
7521 continue;
7523 /* Register the component with the caf-lib before it is initialized.
7524 Register only allocatable components, that are not coarray'ed
7525 components (%comp[*]). Only register when the constructor is not the
7526 null-expression. */
7527 if (coarray && !cm->attr.codimension
7528 && (cm->attr.allocatable || cm->attr.pointer)
7529 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7531 tree token, desc, size;
7532 bool is_array = cm->ts.type == BT_CLASS
7533 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7535 field = cm->backend_decl;
7536 field = fold_build3_loc (input_location, COMPONENT_REF,
7537 TREE_TYPE (field), dest, field, NULL_TREE);
7538 if (cm->ts.type == BT_CLASS)
7539 field = gfc_class_data_get (field);
7541 token = is_array ? gfc_conv_descriptor_token (field)
7542 : fold_build3_loc (input_location, COMPONENT_REF,
7543 TREE_TYPE (cm->caf_token), dest,
7544 cm->caf_token, NULL_TREE);
7546 if (is_array)
7548 /* The _caf_register routine looks at the rank of the array
7549 descriptor to decide whether the data registered is an array
7550 or not. */
7551 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7552 : cm->as->rank;
7553 /* When the rank is not known just set a positive rank, which
7554 suffices to recognize the data as array. */
7555 if (rank < 0)
7556 rank = 1;
7557 size = integer_zero_node;
7558 desc = field;
7559 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
7560 build_int_cst (gfc_array_index_type, rank));
7562 else
7564 desc = gfc_conv_scalar_to_descriptor (&se, field,
7565 cm->ts.type == BT_CLASS
7566 ? CLASS_DATA (cm)->attr
7567 : cm->attr);
7568 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7570 gfc_add_block_to_block (&block, &se.pre);
7571 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7572 7, size, build_int_cst (
7573 integer_type_node,
7574 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7575 gfc_build_addr_expr (pvoid_type_node,
7576 token),
7577 gfc_build_addr_expr (NULL_TREE, desc),
7578 null_pointer_node, null_pointer_node,
7579 integer_zero_node);
7580 gfc_add_expr_to_block (&block, tmp);
7582 field = cm->backend_decl;
7583 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7584 dest, field, NULL_TREE);
7585 if (!c->expr)
7587 gfc_expr *e = gfc_get_null_expr (NULL);
7588 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7589 init);
7590 gfc_free_expr (e);
7592 else
7593 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7594 expr->ts.u.derived, init);
7595 gfc_add_expr_to_block (&block, tmp);
7597 return gfc_finish_block (&block);
7600 void
7601 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7602 gfc_component *un, gfc_expr *init)
7604 gfc_constructor *ctor;
7606 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7607 return;
7609 ctor = gfc_constructor_first (init->value.constructor);
7611 if (ctor == NULL || ctor->expr == NULL)
7612 return;
7614 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7616 /* If we have an 'initialize all' constructor, do it first. */
7617 if (ctor->expr->expr_type == EXPR_NULL)
7619 tree union_type = TREE_TYPE (un->backend_decl);
7620 tree val = build_constructor (union_type, NULL);
7621 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7622 ctor = gfc_constructor_next (ctor);
7625 /* Add the map initializer on top. */
7626 if (ctor != NULL && ctor->expr != NULL)
7628 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7629 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7630 TREE_TYPE (un->backend_decl),
7631 un->attr.dimension, un->attr.pointer,
7632 un->attr.proc_pointer);
7633 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7637 /* Build an expression for a constructor. If init is nonzero then
7638 this is part of a static variable initializer. */
7640 void
7641 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7643 gfc_constructor *c;
7644 gfc_component *cm;
7645 tree val;
7646 tree type;
7647 tree tmp;
7648 vec<constructor_elt, va_gc> *v = NULL;
7650 gcc_assert (se->ss == NULL);
7651 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7652 type = gfc_typenode_for_spec (&expr->ts);
7654 if (!init)
7656 /* Create a temporary variable and fill it in. */
7657 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7658 /* The symtree in expr is NULL, if the code to generate is for
7659 initializing the static members only. */
7660 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7661 se->want_coarray);
7662 gfc_add_expr_to_block (&se->pre, tmp);
7663 return;
7666 cm = expr->ts.u.derived->components;
7668 for (c = gfc_constructor_first (expr->value.constructor);
7669 c; c = gfc_constructor_next (c), cm = cm->next)
7671 /* Skip absent members in default initializers and allocatable
7672 components. Although the latter have a default initializer
7673 of EXPR_NULL,... by default, the static nullify is not needed
7674 since this is done every time we come into scope. */
7675 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7676 continue;
7678 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7679 && strcmp (cm->name, "_extends") == 0
7680 && cm->initializer->symtree)
7682 tree vtab;
7683 gfc_symbol *vtabs;
7684 vtabs = cm->initializer->symtree->n.sym;
7685 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7686 vtab = unshare_expr_without_location (vtab);
7687 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
7689 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
7691 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
7692 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7693 fold_convert (TREE_TYPE (cm->backend_decl),
7694 val));
7696 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
7697 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7698 fold_convert (TREE_TYPE (cm->backend_decl),
7699 integer_zero_node));
7700 else if (cm->ts.type == BT_UNION)
7701 gfc_conv_union_initializer (v, cm, c->expr);
7702 else
7704 val = gfc_conv_initializer (c->expr, &cm->ts,
7705 TREE_TYPE (cm->backend_decl),
7706 cm->attr.dimension, cm->attr.pointer,
7707 cm->attr.proc_pointer);
7708 val = unshare_expr_without_location (val);
7710 /* Append it to the constructor list. */
7711 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
7715 se->expr = build_constructor (type, v);
7716 if (init)
7717 TREE_CONSTANT (se->expr) = 1;
7721 /* Translate a substring expression. */
7723 static void
7724 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
7726 gfc_ref *ref;
7728 ref = expr->ref;
7730 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
7732 se->expr = gfc_build_wide_string_const (expr->ts.kind,
7733 expr->value.character.length,
7734 expr->value.character.string);
7736 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
7737 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
7739 if (ref)
7740 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
7744 /* Entry point for expression translation. Evaluates a scalar quantity.
7745 EXPR is the expression to be translated, and SE is the state structure if
7746 called from within the scalarized. */
7748 void
7749 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
7751 gfc_ss *ss;
7753 ss = se->ss;
7754 if (ss && ss->info->expr == expr
7755 && (ss->info->type == GFC_SS_SCALAR
7756 || ss->info->type == GFC_SS_REFERENCE))
7758 gfc_ss_info *ss_info;
7760 ss_info = ss->info;
7761 /* Substitute a scalar expression evaluated outside the scalarization
7762 loop. */
7763 se->expr = ss_info->data.scalar.value;
7764 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
7765 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7767 se->string_length = ss_info->string_length;
7768 gfc_advance_se_ss_chain (se);
7769 return;
7772 /* We need to convert the expressions for the iso_c_binding derived types.
7773 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7774 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7775 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7776 updated to be an integer with a kind equal to the size of a (void *). */
7777 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
7778 && expr->ts.u.derived->attr.is_bind_c)
7780 if (expr->expr_type == EXPR_VARIABLE
7781 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
7782 || expr->symtree->n.sym->intmod_sym_id
7783 == ISOCBINDING_NULL_FUNPTR))
7785 /* Set expr_type to EXPR_NULL, which will result in
7786 null_pointer_node being used below. */
7787 expr->expr_type = EXPR_NULL;
7789 else
7791 /* Update the type/kind of the expression to be what the new
7792 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7793 expr->ts.type = BT_INTEGER;
7794 expr->ts.f90_type = BT_VOID;
7795 expr->ts.kind = gfc_index_integer_kind;
7799 gfc_fix_class_refs (expr);
7801 switch (expr->expr_type)
7803 case EXPR_OP:
7804 gfc_conv_expr_op (se, expr);
7805 break;
7807 case EXPR_FUNCTION:
7808 gfc_conv_function_expr (se, expr);
7809 break;
7811 case EXPR_CONSTANT:
7812 gfc_conv_constant (se, expr);
7813 break;
7815 case EXPR_VARIABLE:
7816 gfc_conv_variable (se, expr);
7817 break;
7819 case EXPR_NULL:
7820 se->expr = null_pointer_node;
7821 break;
7823 case EXPR_SUBSTRING:
7824 gfc_conv_substring_expr (se, expr);
7825 break;
7827 case EXPR_STRUCTURE:
7828 gfc_conv_structure (se, expr, 0);
7829 break;
7831 case EXPR_ARRAY:
7832 gfc_conv_array_constructor_expr (se, expr);
7833 break;
7835 default:
7836 gcc_unreachable ();
7837 break;
7841 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7842 of an assignment. */
7843 void
7844 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
7846 gfc_conv_expr (se, expr);
7847 /* All numeric lvalues should have empty post chains. If not we need to
7848 figure out a way of rewriting an lvalue so that it has no post chain. */
7849 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
7852 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7853 numeric expressions. Used for scalar values where inserting cleanup code
7854 is inconvenient. */
7855 void
7856 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
7858 tree val;
7860 gcc_assert (expr->ts.type != BT_CHARACTER);
7861 gfc_conv_expr (se, expr);
7862 if (se->post.head)
7864 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
7865 gfc_add_modify (&se->pre, val, se->expr);
7866 se->expr = val;
7867 gfc_add_block_to_block (&se->pre, &se->post);
7871 /* Helper to translate an expression and convert it to a particular type. */
7872 void
7873 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
7875 gfc_conv_expr_val (se, expr);
7876 se->expr = convert (type, se->expr);
7880 /* Converts an expression so that it can be passed by reference. Scalar
7881 values only. */
7883 void
7884 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
7886 gfc_ss *ss;
7887 tree var;
7889 ss = se->ss;
7890 if (ss && ss->info->expr == expr
7891 && ss->info->type == GFC_SS_REFERENCE)
7893 /* Returns a reference to the scalar evaluated outside the loop
7894 for this case. */
7895 gfc_conv_expr (se, expr);
7897 if (expr->ts.type == BT_CHARACTER
7898 && expr->expr_type != EXPR_FUNCTION)
7899 gfc_conv_string_parameter (se);
7900 else
7901 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7903 return;
7906 if (expr->ts.type == BT_CHARACTER)
7908 gfc_conv_expr (se, expr);
7909 gfc_conv_string_parameter (se);
7910 return;
7913 if (expr->expr_type == EXPR_VARIABLE)
7915 se->want_pointer = 1;
7916 gfc_conv_expr (se, expr);
7917 if (se->post.head)
7919 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
7920 gfc_add_modify (&se->pre, var, se->expr);
7921 gfc_add_block_to_block (&se->pre, &se->post);
7922 se->expr = var;
7924 return;
7927 if (expr->expr_type == EXPR_FUNCTION
7928 && ((expr->value.function.esym
7929 && expr->value.function.esym->result->attr.pointer
7930 && !expr->value.function.esym->result->attr.dimension)
7931 || (!expr->value.function.esym && !expr->ref
7932 && expr->symtree->n.sym->attr.pointer
7933 && !expr->symtree->n.sym->attr.dimension)))
7935 se->want_pointer = 1;
7936 gfc_conv_expr (se, expr);
7937 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
7938 gfc_add_modify (&se->pre, var, se->expr);
7939 se->expr = var;
7940 return;
7943 gfc_conv_expr (se, expr);
7945 /* Create a temporary var to hold the value. */
7946 if (TREE_CONSTANT (se->expr))
7948 tree tmp = se->expr;
7949 STRIP_TYPE_NOPS (tmp);
7950 var = build_decl (input_location,
7951 CONST_DECL, NULL, TREE_TYPE (tmp));
7952 DECL_INITIAL (var) = tmp;
7953 TREE_STATIC (var) = 1;
7954 pushdecl (var);
7956 else
7958 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
7959 gfc_add_modify (&se->pre, var, se->expr);
7961 gfc_add_block_to_block (&se->pre, &se->post);
7963 /* Take the address of that value. */
7964 se->expr = gfc_build_addr_expr (NULL_TREE, var);
7968 /* Get the _len component for an unlimited polymorphic expression. */
7970 static tree
7971 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
7973 gfc_se se;
7974 gfc_ref *ref = expr->ref;
7976 gfc_init_se (&se, NULL);
7977 while (ref && ref->next)
7978 ref = ref->next;
7979 gfc_add_len_component (expr);
7980 gfc_conv_expr (&se, expr);
7981 gfc_add_block_to_block (block, &se.pre);
7982 gcc_assert (se.post.head == NULL_TREE);
7983 if (ref)
7985 gfc_free_ref_list (ref->next);
7986 ref->next = NULL;
7988 else
7990 gfc_free_ref_list (expr->ref);
7991 expr->ref = NULL;
7993 return se.expr;
7997 /* Assign _vptr and _len components as appropriate. BLOCK should be a
7998 statement-list outside of the scalarizer-loop. When code is generated, that
7999 depends on the scalarized expression, it is added to RSE.PRE.
8000 Returns le's _vptr tree and when set the len expressions in to_lenp and
8001 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8002 expression. */
8004 static tree
8005 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8006 gfc_expr * re, gfc_se *rse,
8007 tree * to_lenp, tree * from_lenp)
8009 gfc_se se;
8010 gfc_expr * vptr_expr;
8011 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8012 bool set_vptr = false, temp_rhs = false;
8013 stmtblock_t *pre = block;
8015 /* Create a temporary for complicated expressions. */
8016 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8017 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8019 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8020 pre = &rse->pre;
8021 gfc_add_modify (&rse->pre, tmp, rse->expr);
8022 rse->expr = tmp;
8023 temp_rhs = true;
8026 /* Get the _vptr for the left-hand side expression. */
8027 gfc_init_se (&se, NULL);
8028 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8029 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8031 /* Care about _len for unlimited polymorphic entities. */
8032 if (UNLIMITED_POLY (vptr_expr)
8033 || (vptr_expr->ts.type == BT_DERIVED
8034 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8035 to_len = trans_get_upoly_len (block, vptr_expr);
8036 gfc_add_vptr_component (vptr_expr);
8037 set_vptr = true;
8039 else
8040 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8041 se.want_pointer = 1;
8042 gfc_conv_expr (&se, vptr_expr);
8043 gfc_free_expr (vptr_expr);
8044 gfc_add_block_to_block (block, &se.pre);
8045 gcc_assert (se.post.head == NULL_TREE);
8046 lhs_vptr = se.expr;
8047 STRIP_NOPS (lhs_vptr);
8049 /* Set the _vptr only when the left-hand side of the assignment is a
8050 class-object. */
8051 if (set_vptr)
8053 /* Get the vptr from the rhs expression only, when it is variable.
8054 Functions are expected to be assigned to a temporary beforehand. */
8055 vptr_expr = re->expr_type == EXPR_VARIABLE
8056 ? gfc_find_and_cut_at_last_class_ref (re)
8057 : NULL;
8058 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8060 if (to_len != NULL_TREE)
8062 /* Get the _len information from the rhs. */
8063 if (UNLIMITED_POLY (vptr_expr)
8064 || (vptr_expr->ts.type == BT_DERIVED
8065 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8066 from_len = trans_get_upoly_len (block, vptr_expr);
8068 gfc_add_vptr_component (vptr_expr);
8070 else
8072 if (re->expr_type == EXPR_VARIABLE
8073 && DECL_P (re->symtree->n.sym->backend_decl)
8074 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8075 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8076 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8077 re->symtree->n.sym->backend_decl))))
8079 vptr_expr = NULL;
8080 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8081 re->symtree->n.sym->backend_decl));
8082 if (to_len)
8083 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8084 re->symtree->n.sym->backend_decl));
8086 else if (temp_rhs && re->ts.type == BT_CLASS)
8088 vptr_expr = NULL;
8089 se.expr = gfc_class_vptr_get (rse->expr);
8091 else if (re->expr_type != EXPR_NULL)
8092 /* Only when rhs is non-NULL use its declared type for vptr
8093 initialisation. */
8094 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8095 else
8096 /* When the rhs is NULL use the vtab of lhs' declared type. */
8097 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8100 if (vptr_expr)
8102 gfc_init_se (&se, NULL);
8103 se.want_pointer = 1;
8104 gfc_conv_expr (&se, vptr_expr);
8105 gfc_free_expr (vptr_expr);
8106 gfc_add_block_to_block (block, &se.pre);
8107 gcc_assert (se.post.head == NULL_TREE);
8109 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8110 se.expr));
8112 if (to_len != NULL_TREE)
8114 /* The _len component needs to be set. Figure how to get the
8115 value of the right-hand side. */
8116 if (from_len == NULL_TREE)
8118 if (rse->string_length != NULL_TREE)
8119 from_len = rse->string_length;
8120 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8122 from_len = gfc_get_expr_charlen (re);
8123 gfc_init_se (&se, NULL);
8124 gfc_conv_expr (&se, re->ts.u.cl->length);
8125 gfc_add_block_to_block (block, &se.pre);
8126 gcc_assert (se.post.head == NULL_TREE);
8127 from_len = gfc_evaluate_now (se.expr, block);
8129 else
8130 from_len = integer_zero_node;
8132 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8133 from_len));
8137 /* Return the _len trees only, when requested. */
8138 if (to_lenp)
8139 *to_lenp = to_len;
8140 if (from_lenp)
8141 *from_lenp = from_len;
8142 return lhs_vptr;
8146 /* Assign tokens for pointer components. */
8148 static void
8149 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8150 gfc_expr *expr2)
8152 symbol_attribute lhs_attr, rhs_attr;
8153 tree tmp, lhs_tok, rhs_tok;
8154 /* Flag to indicated component refs on the rhs. */
8155 bool rhs_cr;
8157 lhs_attr = gfc_caf_attr (expr1);
8158 if (expr2->expr_type != EXPR_NULL)
8160 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8161 if (lhs_attr.codimension && rhs_attr.codimension)
8163 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8164 lhs_tok = build_fold_indirect_ref (lhs_tok);
8166 if (rhs_cr)
8167 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8168 else
8170 tree caf_decl;
8171 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8172 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8173 NULL_TREE, NULL);
8175 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8176 lhs_tok,
8177 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8178 gfc_prepend_expr_to_block (&lse->post, tmp);
8181 else if (lhs_attr.codimension)
8183 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8184 lhs_tok = build_fold_indirect_ref (lhs_tok);
8185 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8186 lhs_tok, null_pointer_node);
8187 gfc_prepend_expr_to_block (&lse->post, tmp);
8191 /* Indentify class valued proc_pointer assignments. */
8193 static bool
8194 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8196 gfc_ref * ref;
8198 ref = expr1->ref;
8199 while (ref && ref->next)
8200 ref = ref->next;
8202 return ref && ref->type == REF_COMPONENT
8203 && ref->u.c.component->attr.proc_pointer
8204 && expr2->expr_type == EXPR_VARIABLE
8205 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8209 tree
8210 gfc_trans_pointer_assign (gfc_code * code)
8212 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8216 /* Generate code for a pointer assignment. */
8218 tree
8219 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8221 gfc_se lse;
8222 gfc_se rse;
8223 stmtblock_t block;
8224 tree desc;
8225 tree tmp;
8226 tree decl;
8227 bool scalar, non_proc_pointer_assign;
8228 gfc_ss *ss;
8230 gfc_start_block (&block);
8232 gfc_init_se (&lse, NULL);
8234 /* Usually testing whether this is not a proc pointer assignment. */
8235 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8237 /* Check whether the expression is a scalar or not; we cannot use
8238 expr1->rank as it can be nonzero for proc pointers. */
8239 ss = gfc_walk_expr (expr1);
8240 scalar = ss == gfc_ss_terminator;
8241 if (!scalar)
8242 gfc_free_ss_chain (ss);
8244 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8245 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8247 gfc_add_data_component (expr2);
8248 /* The following is required as gfc_add_data_component doesn't
8249 update ts.type if there is a tailing REF_ARRAY. */
8250 expr2->ts.type = BT_DERIVED;
8253 if (scalar)
8255 /* Scalar pointers. */
8256 lse.want_pointer = 1;
8257 gfc_conv_expr (&lse, expr1);
8258 gfc_init_se (&rse, NULL);
8259 rse.want_pointer = 1;
8260 gfc_conv_expr (&rse, expr2);
8262 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8264 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8265 NULL);
8266 lse.expr = gfc_class_data_get (lse.expr);
8269 if (expr1->symtree->n.sym->attr.proc_pointer
8270 && expr1->symtree->n.sym->attr.dummy)
8271 lse.expr = build_fold_indirect_ref_loc (input_location,
8272 lse.expr);
8274 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8275 && expr2->symtree->n.sym->attr.dummy)
8276 rse.expr = build_fold_indirect_ref_loc (input_location,
8277 rse.expr);
8279 gfc_add_block_to_block (&block, &lse.pre);
8280 gfc_add_block_to_block (&block, &rse.pre);
8282 /* Check character lengths if character expression. The test is only
8283 really added if -fbounds-check is enabled. Exclude deferred
8284 character length lefthand sides. */
8285 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8286 && !expr1->ts.deferred
8287 && !expr1->symtree->n.sym->attr.proc_pointer
8288 && !gfc_is_proc_ptr_comp (expr1))
8290 gcc_assert (expr2->ts.type == BT_CHARACTER);
8291 gcc_assert (lse.string_length && rse.string_length);
8292 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8293 lse.string_length, rse.string_length,
8294 &block);
8297 /* The assignment to an deferred character length sets the string
8298 length to that of the rhs. */
8299 if (expr1->ts.deferred)
8301 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8302 gfc_add_modify (&block, lse.string_length, rse.string_length);
8303 else if (lse.string_length != NULL)
8304 gfc_add_modify (&block, lse.string_length,
8305 build_int_cst (gfc_charlen_type_node, 0));
8308 gfc_add_modify (&block, lse.expr,
8309 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8311 /* Also set the tokens for pointer components in derived typed
8312 coarrays. */
8313 if (flag_coarray == GFC_FCOARRAY_LIB)
8314 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8316 gfc_add_block_to_block (&block, &rse.post);
8317 gfc_add_block_to_block (&block, &lse.post);
8319 else
8321 gfc_ref* remap;
8322 bool rank_remap;
8323 tree expr1_vptr = NULL_TREE;
8324 tree strlen_lhs;
8325 tree strlen_rhs = NULL_TREE;
8327 /* Array pointer. Find the last reference on the LHS and if it is an
8328 array section ref, we're dealing with bounds remapping. In this case,
8329 set it to AR_FULL so that gfc_conv_expr_descriptor does
8330 not see it and process the bounds remapping afterwards explicitly. */
8331 for (remap = expr1->ref; remap; remap = remap->next)
8332 if (!remap->next && remap->type == REF_ARRAY
8333 && remap->u.ar.type == AR_SECTION)
8334 break;
8335 rank_remap = (remap && remap->u.ar.end[0]);
8337 gfc_init_se (&lse, NULL);
8338 if (remap)
8339 lse.descriptor_only = 1;
8340 gfc_conv_expr_descriptor (&lse, expr1);
8341 strlen_lhs = lse.string_length;
8342 desc = lse.expr;
8344 if (expr2->expr_type == EXPR_NULL)
8346 /* Just set the data pointer to null. */
8347 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8349 else if (rank_remap)
8351 /* If we are rank-remapping, just get the RHS's descriptor and
8352 process this later on. */
8353 gfc_init_se (&rse, NULL);
8354 rse.direct_byref = 1;
8355 rse.byref_noassign = 1;
8357 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8359 gfc_conv_function_expr (&rse, expr2);
8361 if (expr1->ts.type != BT_CLASS)
8362 rse.expr = gfc_class_data_get (rse.expr);
8363 else
8365 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8366 expr2, &rse,
8367 NULL, NULL);
8368 gfc_add_block_to_block (&block, &rse.pre);
8369 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8370 gfc_add_modify (&lse.pre, tmp, rse.expr);
8372 gfc_add_modify (&lse.pre, expr1_vptr,
8373 fold_convert (TREE_TYPE (expr1_vptr),
8374 gfc_class_vptr_get (tmp)));
8375 rse.expr = gfc_class_data_get (tmp);
8378 else if (expr2->expr_type == EXPR_FUNCTION)
8380 tree bound[GFC_MAX_DIMENSIONS];
8381 int i;
8383 for (i = 0; i < expr2->rank; i++)
8384 bound[i] = NULL_TREE;
8385 tmp = gfc_typenode_for_spec (&expr2->ts);
8386 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8387 bound, bound, 0,
8388 GFC_ARRAY_POINTER_CONT, false);
8389 tmp = gfc_create_var (tmp, "ptrtemp");
8390 rse.descriptor_only = 0;
8391 rse.expr = tmp;
8392 rse.direct_byref = 1;
8393 gfc_conv_expr_descriptor (&rse, expr2);
8394 strlen_rhs = rse.string_length;
8395 rse.expr = tmp;
8397 else
8399 gfc_conv_expr_descriptor (&rse, expr2);
8400 strlen_rhs = rse.string_length;
8401 if (expr1->ts.type == BT_CLASS)
8402 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8403 expr2, &rse,
8404 NULL, NULL);
8407 else if (expr2->expr_type == EXPR_VARIABLE)
8409 /* Assign directly to the LHS's descriptor. */
8410 lse.descriptor_only = 0;
8411 lse.direct_byref = 1;
8412 gfc_conv_expr_descriptor (&lse, expr2);
8413 strlen_rhs = lse.string_length;
8415 /* If this is a subreference array pointer assignment, use the rhs
8416 descriptor element size for the lhs span. */
8417 if (expr1->symtree->n.sym->attr.subref_array_pointer)
8419 decl = expr1->symtree->n.sym->backend_decl;
8420 gfc_init_se (&rse, NULL);
8421 rse.descriptor_only = 1;
8422 gfc_conv_expr (&rse, expr2);
8423 if (expr1->ts.type == BT_CLASS)
8424 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8425 NULL, NULL);
8426 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
8427 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
8428 if (!INTEGER_CST_P (tmp))
8429 gfc_add_block_to_block (&lse.post, &rse.pre);
8430 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
8432 else if (expr1->ts.type == BT_CLASS)
8434 rse.expr = NULL_TREE;
8435 rse.string_length = NULL_TREE;
8436 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8437 NULL, NULL);
8440 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8442 gfc_init_se (&rse, NULL);
8443 rse.want_pointer = 1;
8444 gfc_conv_function_expr (&rse, expr2);
8445 if (expr1->ts.type != BT_CLASS)
8447 rse.expr = gfc_class_data_get (rse.expr);
8448 gfc_add_modify (&lse.pre, desc, rse.expr);
8450 else
8452 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8453 expr2, &rse, NULL,
8454 NULL);
8455 gfc_add_block_to_block (&block, &rse.pre);
8456 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8457 gfc_add_modify (&lse.pre, tmp, rse.expr);
8459 gfc_add_modify (&lse.pre, expr1_vptr,
8460 fold_convert (TREE_TYPE (expr1_vptr),
8461 gfc_class_vptr_get (tmp)));
8462 rse.expr = gfc_class_data_get (tmp);
8463 gfc_add_modify (&lse.pre, desc, rse.expr);
8466 else
8468 /* Assign to a temporary descriptor and then copy that
8469 temporary to the pointer. */
8470 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8471 lse.descriptor_only = 0;
8472 lse.expr = tmp;
8473 lse.direct_byref = 1;
8474 gfc_conv_expr_descriptor (&lse, expr2);
8475 strlen_rhs = lse.string_length;
8476 gfc_add_modify (&lse.pre, desc, tmp);
8479 gfc_add_block_to_block (&block, &lse.pre);
8480 if (rank_remap)
8481 gfc_add_block_to_block (&block, &rse.pre);
8483 /* If we do bounds remapping, update LHS descriptor accordingly. */
8484 if (remap)
8486 int dim;
8487 gcc_assert (remap->u.ar.dimen == expr1->rank);
8489 if (rank_remap)
8491 /* Do rank remapping. We already have the RHS's descriptor
8492 converted in rse and now have to build the correct LHS
8493 descriptor for it. */
8495 tree dtype, data;
8496 tree offs, stride;
8497 tree lbound, ubound;
8499 /* Set dtype. */
8500 dtype = gfc_conv_descriptor_dtype (desc);
8501 tmp = gfc_get_dtype (TREE_TYPE (desc));
8502 gfc_add_modify (&block, dtype, tmp);
8504 /* Copy data pointer. */
8505 data = gfc_conv_descriptor_data_get (rse.expr);
8506 gfc_conv_descriptor_data_set (&block, desc, data);
8508 /* Copy offset but adjust it such that it would correspond
8509 to a lbound of zero. */
8510 offs = gfc_conv_descriptor_offset_get (rse.expr);
8511 for (dim = 0; dim < expr2->rank; ++dim)
8513 stride = gfc_conv_descriptor_stride_get (rse.expr,
8514 gfc_rank_cst[dim]);
8515 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8516 gfc_rank_cst[dim]);
8517 tmp = fold_build2_loc (input_location, MULT_EXPR,
8518 gfc_array_index_type, stride, lbound);
8519 offs = fold_build2_loc (input_location, PLUS_EXPR,
8520 gfc_array_index_type, offs, tmp);
8522 gfc_conv_descriptor_offset_set (&block, desc, offs);
8524 /* Set the bounds as declared for the LHS and calculate strides as
8525 well as another offset update accordingly. */
8526 stride = gfc_conv_descriptor_stride_get (rse.expr,
8527 gfc_rank_cst[0]);
8528 for (dim = 0; dim < expr1->rank; ++dim)
8530 gfc_se lower_se;
8531 gfc_se upper_se;
8533 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8535 /* Convert declared bounds. */
8536 gfc_init_se (&lower_se, NULL);
8537 gfc_init_se (&upper_se, NULL);
8538 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8539 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8541 gfc_add_block_to_block (&block, &lower_se.pre);
8542 gfc_add_block_to_block (&block, &upper_se.pre);
8544 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8545 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8547 lbound = gfc_evaluate_now (lbound, &block);
8548 ubound = gfc_evaluate_now (ubound, &block);
8550 gfc_add_block_to_block (&block, &lower_se.post);
8551 gfc_add_block_to_block (&block, &upper_se.post);
8553 /* Set bounds in descriptor. */
8554 gfc_conv_descriptor_lbound_set (&block, desc,
8555 gfc_rank_cst[dim], lbound);
8556 gfc_conv_descriptor_ubound_set (&block, desc,
8557 gfc_rank_cst[dim], ubound);
8559 /* Set stride. */
8560 stride = gfc_evaluate_now (stride, &block);
8561 gfc_conv_descriptor_stride_set (&block, desc,
8562 gfc_rank_cst[dim], stride);
8564 /* Update offset. */
8565 offs = gfc_conv_descriptor_offset_get (desc);
8566 tmp = fold_build2_loc (input_location, MULT_EXPR,
8567 gfc_array_index_type, lbound, stride);
8568 offs = fold_build2_loc (input_location, MINUS_EXPR,
8569 gfc_array_index_type, offs, tmp);
8570 offs = gfc_evaluate_now (offs, &block);
8571 gfc_conv_descriptor_offset_set (&block, desc, offs);
8573 /* Update stride. */
8574 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8575 stride = fold_build2_loc (input_location, MULT_EXPR,
8576 gfc_array_index_type, stride, tmp);
8579 else
8581 /* Bounds remapping. Just shift the lower bounds. */
8583 gcc_assert (expr1->rank == expr2->rank);
8585 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8587 gfc_se lbound_se;
8589 gcc_assert (remap->u.ar.start[dim]);
8590 gcc_assert (!remap->u.ar.end[dim]);
8591 gfc_init_se (&lbound_se, NULL);
8592 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8594 gfc_add_block_to_block (&block, &lbound_se.pre);
8595 gfc_conv_shift_descriptor_lbound (&block, desc,
8596 dim, lbound_se.expr);
8597 gfc_add_block_to_block (&block, &lbound_se.post);
8602 /* Check string lengths if applicable. The check is only really added
8603 to the output code if -fbounds-check is enabled. */
8604 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8606 gcc_assert (expr2->ts.type == BT_CHARACTER);
8607 gcc_assert (strlen_lhs && strlen_rhs);
8608 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8609 strlen_lhs, strlen_rhs, &block);
8612 /* If rank remapping was done, check with -fcheck=bounds that
8613 the target is at least as large as the pointer. */
8614 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8616 tree lsize, rsize;
8617 tree fault;
8618 const char* msg;
8620 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8621 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8623 lsize = gfc_evaluate_now (lsize, &block);
8624 rsize = gfc_evaluate_now (rsize, &block);
8625 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8626 rsize, lsize);
8628 msg = _("Target of rank remapping is too small (%ld < %ld)");
8629 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8630 msg, rsize, lsize);
8633 gfc_add_block_to_block (&block, &lse.post);
8634 if (rank_remap)
8635 gfc_add_block_to_block (&block, &rse.post);
8638 return gfc_finish_block (&block);
8642 /* Makes sure se is suitable for passing as a function string parameter. */
8643 /* TODO: Need to check all callers of this function. It may be abused. */
8645 void
8646 gfc_conv_string_parameter (gfc_se * se)
8648 tree type;
8650 if (TREE_CODE (se->expr) == STRING_CST)
8652 type = TREE_TYPE (TREE_TYPE (se->expr));
8653 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8654 return;
8657 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
8659 if (TREE_CODE (se->expr) != INDIRECT_REF)
8661 type = TREE_TYPE (se->expr);
8662 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8664 else
8666 type = gfc_get_character_type_len (gfc_default_character_kind,
8667 se->string_length);
8668 type = build_pointer_type (type);
8669 se->expr = gfc_build_addr_expr (type, se->expr);
8673 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
8677 /* Generate code for assignment of scalar variables. Includes character
8678 strings and derived types with allocatable components.
8679 If you know that the LHS has no allocations, set dealloc to false.
8681 DEEP_COPY has no effect if the typespec TS is not a derived type with
8682 allocatable components. Otherwise, if it is set, an explicit copy of each
8683 allocatable component is made. This is necessary as a simple copy of the
8684 whole object would copy array descriptors as is, so that the lhs's
8685 allocatable components would point to the rhs's after the assignment.
8686 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8687 necessary if the rhs is a non-pointer function, as the allocatable components
8688 are not accessible by other means than the function's result after the
8689 function has returned. It is even more subtle when temporaries are involved,
8690 as the two following examples show:
8691 1. When we evaluate an array constructor, a temporary is created. Thus
8692 there is theoretically no alias possible. However, no deep copy is
8693 made for this temporary, so that if the constructor is made of one or
8694 more variable with allocatable components, those components still point
8695 to the variable's: DEEP_COPY should be set for the assignment from the
8696 temporary to the lhs in that case.
8697 2. When assigning a scalar to an array, we evaluate the scalar value out
8698 of the loop, store it into a temporary variable, and assign from that.
8699 In that case, deep copying when assigning to the temporary would be a
8700 waste of resources; however deep copies should happen when assigning from
8701 the temporary to each array element: again DEEP_COPY should be set for
8702 the assignment from the temporary to the lhs. */
8704 tree
8705 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
8706 bool deep_copy, bool dealloc, bool in_coarray)
8708 stmtblock_t block;
8709 tree tmp;
8710 tree cond;
8712 gfc_init_block (&block);
8714 if (ts.type == BT_CHARACTER)
8716 tree rlen = NULL;
8717 tree llen = NULL;
8719 if (lse->string_length != NULL_TREE)
8721 gfc_conv_string_parameter (lse);
8722 gfc_add_block_to_block (&block, &lse->pre);
8723 llen = lse->string_length;
8726 if (rse->string_length != NULL_TREE)
8728 gfc_conv_string_parameter (rse);
8729 gfc_add_block_to_block (&block, &rse->pre);
8730 rlen = rse->string_length;
8733 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
8734 rse->expr, ts.kind);
8736 else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp)
8738 tree tmp_var = NULL_TREE;
8739 cond = NULL_TREE;
8741 /* Are the rhs and the lhs the same? */
8742 if (deep_copy)
8744 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8745 gfc_build_addr_expr (NULL_TREE, lse->expr),
8746 gfc_build_addr_expr (NULL_TREE, rse->expr));
8747 cond = gfc_evaluate_now (cond, &lse->pre);
8750 /* Deallocate the lhs allocated components as long as it is not
8751 the same as the rhs. This must be done following the assignment
8752 to prevent deallocating data that could be used in the rhs
8753 expression. */
8754 if (dealloc)
8756 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
8757 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
8758 if (deep_copy)
8759 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8760 tmp);
8761 gfc_add_expr_to_block (&lse->post, tmp);
8764 gfc_add_block_to_block (&block, &rse->pre);
8765 gfc_add_block_to_block (&block, &lse->pre);
8767 gfc_add_modify (&block, lse->expr,
8768 fold_convert (TREE_TYPE (lse->expr), rse->expr));
8770 /* Restore pointer address of coarray components. */
8771 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
8773 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
8774 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8775 tmp);
8776 gfc_add_expr_to_block (&block, tmp);
8779 /* Do a deep copy if the rhs is a variable, if it is not the
8780 same as the lhs. */
8781 if (deep_copy)
8783 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8784 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
8785 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
8786 caf_mode);
8787 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8788 tmp);
8789 gfc_add_expr_to_block (&block, tmp);
8792 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
8794 gfc_add_block_to_block (&block, &lse->pre);
8795 gfc_add_block_to_block (&block, &rse->pre);
8796 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
8797 TREE_TYPE (lse->expr), rse->expr);
8798 gfc_add_modify (&block, lse->expr, tmp);
8800 else
8802 gfc_add_block_to_block (&block, &lse->pre);
8803 gfc_add_block_to_block (&block, &rse->pre);
8805 gfc_add_modify (&block, lse->expr,
8806 fold_convert (TREE_TYPE (lse->expr), rse->expr));
8809 gfc_add_block_to_block (&block, &lse->post);
8810 gfc_add_block_to_block (&block, &rse->post);
8812 return gfc_finish_block (&block);
8816 /* There are quite a lot of restrictions on the optimisation in using an
8817 array function assign without a temporary. */
8819 static bool
8820 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
8822 gfc_ref * ref;
8823 bool seen_array_ref;
8824 bool c = false;
8825 gfc_symbol *sym = expr1->symtree->n.sym;
8827 /* Play it safe with class functions assigned to a derived type. */
8828 if (gfc_is_alloc_class_array_function (expr2)
8829 && expr1->ts.type == BT_DERIVED)
8830 return true;
8832 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8833 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
8834 return true;
8836 /* Elemental functions are scalarized so that they don't need a
8837 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8838 they would need special treatment in gfc_trans_arrayfunc_assign. */
8839 if (expr2->value.function.esym != NULL
8840 && expr2->value.function.esym->attr.elemental)
8841 return true;
8843 /* Need a temporary if rhs is not FULL or a contiguous section. */
8844 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
8845 return true;
8847 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8848 if (gfc_ref_needs_temporary_p (expr1->ref))
8849 return true;
8851 /* Functions returning pointers or allocatables need temporaries. */
8852 c = expr2->value.function.esym
8853 ? (expr2->value.function.esym->attr.pointer
8854 || expr2->value.function.esym->attr.allocatable)
8855 : (expr2->symtree->n.sym->attr.pointer
8856 || expr2->symtree->n.sym->attr.allocatable);
8857 if (c)
8858 return true;
8860 /* Character array functions need temporaries unless the
8861 character lengths are the same. */
8862 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
8864 if (expr1->ts.u.cl->length == NULL
8865 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8866 return true;
8868 if (expr2->ts.u.cl->length == NULL
8869 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8870 return true;
8872 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
8873 expr2->ts.u.cl->length->value.integer) != 0)
8874 return true;
8877 /* Check that no LHS component references appear during an array
8878 reference. This is needed because we do not have the means to
8879 span any arbitrary stride with an array descriptor. This check
8880 is not needed for the rhs because the function result has to be
8881 a complete type. */
8882 seen_array_ref = false;
8883 for (ref = expr1->ref; ref; ref = ref->next)
8885 if (ref->type == REF_ARRAY)
8886 seen_array_ref= true;
8887 else if (ref->type == REF_COMPONENT && seen_array_ref)
8888 return true;
8891 /* Check for a dependency. */
8892 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
8893 expr2->value.function.esym,
8894 expr2->value.function.actual,
8895 NOT_ELEMENTAL))
8896 return true;
8898 /* If we have reached here with an intrinsic function, we do not
8899 need a temporary except in the particular case that reallocation
8900 on assignment is active and the lhs is allocatable and a target. */
8901 if (expr2->value.function.isym)
8902 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
8904 /* If the LHS is a dummy, we need a temporary if it is not
8905 INTENT(OUT). */
8906 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
8907 return true;
8909 /* If the lhs has been host_associated, is in common, a pointer or is
8910 a target and the function is not using a RESULT variable, aliasing
8911 can occur and a temporary is needed. */
8912 if ((sym->attr.host_assoc
8913 || sym->attr.in_common
8914 || sym->attr.pointer
8915 || sym->attr.cray_pointee
8916 || sym->attr.target)
8917 && expr2->symtree != NULL
8918 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
8919 return true;
8921 /* A PURE function can unconditionally be called without a temporary. */
8922 if (expr2->value.function.esym != NULL
8923 && expr2->value.function.esym->attr.pure)
8924 return false;
8926 /* Implicit_pure functions are those which could legally be declared
8927 to be PURE. */
8928 if (expr2->value.function.esym != NULL
8929 && expr2->value.function.esym->attr.implicit_pure)
8930 return false;
8932 if (!sym->attr.use_assoc
8933 && !sym->attr.in_common
8934 && !sym->attr.pointer
8935 && !sym->attr.target
8936 && !sym->attr.cray_pointee
8937 && expr2->value.function.esym)
8939 /* A temporary is not needed if the function is not contained and
8940 the variable is local or host associated and not a pointer or
8941 a target. */
8942 if (!expr2->value.function.esym->attr.contained)
8943 return false;
8945 /* A temporary is not needed if the lhs has never been host
8946 associated and the procedure is contained. */
8947 else if (!sym->attr.host_assoc)
8948 return false;
8950 /* A temporary is not needed if the variable is local and not
8951 a pointer, a target or a result. */
8952 if (sym->ns->parent
8953 && expr2->value.function.esym->ns == sym->ns->parent)
8954 return false;
8957 /* Default to temporary use. */
8958 return true;
8962 /* Provide the loop info so that the lhs descriptor can be built for
8963 reallocatable assignments from extrinsic function calls. */
8965 static void
8966 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
8967 gfc_loopinfo *loop)
8969 /* Signal that the function call should not be made by
8970 gfc_conv_loop_setup. */
8971 se->ss->is_alloc_lhs = 1;
8972 gfc_init_loopinfo (loop);
8973 gfc_add_ss_to_loop (loop, *ss);
8974 gfc_add_ss_to_loop (loop, se->ss);
8975 gfc_conv_ss_startstride (loop);
8976 gfc_conv_loop_setup (loop, where);
8977 gfc_copy_loopinfo_to_se (se, loop);
8978 gfc_add_block_to_block (&se->pre, &loop->pre);
8979 gfc_add_block_to_block (&se->pre, &loop->post);
8980 se->ss->is_alloc_lhs = 0;
8984 /* For assignment to a reallocatable lhs from intrinsic functions,
8985 replace the se.expr (ie. the result) with a temporary descriptor.
8986 Null the data field so that the library allocates space for the
8987 result. Free the data of the original descriptor after the function,
8988 in case it appears in an argument expression and transfer the
8989 result to the original descriptor. */
8991 static void
8992 fcncall_realloc_result (gfc_se *se, int rank)
8994 tree desc;
8995 tree res_desc;
8996 tree tmp;
8997 tree offset;
8998 tree zero_cond;
8999 int n;
9001 /* Use the allocation done by the library. Substitute the lhs
9002 descriptor with a copy, whose data field is nulled.*/
9003 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9004 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9005 desc = build_fold_indirect_ref_loc (input_location, desc);
9007 /* Unallocated, the descriptor does not have a dtype. */
9008 tmp = gfc_conv_descriptor_dtype (desc);
9009 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9011 res_desc = gfc_evaluate_now (desc, &se->pre);
9012 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9013 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9015 /* Free the lhs after the function call and copy the result data to
9016 the lhs descriptor. */
9017 tmp = gfc_conv_descriptor_data_get (desc);
9018 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9019 boolean_type_node, tmp,
9020 build_int_cst (TREE_TYPE (tmp), 0));
9021 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9022 tmp = gfc_call_free (tmp);
9023 gfc_add_expr_to_block (&se->post, tmp);
9025 tmp = gfc_conv_descriptor_data_get (res_desc);
9026 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9028 /* Check that the shapes are the same between lhs and expression. */
9029 for (n = 0 ; n < rank; n++)
9031 tree tmp1;
9032 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9033 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9034 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9035 gfc_array_index_type, tmp, tmp1);
9036 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9037 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9038 gfc_array_index_type, tmp, tmp1);
9039 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9040 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9041 gfc_array_index_type, tmp, tmp1);
9042 tmp = fold_build2_loc (input_location, NE_EXPR,
9043 boolean_type_node, tmp,
9044 gfc_index_zero_node);
9045 tmp = gfc_evaluate_now (tmp, &se->post);
9046 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9047 boolean_type_node, tmp,
9048 zero_cond);
9051 /* 'zero_cond' being true is equal to lhs not being allocated or the
9052 shapes being different. */
9053 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9055 /* Now reset the bounds returned from the function call to bounds based
9056 on the lhs lbounds, except where the lhs is not allocated or the shapes
9057 of 'variable and 'expr' are different. Set the offset accordingly. */
9058 offset = gfc_index_zero_node;
9059 for (n = 0 ; n < rank; n++)
9061 tree lbound;
9063 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9064 lbound = fold_build3_loc (input_location, COND_EXPR,
9065 gfc_array_index_type, zero_cond,
9066 gfc_index_one_node, lbound);
9067 lbound = gfc_evaluate_now (lbound, &se->post);
9069 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9070 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9071 gfc_array_index_type, tmp, lbound);
9072 gfc_conv_descriptor_lbound_set (&se->post, desc,
9073 gfc_rank_cst[n], lbound);
9074 gfc_conv_descriptor_ubound_set (&se->post, desc,
9075 gfc_rank_cst[n], tmp);
9077 /* Set stride and accumulate the offset. */
9078 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9079 gfc_conv_descriptor_stride_set (&se->post, desc,
9080 gfc_rank_cst[n], tmp);
9081 tmp = fold_build2_loc (input_location, MULT_EXPR,
9082 gfc_array_index_type, lbound, tmp);
9083 offset = fold_build2_loc (input_location, MINUS_EXPR,
9084 gfc_array_index_type, offset, tmp);
9085 offset = gfc_evaluate_now (offset, &se->post);
9088 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9093 /* Try to translate array(:) = func (...), where func is a transformational
9094 array function, without using a temporary. Returns NULL if this isn't the
9095 case. */
9097 static tree
9098 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9100 gfc_se se;
9101 gfc_ss *ss = NULL;
9102 gfc_component *comp = NULL;
9103 gfc_loopinfo loop;
9105 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9106 return NULL;
9108 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9109 functions. */
9110 comp = gfc_get_proc_ptr_comp (expr2);
9111 gcc_assert (expr2->value.function.isym
9112 || (comp && comp->attr.dimension)
9113 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9114 && expr2->value.function.esym->result->attr.dimension));
9116 gfc_init_se (&se, NULL);
9117 gfc_start_block (&se.pre);
9118 se.want_pointer = 1;
9120 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9122 if (expr1->ts.type == BT_DERIVED
9123 && expr1->ts.u.derived->attr.alloc_comp)
9125 tree tmp;
9126 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9127 expr1->rank);
9128 gfc_add_expr_to_block (&se.pre, tmp);
9131 se.direct_byref = 1;
9132 se.ss = gfc_walk_expr (expr2);
9133 gcc_assert (se.ss != gfc_ss_terminator);
9135 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9136 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9137 Clearly, this cannot be done for an allocatable function result, since
9138 the shape of the result is unknown and, in any case, the function must
9139 correctly take care of the reallocation internally. For intrinsic
9140 calls, the array data is freed and the library takes care of allocation.
9141 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9142 to the library. */
9143 if (flag_realloc_lhs
9144 && gfc_is_reallocatable_lhs (expr1)
9145 && !gfc_expr_attr (expr1).codimension
9146 && !gfc_is_coindexed (expr1)
9147 && !(expr2->value.function.esym
9148 && expr2->value.function.esym->result->attr.allocatable))
9150 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9152 if (!expr2->value.function.isym)
9154 ss = gfc_walk_expr (expr1);
9155 gcc_assert (ss != gfc_ss_terminator);
9157 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9158 ss->is_alloc_lhs = 1;
9160 else
9161 fcncall_realloc_result (&se, expr1->rank);
9164 gfc_conv_function_expr (&se, expr2);
9165 gfc_add_block_to_block (&se.pre, &se.post);
9167 if (ss)
9168 gfc_cleanup_loop (&loop);
9169 else
9170 gfc_free_ss_chain (se.ss);
9172 return gfc_finish_block (&se.pre);
9176 /* Try to efficiently translate array(:) = 0. Return NULL if this
9177 can't be done. */
9179 static tree
9180 gfc_trans_zero_assign (gfc_expr * expr)
9182 tree dest, len, type;
9183 tree tmp;
9184 gfc_symbol *sym;
9186 sym = expr->symtree->n.sym;
9187 dest = gfc_get_symbol_decl (sym);
9189 type = TREE_TYPE (dest);
9190 if (POINTER_TYPE_P (type))
9191 type = TREE_TYPE (type);
9192 if (!GFC_ARRAY_TYPE_P (type))
9193 return NULL_TREE;
9195 /* Determine the length of the array. */
9196 len = GFC_TYPE_ARRAY_SIZE (type);
9197 if (!len || TREE_CODE (len) != INTEGER_CST)
9198 return NULL_TREE;
9200 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9201 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9202 fold_convert (gfc_array_index_type, tmp));
9204 /* If we are zeroing a local array avoid taking its address by emitting
9205 a = {} instead. */
9206 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9207 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9208 dest, build_constructor (TREE_TYPE (dest),
9209 NULL));
9211 /* Convert arguments to the correct types. */
9212 dest = fold_convert (pvoid_type_node, dest);
9213 len = fold_convert (size_type_node, len);
9215 /* Construct call to __builtin_memset. */
9216 tmp = build_call_expr_loc (input_location,
9217 builtin_decl_explicit (BUILT_IN_MEMSET),
9218 3, dest, integer_zero_node, len);
9219 return fold_convert (void_type_node, tmp);
9223 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9224 that constructs the call to __builtin_memcpy. */
9226 tree
9227 gfc_build_memcpy_call (tree dst, tree src, tree len)
9229 tree tmp;
9231 /* Convert arguments to the correct types. */
9232 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9233 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9234 else
9235 dst = fold_convert (pvoid_type_node, dst);
9237 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9238 src = gfc_build_addr_expr (pvoid_type_node, src);
9239 else
9240 src = fold_convert (pvoid_type_node, src);
9242 len = fold_convert (size_type_node, len);
9244 /* Construct call to __builtin_memcpy. */
9245 tmp = build_call_expr_loc (input_location,
9246 builtin_decl_explicit (BUILT_IN_MEMCPY),
9247 3, dst, src, len);
9248 return fold_convert (void_type_node, tmp);
9252 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9253 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9254 source/rhs, both are gfc_full_array_ref_p which have been checked for
9255 dependencies. */
9257 static tree
9258 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9260 tree dst, dlen, dtype;
9261 tree src, slen, stype;
9262 tree tmp;
9264 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9265 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9267 dtype = TREE_TYPE (dst);
9268 if (POINTER_TYPE_P (dtype))
9269 dtype = TREE_TYPE (dtype);
9270 stype = TREE_TYPE (src);
9271 if (POINTER_TYPE_P (stype))
9272 stype = TREE_TYPE (stype);
9274 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9275 return NULL_TREE;
9277 /* Determine the lengths of the arrays. */
9278 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9279 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9280 return NULL_TREE;
9281 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9282 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9283 dlen, fold_convert (gfc_array_index_type, tmp));
9285 slen = GFC_TYPE_ARRAY_SIZE (stype);
9286 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9287 return NULL_TREE;
9288 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9289 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9290 slen, fold_convert (gfc_array_index_type, tmp));
9292 /* Sanity check that they are the same. This should always be
9293 the case, as we should already have checked for conformance. */
9294 if (!tree_int_cst_equal (slen, dlen))
9295 return NULL_TREE;
9297 return gfc_build_memcpy_call (dst, src, dlen);
9301 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9302 this can't be done. EXPR1 is the destination/lhs for which
9303 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9305 static tree
9306 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9308 unsigned HOST_WIDE_INT nelem;
9309 tree dst, dtype;
9310 tree src, stype;
9311 tree len;
9312 tree tmp;
9314 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9315 if (nelem == 0)
9316 return NULL_TREE;
9318 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9319 dtype = TREE_TYPE (dst);
9320 if (POINTER_TYPE_P (dtype))
9321 dtype = TREE_TYPE (dtype);
9322 if (!GFC_ARRAY_TYPE_P (dtype))
9323 return NULL_TREE;
9325 /* Determine the lengths of the array. */
9326 len = GFC_TYPE_ARRAY_SIZE (dtype);
9327 if (!len || TREE_CODE (len) != INTEGER_CST)
9328 return NULL_TREE;
9330 /* Confirm that the constructor is the same size. */
9331 if (compare_tree_int (len, nelem) != 0)
9332 return NULL_TREE;
9334 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9335 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9336 fold_convert (gfc_array_index_type, tmp));
9338 stype = gfc_typenode_for_spec (&expr2->ts);
9339 src = gfc_build_constant_array_constructor (expr2, stype);
9341 stype = TREE_TYPE (src);
9342 if (POINTER_TYPE_P (stype))
9343 stype = TREE_TYPE (stype);
9345 return gfc_build_memcpy_call (dst, src, len);
9349 /* Tells whether the expression is to be treated as a variable reference. */
9351 bool
9352 gfc_expr_is_variable (gfc_expr *expr)
9354 gfc_expr *arg;
9355 gfc_component *comp;
9356 gfc_symbol *func_ifc;
9358 if (expr->expr_type == EXPR_VARIABLE)
9359 return true;
9361 arg = gfc_get_noncopying_intrinsic_argument (expr);
9362 if (arg)
9364 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9365 return gfc_expr_is_variable (arg);
9368 /* A data-pointer-returning function should be considered as a variable
9369 too. */
9370 if (expr->expr_type == EXPR_FUNCTION
9371 && expr->ref == NULL)
9373 if (expr->value.function.isym != NULL)
9374 return false;
9376 if (expr->value.function.esym != NULL)
9378 func_ifc = expr->value.function.esym;
9379 goto found_ifc;
9381 else
9383 gcc_assert (expr->symtree);
9384 func_ifc = expr->symtree->n.sym;
9385 goto found_ifc;
9388 gcc_unreachable ();
9391 comp = gfc_get_proc_ptr_comp (expr);
9392 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9393 && comp)
9395 func_ifc = comp->ts.interface;
9396 goto found_ifc;
9399 if (expr->expr_type == EXPR_COMPCALL)
9401 gcc_assert (!expr->value.compcall.tbp->is_generic);
9402 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9403 goto found_ifc;
9406 return false;
9408 found_ifc:
9409 gcc_assert (func_ifc->attr.function
9410 && func_ifc->result != NULL);
9411 return func_ifc->result->attr.pointer;
9415 /* Is the lhs OK for automatic reallocation? */
9417 static bool
9418 is_scalar_reallocatable_lhs (gfc_expr *expr)
9420 gfc_ref * ref;
9422 /* An allocatable variable with no reference. */
9423 if (expr->symtree->n.sym->attr.allocatable
9424 && !expr->ref)
9425 return true;
9427 /* All that can be left are allocatable components. However, we do
9428 not check for allocatable components here because the expression
9429 could be an allocatable component of a pointer component. */
9430 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9431 && expr->symtree->n.sym->ts.type != BT_CLASS)
9432 return false;
9434 /* Find an allocatable component ref last. */
9435 for (ref = expr->ref; ref; ref = ref->next)
9436 if (ref->type == REF_COMPONENT
9437 && !ref->next
9438 && ref->u.c.component->attr.allocatable)
9439 return true;
9441 return false;
9445 /* Allocate or reallocate scalar lhs, as necessary. */
9447 static void
9448 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9449 tree string_length,
9450 gfc_expr *expr1,
9451 gfc_expr *expr2)
9454 tree cond;
9455 tree tmp;
9456 tree size;
9457 tree size_in_bytes;
9458 tree jump_label1;
9459 tree jump_label2;
9460 gfc_se lse;
9461 gfc_ref *ref;
9463 if (!expr1 || expr1->rank)
9464 return;
9466 if (!expr2 || expr2->rank)
9467 return;
9469 for (ref = expr1->ref; ref; ref = ref->next)
9470 if (ref->type == REF_SUBSTRING)
9471 return;
9473 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9475 /* Since this is a scalar lhs, we can afford to do this. That is,
9476 there is no risk of side effects being repeated. */
9477 gfc_init_se (&lse, NULL);
9478 lse.want_pointer = 1;
9479 gfc_conv_expr (&lse, expr1);
9481 jump_label1 = gfc_build_label_decl (NULL_TREE);
9482 jump_label2 = gfc_build_label_decl (NULL_TREE);
9484 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9485 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9486 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
9487 lse.expr, tmp);
9488 tmp = build3_v (COND_EXPR, cond,
9489 build1_v (GOTO_EXPR, jump_label1),
9490 build_empty_stmt (input_location));
9491 gfc_add_expr_to_block (block, tmp);
9493 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9495 /* Use the rhs string length and the lhs element size. */
9496 size = string_length;
9497 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9498 tmp = TYPE_SIZE_UNIT (tmp);
9499 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9500 TREE_TYPE (tmp), tmp,
9501 fold_convert (TREE_TYPE (tmp), size));
9503 else
9505 /* Otherwise use the length in bytes of the rhs. */
9506 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9507 size_in_bytes = size;
9510 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9511 size_in_bytes, size_one_node);
9513 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9515 tree caf_decl, token;
9516 gfc_se caf_se;
9517 symbol_attribute attr;
9519 gfc_clear_attr (&attr);
9520 gfc_init_se (&caf_se, NULL);
9522 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9523 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9524 NULL);
9525 gfc_add_block_to_block (block, &caf_se.pre);
9526 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9527 gfc_build_addr_expr (NULL_TREE, token),
9528 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9529 expr1, 1);
9531 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9533 tmp = build_call_expr_loc (input_location,
9534 builtin_decl_explicit (BUILT_IN_CALLOC),
9535 2, build_one_cst (size_type_node),
9536 size_in_bytes);
9537 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9538 gfc_add_modify (block, lse.expr, tmp);
9540 else
9542 tmp = build_call_expr_loc (input_location,
9543 builtin_decl_explicit (BUILT_IN_MALLOC),
9544 1, size_in_bytes);
9545 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9546 gfc_add_modify (block, lse.expr, tmp);
9549 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9551 /* Deferred characters need checking for lhs and rhs string
9552 length. Other deferred parameter variables will have to
9553 come here too. */
9554 tmp = build1_v (GOTO_EXPR, jump_label2);
9555 gfc_add_expr_to_block (block, tmp);
9557 tmp = build1_v (LABEL_EXPR, jump_label1);
9558 gfc_add_expr_to_block (block, tmp);
9560 /* For a deferred length character, reallocate if lengths of lhs and
9561 rhs are different. */
9562 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9564 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9565 lse.string_length, size);
9566 /* Jump past the realloc if the lengths are the same. */
9567 tmp = build3_v (COND_EXPR, cond,
9568 build1_v (GOTO_EXPR, jump_label2),
9569 build_empty_stmt (input_location));
9570 gfc_add_expr_to_block (block, tmp);
9571 tmp = build_call_expr_loc (input_location,
9572 builtin_decl_explicit (BUILT_IN_REALLOC),
9573 2, fold_convert (pvoid_type_node, lse.expr),
9574 size_in_bytes);
9575 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9576 gfc_add_modify (block, lse.expr, tmp);
9577 tmp = build1_v (LABEL_EXPR, jump_label2);
9578 gfc_add_expr_to_block (block, tmp);
9580 /* Update the lhs character length. */
9581 size = string_length;
9582 gfc_add_modify (block, lse.string_length, size);
9586 /* Check for assignments of the type
9588 a = a + 4
9590 to make sure we do not check for reallocation unneccessarily. */
9593 static bool
9594 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9596 gfc_actual_arglist *a;
9597 gfc_expr *e1, *e2;
9599 switch (expr2->expr_type)
9601 case EXPR_VARIABLE:
9602 return gfc_dep_compare_expr (expr1, expr2) == 0;
9604 case EXPR_FUNCTION:
9605 if (expr2->value.function.esym
9606 && expr2->value.function.esym->attr.elemental)
9608 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9610 e1 = a->expr;
9611 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9612 return false;
9614 return true;
9616 else if (expr2->value.function.isym
9617 && expr2->value.function.isym->elemental)
9619 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9621 e1 = a->expr;
9622 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9623 return false;
9625 return true;
9628 break;
9630 case EXPR_OP:
9631 switch (expr2->value.op.op)
9633 case INTRINSIC_NOT:
9634 case INTRINSIC_UPLUS:
9635 case INTRINSIC_UMINUS:
9636 case INTRINSIC_PARENTHESES:
9637 return is_runtime_conformable (expr1, expr2->value.op.op1);
9639 case INTRINSIC_PLUS:
9640 case INTRINSIC_MINUS:
9641 case INTRINSIC_TIMES:
9642 case INTRINSIC_DIVIDE:
9643 case INTRINSIC_POWER:
9644 case INTRINSIC_AND:
9645 case INTRINSIC_OR:
9646 case INTRINSIC_EQV:
9647 case INTRINSIC_NEQV:
9648 case INTRINSIC_EQ:
9649 case INTRINSIC_NE:
9650 case INTRINSIC_GT:
9651 case INTRINSIC_GE:
9652 case INTRINSIC_LT:
9653 case INTRINSIC_LE:
9654 case INTRINSIC_EQ_OS:
9655 case INTRINSIC_NE_OS:
9656 case INTRINSIC_GT_OS:
9657 case INTRINSIC_GE_OS:
9658 case INTRINSIC_LT_OS:
9659 case INTRINSIC_LE_OS:
9661 e1 = expr2->value.op.op1;
9662 e2 = expr2->value.op.op2;
9664 if (e1->rank == 0 && e2->rank > 0)
9665 return is_runtime_conformable (expr1, e2);
9666 else if (e1->rank > 0 && e2->rank == 0)
9667 return is_runtime_conformable (expr1, e1);
9668 else if (e1->rank > 0 && e2->rank > 0)
9669 return is_runtime_conformable (expr1, e1)
9670 && is_runtime_conformable (expr1, e2);
9671 break;
9673 default:
9674 break;
9678 break;
9680 default:
9681 break;
9683 return false;
9687 static tree
9688 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
9689 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
9690 bool class_realloc)
9692 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
9693 vec<tree, va_gc> *args = NULL;
9695 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
9696 &from_len);
9698 /* Generate allocation of the lhs. */
9699 if (class_realloc)
9701 stmtblock_t alloc;
9702 tree class_han;
9704 tmp = gfc_vptr_size_get (vptr);
9705 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9706 ? gfc_class_data_get (lse->expr) : lse->expr;
9707 gfc_init_block (&alloc);
9708 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
9709 tmp = fold_build2_loc (input_location, EQ_EXPR,
9710 boolean_type_node, class_han,
9711 build_int_cst (prvoid_type_node, 0));
9712 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
9713 gfc_unlikely (tmp,
9714 PRED_FORTRAN_FAIL_ALLOC),
9715 gfc_finish_block (&alloc),
9716 build_empty_stmt (input_location));
9717 gfc_add_expr_to_block (&lse->pre, tmp);
9720 fcn = gfc_vptr_copy_get (vptr);
9722 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
9723 ? gfc_class_data_get (rse->expr) : rse->expr;
9724 if (use_vptr_copy)
9726 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9727 || INDIRECT_REF_P (tmp)
9728 || (rhs->ts.type == BT_DERIVED
9729 && rhs->ts.u.derived->attr.unlimited_polymorphic
9730 && !rhs->ts.u.derived->attr.pointer
9731 && !rhs->ts.u.derived->attr.allocatable)
9732 || (UNLIMITED_POLY (rhs)
9733 && !CLASS_DATA (rhs)->attr.pointer
9734 && !CLASS_DATA (rhs)->attr.allocatable))
9735 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9736 else
9737 vec_safe_push (args, tmp);
9738 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9739 ? gfc_class_data_get (lse->expr) : lse->expr;
9740 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9741 || INDIRECT_REF_P (tmp)
9742 || (lhs->ts.type == BT_DERIVED
9743 && lhs->ts.u.derived->attr.unlimited_polymorphic
9744 && !lhs->ts.u.derived->attr.pointer
9745 && !lhs->ts.u.derived->attr.allocatable)
9746 || (UNLIMITED_POLY (lhs)
9747 && !CLASS_DATA (lhs)->attr.pointer
9748 && !CLASS_DATA (lhs)->attr.allocatable))
9749 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9750 else
9751 vec_safe_push (args, tmp);
9753 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
9755 if (to_len != NULL_TREE && !integer_zerop (from_len))
9757 tree extcopy;
9758 vec_safe_push (args, from_len);
9759 vec_safe_push (args, to_len);
9760 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
9762 tmp = fold_build2_loc (input_location, GT_EXPR,
9763 boolean_type_node, from_len,
9764 integer_zero_node);
9765 return fold_build3_loc (input_location, COND_EXPR,
9766 void_type_node, tmp,
9767 extcopy, stdcopy);
9769 else
9770 return stdcopy;
9772 else
9774 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9775 ? gfc_class_data_get (lse->expr) : lse->expr;
9776 stmtblock_t tblock;
9777 gfc_init_block (&tblock);
9778 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
9779 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
9780 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
9781 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
9782 /* When coming from a ptr_copy lhs and rhs are swapped. */
9783 gfc_add_modify_loc (input_location, &tblock, rhst,
9784 fold_convert (TREE_TYPE (rhst), tmp));
9785 return gfc_finish_block (&tblock);
9789 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9790 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9791 init_flag indicates initialization expressions and dealloc that no
9792 deallocate prior assignment is needed (if in doubt, set true).
9793 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9794 routine instead of a pointer assignment. Alias resolution is only done,
9795 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9796 where it is known, that newly allocated memory on the lhs can never be
9797 an alias of the rhs. */
9799 static tree
9800 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
9801 bool dealloc, bool use_vptr_copy, bool may_alias)
9803 gfc_se lse;
9804 gfc_se rse;
9805 gfc_ss *lss;
9806 gfc_ss *lss_section;
9807 gfc_ss *rss;
9808 gfc_loopinfo loop;
9809 tree tmp;
9810 stmtblock_t block;
9811 stmtblock_t body;
9812 bool l_is_temp;
9813 bool scalar_to_array;
9814 tree string_length;
9815 int n;
9816 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
9817 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
9818 bool is_poly_assign;
9820 /* Assignment of the form lhs = rhs. */
9821 gfc_start_block (&block);
9823 gfc_init_se (&lse, NULL);
9824 gfc_init_se (&rse, NULL);
9826 /* Walk the lhs. */
9827 lss = gfc_walk_expr (expr1);
9828 if (gfc_is_reallocatable_lhs (expr1)
9829 && !(expr2->expr_type == EXPR_FUNCTION
9830 && expr2->value.function.isym != NULL))
9831 lss->is_alloc_lhs = 1;
9832 rss = NULL;
9834 if ((expr1->ts.type == BT_DERIVED)
9835 && (gfc_is_alloc_class_array_function (expr2)
9836 || gfc_is_alloc_class_scalar_function (expr2)))
9837 expr2->must_finalize = 1;
9839 /* Checking whether a class assignment is desired is quite complicated and
9840 needed at two locations, so do it once only before the information is
9841 needed. */
9842 lhs_attr = gfc_expr_attr (expr1);
9843 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
9844 || (lhs_attr.allocatable && !lhs_attr.dimension))
9845 && (expr1->ts.type == BT_CLASS
9846 || gfc_is_class_array_ref (expr1, NULL)
9847 || gfc_is_class_scalar_expr (expr1)
9848 || gfc_is_class_array_ref (expr2, NULL)
9849 || gfc_is_class_scalar_expr (expr2));
9852 /* Only analyze the expressions for coarray properties, when in coarray-lib
9853 mode. */
9854 if (flag_coarray == GFC_FCOARRAY_LIB)
9856 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
9857 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
9860 if (lss != gfc_ss_terminator)
9862 /* The assignment needs scalarization. */
9863 lss_section = lss;
9865 /* Find a non-scalar SS from the lhs. */
9866 while (lss_section != gfc_ss_terminator
9867 && lss_section->info->type != GFC_SS_SECTION)
9868 lss_section = lss_section->next;
9870 gcc_assert (lss_section != gfc_ss_terminator);
9872 /* Initialize the scalarizer. */
9873 gfc_init_loopinfo (&loop);
9875 /* Walk the rhs. */
9876 rss = gfc_walk_expr (expr2);
9877 if (rss == gfc_ss_terminator)
9878 /* The rhs is scalar. Add a ss for the expression. */
9879 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
9880 /* When doing a class assign, then the handle to the rhs needs to be a
9881 pointer to allow for polymorphism. */
9882 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
9883 rss->info->type = GFC_SS_REFERENCE;
9885 /* Associate the SS with the loop. */
9886 gfc_add_ss_to_loop (&loop, lss);
9887 gfc_add_ss_to_loop (&loop, rss);
9889 /* Calculate the bounds of the scalarization. */
9890 gfc_conv_ss_startstride (&loop);
9891 /* Enable loop reversal. */
9892 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
9893 loop.reverse[n] = GFC_ENABLE_REVERSE;
9894 /* Resolve any data dependencies in the statement. */
9895 if (may_alias)
9896 gfc_conv_resolve_dependencies (&loop, lss, rss);
9897 /* Setup the scalarizing loops. */
9898 gfc_conv_loop_setup (&loop, &expr2->where);
9900 /* Setup the gfc_se structures. */
9901 gfc_copy_loopinfo_to_se (&lse, &loop);
9902 gfc_copy_loopinfo_to_se (&rse, &loop);
9904 rse.ss = rss;
9905 gfc_mark_ss_chain_used (rss, 1);
9906 if (loop.temp_ss == NULL)
9908 lse.ss = lss;
9909 gfc_mark_ss_chain_used (lss, 1);
9911 else
9913 lse.ss = loop.temp_ss;
9914 gfc_mark_ss_chain_used (lss, 3);
9915 gfc_mark_ss_chain_used (loop.temp_ss, 3);
9918 /* Allow the scalarizer to workshare array assignments. */
9919 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
9920 == OMPWS_WORKSHARE_FLAG
9921 && loop.temp_ss == NULL)
9923 maybe_workshare = true;
9924 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
9927 /* Start the scalarized loop body. */
9928 gfc_start_scalarized_body (&loop, &body);
9930 else
9931 gfc_init_block (&body);
9933 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
9935 /* Translate the expression. */
9936 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
9937 && lhs_caf_attr.codimension;
9938 gfc_conv_expr (&rse, expr2);
9940 /* Deal with the case of a scalar class function assigned to a derived type. */
9941 if (gfc_is_alloc_class_scalar_function (expr2)
9942 && expr1->ts.type == BT_DERIVED)
9944 rse.expr = gfc_class_data_get (rse.expr);
9945 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
9948 /* Stabilize a string length for temporaries. */
9949 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
9950 && !(VAR_P (rse.string_length)
9951 || TREE_CODE (rse.string_length) == PARM_DECL
9952 || TREE_CODE (rse.string_length) == INDIRECT_REF))
9953 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
9954 else if (expr2->ts.type == BT_CHARACTER)
9955 string_length = rse.string_length;
9956 else
9957 string_length = NULL_TREE;
9959 if (l_is_temp)
9961 gfc_conv_tmp_array_ref (&lse);
9962 if (expr2->ts.type == BT_CHARACTER)
9963 lse.string_length = string_length;
9965 else
9967 gfc_conv_expr (&lse, expr1);
9968 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
9969 && !init_flag
9970 && gfc_expr_attr (expr1).allocatable
9971 && expr1->rank
9972 && !expr2->rank)
9974 tree cond;
9975 const char* msg;
9977 tmp = INDIRECT_REF_P (lse.expr)
9978 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
9980 /* We should only get array references here. */
9981 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
9982 || TREE_CODE (tmp) == ARRAY_REF);
9984 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
9985 or the array itself(ARRAY_REF). */
9986 tmp = TREE_OPERAND (tmp, 0);
9988 /* Provide the address of the array. */
9989 if (TREE_CODE (lse.expr) == ARRAY_REF)
9990 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
9992 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9993 tmp, build_int_cst (TREE_TYPE (tmp), 0));
9994 msg = _("Assignment of scalar to unallocated array");
9995 gfc_trans_runtime_check (true, false, cond, &loop.pre,
9996 &expr1->where, msg);
10000 /* Assignments of scalar derived types with allocatable components
10001 to arrays must be done with a deep copy and the rhs temporary
10002 must have its components deallocated afterwards. */
10003 scalar_to_array = (expr2->ts.type == BT_DERIVED
10004 && expr2->ts.u.derived->attr.alloc_comp
10005 && !gfc_expr_is_variable (expr2)
10006 && expr1->rank && !expr2->rank);
10007 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10008 && expr1->rank
10009 && expr1->ts.u.derived->attr.alloc_comp
10010 && gfc_is_alloc_class_scalar_function (expr2));
10011 if (scalar_to_array && dealloc)
10013 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10014 gfc_prepend_expr_to_block (&loop.post, tmp);
10017 /* When assigning a character function result to a deferred-length variable,
10018 the function call must happen before the (re)allocation of the lhs -
10019 otherwise the character length of the result is not known.
10020 NOTE: This relies on having the exact dependence of the length type
10021 parameter available to the caller; gfortran saves it in the .mod files.
10022 NOTE ALSO: The concatenation operation generates a temporary pointer,
10023 whose allocation must go to the innermost loop. */
10024 if (flag_realloc_lhs
10025 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10026 && !(lss != gfc_ss_terminator
10027 && expr2->expr_type == EXPR_OP
10028 && expr2->value.op.op == INTRINSIC_CONCAT))
10029 gfc_add_block_to_block (&block, &rse.pre);
10031 /* Nullify the allocatable components corresponding to those of the lhs
10032 derived type, so that the finalization of the function result does not
10033 affect the lhs of the assignment. Prepend is used to ensure that the
10034 nullification occurs before the call to the finalizer. In the case of
10035 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10036 as part of the deep copy. */
10037 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10038 && (gfc_is_alloc_class_array_function (expr2)
10039 || gfc_is_alloc_class_scalar_function (expr2)))
10041 tmp = rse.expr;
10042 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10043 gfc_prepend_expr_to_block (&rse.post, tmp);
10044 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10045 gfc_add_block_to_block (&loop.post, &rse.post);
10048 if (is_poly_assign)
10049 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10050 use_vptr_copy || (lhs_attr.allocatable
10051 && !lhs_attr.dimension),
10052 flag_realloc_lhs && !lhs_attr.pointer);
10053 else if (flag_coarray == GFC_FCOARRAY_LIB
10054 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10055 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10056 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10058 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10059 allocatable component, because those need to be accessed via the
10060 caf-runtime. No need to check for coindexes here, because resolve
10061 has rewritten those already. */
10062 gfc_code code;
10063 gfc_actual_arglist a1, a2;
10064 /* Clear the structures to prevent accessing garbage. */
10065 memset (&code, '\0', sizeof (gfc_code));
10066 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10067 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10068 a1.expr = expr1;
10069 a1.next = &a2;
10070 a2.expr = expr2;
10071 a2.next = NULL;
10072 code.ext.actual = &a1;
10073 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10074 tmp = gfc_conv_intrinsic_subroutine (&code);
10076 else
10077 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10078 gfc_expr_is_variable (expr2)
10079 || scalar_to_array
10080 || expr2->expr_type == EXPR_ARRAY,
10081 !(l_is_temp || init_flag) && dealloc,
10082 expr1->symtree->n.sym->attr.codimension);
10083 /* Add the pre blocks to the body. */
10084 gfc_add_block_to_block (&body, &rse.pre);
10085 gfc_add_block_to_block (&body, &lse.pre);
10086 gfc_add_expr_to_block (&body, tmp);
10087 /* Add the post blocks to the body. */
10088 gfc_add_block_to_block (&body, &rse.post);
10089 gfc_add_block_to_block (&body, &lse.post);
10091 if (lss == gfc_ss_terminator)
10093 /* F2003: Add the code for reallocation on assignment. */
10094 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10095 && !is_poly_assign)
10096 alloc_scalar_allocatable_for_assignment (&block, string_length,
10097 expr1, expr2);
10099 /* Use the scalar assignment as is. */
10100 gfc_add_block_to_block (&block, &body);
10102 else
10104 gcc_assert (lse.ss == gfc_ss_terminator
10105 && rse.ss == gfc_ss_terminator);
10107 if (l_is_temp)
10109 gfc_trans_scalarized_loop_boundary (&loop, &body);
10111 /* We need to copy the temporary to the actual lhs. */
10112 gfc_init_se (&lse, NULL);
10113 gfc_init_se (&rse, NULL);
10114 gfc_copy_loopinfo_to_se (&lse, &loop);
10115 gfc_copy_loopinfo_to_se (&rse, &loop);
10117 rse.ss = loop.temp_ss;
10118 lse.ss = lss;
10120 gfc_conv_tmp_array_ref (&rse);
10121 gfc_conv_expr (&lse, expr1);
10123 gcc_assert (lse.ss == gfc_ss_terminator
10124 && rse.ss == gfc_ss_terminator);
10126 if (expr2->ts.type == BT_CHARACTER)
10127 rse.string_length = string_length;
10129 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10130 false, dealloc);
10131 gfc_add_expr_to_block (&body, tmp);
10134 /* F2003: Allocate or reallocate lhs of allocatable array. */
10135 if (flag_realloc_lhs
10136 && gfc_is_reallocatable_lhs (expr1)
10137 && expr2->rank
10138 && !is_runtime_conformable (expr1, expr2))
10140 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10141 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10142 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10143 if (tmp != NULL_TREE)
10144 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10147 if (maybe_workshare)
10148 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10150 /* Generate the copying loops. */
10151 gfc_trans_scalarizing_loops (&loop, &body);
10153 /* Wrap the whole thing up. */
10154 gfc_add_block_to_block (&block, &loop.pre);
10155 gfc_add_block_to_block (&block, &loop.post);
10157 gfc_cleanup_loop (&loop);
10160 return gfc_finish_block (&block);
10164 /* Check whether EXPR is a copyable array. */
10166 static bool
10167 copyable_array_p (gfc_expr * expr)
10169 if (expr->expr_type != EXPR_VARIABLE)
10170 return false;
10172 /* First check it's an array. */
10173 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10174 return false;
10176 if (!gfc_full_array_ref_p (expr->ref, NULL))
10177 return false;
10179 /* Next check that it's of a simple enough type. */
10180 switch (expr->ts.type)
10182 case BT_INTEGER:
10183 case BT_REAL:
10184 case BT_COMPLEX:
10185 case BT_LOGICAL:
10186 return true;
10188 case BT_CHARACTER:
10189 return false;
10191 case_bt_struct:
10192 return !expr->ts.u.derived->attr.alloc_comp;
10194 default:
10195 break;
10198 return false;
10201 /* Translate an assignment. */
10203 tree
10204 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10205 bool dealloc, bool use_vptr_copy, bool may_alias)
10207 tree tmp;
10209 /* Special case a single function returning an array. */
10210 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10212 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10213 if (tmp)
10214 return tmp;
10217 /* Special case assigning an array to zero. */
10218 if (copyable_array_p (expr1)
10219 && is_zero_initializer_p (expr2))
10221 tmp = gfc_trans_zero_assign (expr1);
10222 if (tmp)
10223 return tmp;
10226 /* Special case copying one array to another. */
10227 if (copyable_array_p (expr1)
10228 && copyable_array_p (expr2)
10229 && gfc_compare_types (&expr1->ts, &expr2->ts)
10230 && !gfc_check_dependency (expr1, expr2, 0))
10232 tmp = gfc_trans_array_copy (expr1, expr2);
10233 if (tmp)
10234 return tmp;
10237 /* Special case initializing an array from a constant array constructor. */
10238 if (copyable_array_p (expr1)
10239 && expr2->expr_type == EXPR_ARRAY
10240 && gfc_compare_types (&expr1->ts, &expr2->ts))
10242 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10243 if (tmp)
10244 return tmp;
10247 /* Fallback to the scalarizer to generate explicit loops. */
10248 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10249 use_vptr_copy, may_alias);
10252 tree
10253 gfc_trans_init_assign (gfc_code * code)
10255 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10258 tree
10259 gfc_trans_assign (gfc_code * code)
10261 return gfc_trans_assignment (code->expr1, code->expr2, false, true);