2018-05-27 Steven G. Kargl <kargl@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-expr.c
blob8bf550445cc19739804e20314b0570b4bf142911
1 /* Expression translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
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, etype;
71 type = get_scalar_to_descriptor_type (scalar, attr);
72 etype = TREE_TYPE (scalar);
73 desc = gfc_create_var (type, "desc");
74 DECL_ARTIFICIAL (desc) = 1;
76 if (CONSTANT_CLASS_P (scalar))
78 tree tmp;
79 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
80 gfc_add_modify (&se->pre, tmp, scalar);
81 scalar = tmp;
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
84 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
85 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
86 etype = TREE_TYPE (etype);
87 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
88 gfc_get_dtype_rank_type (0, etype));
89 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
94 gfc_add_modify (&se->post, scalar,
95 fold_convert (TREE_TYPE (scalar),
96 gfc_conv_descriptor_data_get (desc)));
97 return desc;
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
104 tree
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
107 gfc_symbol *sym = expr->symtree->n.sym;
108 bool is_coarray = sym->attr.codimension;
109 gfc_expr *caf_expr = gfc_copy_expr (expr);
110 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
112 while (ref)
114 if (ref->type == REF_COMPONENT
115 && (ref->u.c.component->attr.allocatable
116 || ref->u.c.component->attr.pointer)
117 && (is_coarray || ref->u.c.component->attr.codimension))
118 last_caf_ref = ref;
119 ref = ref->next;
122 if (last_caf_ref == NULL)
123 return NULL_TREE;
125 tree comp = last_caf_ref->u.c.component->caf_token, caf;
126 gfc_se se;
127 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
128 if (comp == NULL_TREE && comp_ref)
129 return NULL_TREE;
130 gfc_init_se (&se, outerse);
131 gfc_free_ref_list (last_caf_ref->next);
132 last_caf_ref->next = NULL;
133 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
134 se.want_pointer = comp_ref;
135 gfc_conv_expr (&se, caf_expr);
136 gfc_add_block_to_block (&outerse->pre, &se.pre);
138 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
139 se.expr = TREE_OPERAND (se.expr, 0);
140 gfc_free_expr (caf_expr);
142 if (comp_ref)
143 caf = fold_build3_loc (input_location, COMPONENT_REF,
144 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
145 else
146 caf = gfc_conv_descriptor_token (se.expr);
147 return gfc_build_addr_expr (NULL_TREE, caf);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
167 tree
168 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
170 tree tmp;
171 tree field;
172 vec<constructor_elt, va_gc> *init = NULL;
174 field = TYPE_FIELDS (TREE_TYPE (decl));
175 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
178 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
179 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
181 return build_constructor (TREE_TYPE (decl), init);
185 tree
186 gfc_class_data_get (tree decl)
188 tree data;
189 if (POINTER_TYPE_P (TREE_TYPE (decl)))
190 decl = build_fold_indirect_ref_loc (input_location, decl);
191 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
192 CLASS_DATA_FIELD);
193 return fold_build3_loc (input_location, COMPONENT_REF,
194 TREE_TYPE (data), decl, data,
195 NULL_TREE);
199 tree
200 gfc_class_vptr_get (tree decl)
202 tree vptr;
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl))
207 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
208 if (POINTER_TYPE_P (TREE_TYPE (decl)))
209 decl = build_fold_indirect_ref_loc (input_location, decl);
210 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
211 CLASS_VPTR_FIELD);
212 return fold_build3_loc (input_location, COMPONENT_REF,
213 TREE_TYPE (vptr), decl, vptr,
214 NULL_TREE);
218 tree
219 gfc_class_len_get (tree decl)
221 tree len;
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl))
226 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
227 if (POINTER_TYPE_P (TREE_TYPE (decl)))
228 decl = build_fold_indirect_ref_loc (input_location, decl);
229 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
230 CLASS_LEN_FIELD);
231 return fold_build3_loc (input_location, COMPONENT_REF,
232 TREE_TYPE (len), decl, len,
233 NULL_TREE);
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
240 tree
241 gfc_class_len_or_zero_get (tree decl)
243 tree len;
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl))
248 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
249 if (POINTER_TYPE_P (TREE_TYPE (decl)))
250 decl = build_fold_indirect_ref_loc (input_location, decl);
251 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
252 CLASS_LEN_FIELD);
253 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (len), decl, len,
255 NULL_TREE)
256 : build_zero_cst (gfc_charlen_type_node);
260 /* Get the specified FIELD from the VPTR. */
262 static tree
263 vptr_field_get (tree vptr, int fieldno)
265 tree field;
266 vptr = build_fold_indirect_ref_loc (input_location, vptr);
267 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
268 fieldno);
269 field = fold_build3_loc (input_location, COMPONENT_REF,
270 TREE_TYPE (field), vptr, field,
271 NULL_TREE);
272 gcc_assert (field);
273 return field;
277 /* Get the field from the class' vptr. */
279 static tree
280 class_vtab_field_get (tree decl, int fieldno)
282 tree vptr;
283 vptr = gfc_class_vptr_get (decl);
284 return vptr_field_get (vptr, fieldno);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
289 unison. */
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
296 tree \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
303 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
304 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
305 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
306 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
307 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
313 tree
314 gfc_class_vtab_size_get (tree cl)
316 tree size;
317 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
318 /* Always return size as an array index type. */
319 size = fold_convert (gfc_array_index_type, size);
320 gcc_assert (size);
321 return size;
324 tree
325 gfc_vptr_size_get (tree vptr)
327 tree size;
328 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
329 /* Always return size as an array index type. */
330 size = fold_convert (gfc_array_index_type, size);
331 gcc_assert (size);
332 return size;
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
354 gfc_expr *
355 gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
357 gfc_expr *base_expr;
358 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
360 /* Find the last class reference. */
361 class_ref = NULL;
362 array_ref = NULL;
363 for (ref = e->ref; ref; ref = ref->next)
365 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
366 array_ref = ref;
368 if (ref->type == REF_COMPONENT
369 && ref->u.c.component->ts.type == BT_CLASS)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
376 return NULL;
377 class_ref = ref;
380 if (ref->next == NULL)
381 break;
384 /* Remove and store all subsequent references after the
385 CLASS reference. */
386 if (class_ref)
388 tail = class_ref->next;
389 class_ref->next = NULL;
391 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
393 tail = e->ref;
394 e->ref = NULL;
397 base_expr = gfc_expr_to_initialize (e);
399 /* Restore the original tail expression. */
400 if (class_ref)
402 gfc_free_ref_list (class_ref->next);
403 class_ref->next = tail;
405 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
407 gfc_free_ref_list (e->ref);
408 e->ref = tail;
410 return base_expr;
414 /* Reset the vptr to the declared type, e.g. after deallocation. */
416 void
417 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
419 gfc_symbol *vtab;
420 tree vptr;
421 tree vtable;
422 gfc_se se;
424 /* Evaluate the expression and obtain the vptr from it. */
425 gfc_init_se (&se, NULL);
426 if (e->rank)
427 gfc_conv_expr_descriptor (&se, e);
428 else
429 gfc_conv_expr (&se, e);
430 gfc_add_block_to_block (block, &se.pre);
431 vptr = gfc_get_vptr_from_expr (se.expr);
433 /* If a vptr is not found, we can do nothing more. */
434 if (vptr == NULL_TREE)
435 return;
437 if (UNLIMITED_POLY (e))
438 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
439 else
441 /* Return the vptr to the address of the declared type. */
442 vtab = gfc_find_derived_vtab (e->ts.u.derived);
443 vtable = vtab->backend_decl;
444 if (vtable == NULL_TREE)
445 vtable = gfc_get_symbol_decl (vtab);
446 vtable = gfc_build_addr_expr (NULL, vtable);
447 vtable = fold_convert (TREE_TYPE (vptr), vtable);
448 gfc_add_modify (block, vptr, vtable);
453 /* Reset the len for unlimited polymorphic objects. */
455 void
456 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
458 gfc_expr *e;
459 gfc_se se_len;
460 e = gfc_find_and_cut_at_last_class_ref (expr);
461 if (e == NULL)
462 return;
463 gfc_add_len_component (e);
464 gfc_init_se (&se_len, NULL);
465 gfc_conv_expr (&se_len, e);
466 gfc_add_modify (block, se_len.expr,
467 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
468 gfc_free_expr (e);
472 /* Obtain the vptr of the last class reference in an expression.
473 Return NULL_TREE if no class reference is found. */
475 tree
476 gfc_get_vptr_from_expr (tree expr)
478 tree tmp;
479 tree type;
481 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
483 type = TREE_TYPE (tmp);
484 while (type)
486 if (GFC_CLASS_TYPE_P (type))
487 return gfc_class_vptr_get (tmp);
488 if (type != TYPE_CANONICAL (type))
489 type = TYPE_CANONICAL (type);
490 else
491 type = NULL_TREE;
493 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
494 break;
497 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
498 tmp = build_fold_indirect_ref_loc (input_location, tmp);
500 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
501 return gfc_class_vptr_get (tmp);
503 return NULL_TREE;
507 static void
508 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
509 bool lhs_type)
511 tree tmp, tmp2, type;
513 gfc_conv_descriptor_data_set (block, lhs_desc,
514 gfc_conv_descriptor_data_get (rhs_desc));
515 gfc_conv_descriptor_offset_set (block, lhs_desc,
516 gfc_conv_descriptor_offset_get (rhs_desc));
518 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
519 gfc_conv_descriptor_dtype (rhs_desc));
521 /* Assign the dimension as range-ref. */
522 tmp = gfc_get_descriptor_dimension (lhs_desc);
523 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
525 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
526 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
527 gfc_index_zero_node, NULL_TREE, NULL_TREE);
528 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
529 gfc_index_zero_node, NULL_TREE, NULL_TREE);
530 gfc_add_modify (block, tmp, tmp2);
534 /* Takes a derived type expression and returns the address of a temporary
535 class object of the 'declared' type. If vptr is not NULL, this is
536 used for the temporary class object.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's only relevant for the optional handling. */
539 void
540 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
541 gfc_typespec class_ts, tree vptr, bool optional,
542 bool optional_alloc_ptr)
544 gfc_symbol *vtab;
545 tree cond_optional = NULL_TREE;
546 gfc_ss *ss;
547 tree ctree;
548 tree var;
549 tree tmp;
550 int dim;
552 /* The derived type needs to be converted to a temporary
553 CLASS object. */
554 tmp = gfc_typenode_for_spec (&class_ts);
555 var = gfc_create_var (tmp, "class");
557 /* Set the vptr. */
558 ctree = gfc_class_vptr_get (var);
560 if (vptr != NULL_TREE)
562 /* Use the dynamic vptr. */
563 tmp = vptr;
565 else
567 /* In this case the vtab corresponds to the derived type and the
568 vptr must point to it. */
569 vtab = gfc_find_derived_vtab (e->ts.u.derived);
570 gcc_assert (vtab);
571 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
573 gfc_add_modify (&parmse->pre, ctree,
574 fold_convert (TREE_TYPE (ctree), tmp));
576 /* Now set the data field. */
577 ctree = gfc_class_data_get (var);
579 if (optional)
580 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
582 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
584 /* If there is a ready made pointer to a derived type, use it
585 rather than evaluating the expression again. */
586 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
587 gfc_add_modify (&parmse->pre, ctree, tmp);
589 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
591 /* For an array reference in an elemental procedure call we need
592 to retain the ss to provide the scalarized array reference. */
593 gfc_conv_expr_reference (parmse, e);
594 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
595 if (optional)
596 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
597 cond_optional, tmp,
598 fold_convert (TREE_TYPE (tmp), null_pointer_node));
599 gfc_add_modify (&parmse->pre, ctree, tmp);
601 else
603 ss = gfc_walk_expr (e);
604 if (ss == gfc_ss_terminator)
606 parmse->ss = NULL;
607 gfc_conv_expr_reference (parmse, e);
609 /* Scalar to an assumed-rank array. */
610 if (class_ts.u.derived->components->as)
612 tree type;
613 type = get_scalar_to_descriptor_type (parmse->expr,
614 gfc_expr_attr (e));
615 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
616 gfc_get_dtype (type));
617 if (optional)
618 parmse->expr = build3_loc (input_location, COND_EXPR,
619 TREE_TYPE (parmse->expr),
620 cond_optional, parmse->expr,
621 fold_convert (TREE_TYPE (parmse->expr),
622 null_pointer_node));
623 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
625 else
627 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
628 if (optional)
629 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
630 cond_optional, tmp,
631 fold_convert (TREE_TYPE (tmp),
632 null_pointer_node));
633 gfc_add_modify (&parmse->pre, ctree, tmp);
636 else
638 stmtblock_t block;
639 gfc_init_block (&block);
640 gfc_ref *ref;
642 parmse->ss = ss;
643 parmse->use_offset = 1;
644 gfc_conv_expr_descriptor (parmse, e);
646 /* Detect any array references with vector subscripts. */
647 for (ref = e->ref; ref; ref = ref->next)
648 if (ref->type == REF_ARRAY
649 && ref->u.ar.type != AR_ELEMENT
650 && ref->u.ar.type != AR_FULL)
652 for (dim = 0; dim < ref->u.ar.dimen; dim++)
653 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
654 break;
655 if (dim < ref->u.ar.dimen)
656 break;
659 /* Array references with vector subscripts and non-variable expressions
660 need be converted to a one-based descriptor. */
661 if (ref || e->expr_type != EXPR_VARIABLE)
663 for (dim = 0; dim < e->rank; ++dim)
664 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
665 gfc_index_one_node);
668 if (e->rank != class_ts.u.derived->components->as->rank)
670 gcc_assert (class_ts.u.derived->components->as->type
671 == AS_ASSUMED_RANK);
672 class_array_data_assign (&block, ctree, parmse->expr, false);
674 else
676 if (gfc_expr_attr (e).codimension)
677 parmse->expr = fold_build1_loc (input_location,
678 VIEW_CONVERT_EXPR,
679 TREE_TYPE (ctree),
680 parmse->expr);
681 gfc_add_modify (&block, ctree, parmse->expr);
684 if (optional)
686 tmp = gfc_finish_block (&block);
688 gfc_init_block (&block);
689 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
691 tmp = build3_v (COND_EXPR, cond_optional, tmp,
692 gfc_finish_block (&block));
693 gfc_add_expr_to_block (&parmse->pre, tmp);
695 else
696 gfc_add_block_to_block (&parmse->pre, &block);
700 if (class_ts.u.derived->components->ts.type == BT_DERIVED
701 && class_ts.u.derived->components->ts.u.derived
702 ->attr.unlimited_polymorphic)
704 /* Take care about initializing the _len component correctly. */
705 ctree = gfc_class_len_get (var);
706 if (UNLIMITED_POLY (e))
708 gfc_expr *len;
709 gfc_se se;
711 len = gfc_copy_expr (e);
712 gfc_add_len_component (len);
713 gfc_init_se (&se, NULL);
714 gfc_conv_expr (&se, len);
715 if (optional)
716 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
717 cond_optional, se.expr,
718 fold_convert (TREE_TYPE (se.expr),
719 integer_zero_node));
720 else
721 tmp = se.expr;
723 else
724 tmp = integer_zero_node;
725 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
726 tmp));
728 /* Pass the address of the class object. */
729 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
731 if (optional && optional_alloc_ptr)
732 parmse->expr = build3_loc (input_location, COND_EXPR,
733 TREE_TYPE (parmse->expr),
734 cond_optional, parmse->expr,
735 fold_convert (TREE_TYPE (parmse->expr),
736 null_pointer_node));
740 /* Create a new class container, which is required as scalar coarrays
741 have an array descriptor while normal scalars haven't. Optionally,
742 NULL pointer checks are added if the argument is OPTIONAL. */
744 static void
745 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
746 gfc_typespec class_ts, bool optional)
748 tree var, ctree, tmp;
749 stmtblock_t block;
750 gfc_ref *ref;
751 gfc_ref *class_ref;
753 gfc_init_block (&block);
755 class_ref = NULL;
756 for (ref = e->ref; ref; ref = ref->next)
758 if (ref->type == REF_COMPONENT
759 && ref->u.c.component->ts.type == BT_CLASS)
760 class_ref = ref;
763 if (class_ref == NULL
764 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
765 tmp = e->symtree->n.sym->backend_decl;
766 else
768 /* Remove everything after the last class reference, convert the
769 expression and then recover its tailend once more. */
770 gfc_se tmpse;
771 ref = class_ref->next;
772 class_ref->next = NULL;
773 gfc_init_se (&tmpse, NULL);
774 gfc_conv_expr (&tmpse, e);
775 class_ref->next = ref;
776 tmp = tmpse.expr;
779 var = gfc_typenode_for_spec (&class_ts);
780 var = gfc_create_var (var, "class");
782 ctree = gfc_class_vptr_get (var);
783 gfc_add_modify (&block, ctree,
784 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
786 ctree = gfc_class_data_get (var);
787 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
788 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
790 /* Pass the address of the class object. */
791 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
793 if (optional)
795 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
796 tree tmp2;
798 tmp = gfc_finish_block (&block);
800 gfc_init_block (&block);
801 tmp2 = gfc_class_data_get (var);
802 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
803 null_pointer_node));
804 tmp2 = gfc_finish_block (&block);
806 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
807 cond, tmp, tmp2);
808 gfc_add_expr_to_block (&parmse->pre, tmp);
810 else
811 gfc_add_block_to_block (&parmse->pre, &block);
815 /* Takes an intrinsic type expression and returns the address of a temporary
816 class object of the 'declared' type. */
817 void
818 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
819 gfc_typespec class_ts)
821 gfc_symbol *vtab;
822 gfc_ss *ss;
823 tree ctree;
824 tree var;
825 tree tmp;
827 /* The intrinsic type needs to be converted to a temporary
828 CLASS object. */
829 tmp = gfc_typenode_for_spec (&class_ts);
830 var = gfc_create_var (tmp, "class");
832 /* Set the vptr. */
833 ctree = gfc_class_vptr_get (var);
835 vtab = gfc_find_vtab (&e->ts);
836 gcc_assert (vtab);
837 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
838 gfc_add_modify (&parmse->pre, ctree,
839 fold_convert (TREE_TYPE (ctree), tmp));
841 /* Now set the data field. */
842 ctree = gfc_class_data_get (var);
843 if (parmse->ss && parmse->ss->info->useflags)
845 /* For an array reference in an elemental procedure call we need
846 to retain the ss to provide the scalarized array reference. */
847 gfc_conv_expr_reference (parmse, e);
848 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
849 gfc_add_modify (&parmse->pre, ctree, tmp);
851 else
853 ss = gfc_walk_expr (e);
854 if (ss == gfc_ss_terminator)
856 parmse->ss = NULL;
857 gfc_conv_expr_reference (parmse, e);
858 if (class_ts.u.derived->components->as
859 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
861 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
862 gfc_expr_attr (e));
863 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
864 TREE_TYPE (ctree), tmp);
866 else
867 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
868 gfc_add_modify (&parmse->pre, ctree, tmp);
870 else
872 parmse->ss = ss;
873 parmse->use_offset = 1;
874 gfc_conv_expr_descriptor (parmse, e);
875 if (class_ts.u.derived->components->as->rank != e->rank)
877 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
878 TREE_TYPE (ctree), parmse->expr);
879 gfc_add_modify (&parmse->pre, ctree, tmp);
881 else
882 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
886 gcc_assert (class_ts.type == BT_CLASS);
887 if (class_ts.u.derived->components->ts.type == BT_DERIVED
888 && class_ts.u.derived->components->ts.u.derived
889 ->attr.unlimited_polymorphic)
891 ctree = gfc_class_len_get (var);
892 /* When the actual arg is a char array, then set the _len component of the
893 unlimited polymorphic entity to the length of the string. */
894 if (e->ts.type == BT_CHARACTER)
896 /* Start with parmse->string_length because this seems to be set to a
897 correct value more often. */
898 if (parmse->string_length)
899 tmp = parmse->string_length;
900 /* When the string_length is not yet set, then try the backend_decl of
901 the cl. */
902 else if (e->ts.u.cl->backend_decl)
903 tmp = e->ts.u.cl->backend_decl;
904 /* If both of the above approaches fail, then try to generate an
905 expression from the input, which is only feasible currently, when the
906 expression can be evaluated to a constant one. */
907 else
909 /* Try to simplify the expression. */
910 gfc_simplify_expr (e, 0);
911 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
913 /* Amazingly all data is present to compute the length of a
914 constant string, but the expression is not yet there. */
915 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
916 gfc_charlen_int_kind,
917 &e->where);
918 mpz_set_ui (e->ts.u.cl->length->value.integer,
919 e->value.character.length);
920 gfc_conv_const_charlen (e->ts.u.cl);
921 e->ts.u.cl->resolved = 1;
922 tmp = e->ts.u.cl->backend_decl;
924 else
926 gfc_error ("Can't compute the length of the char array at %L.",
927 &e->where);
931 else
932 tmp = integer_zero_node;
934 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
936 else if (class_ts.type == BT_CLASS
937 && class_ts.u.derived->components
938 && class_ts.u.derived->components->ts.u
939 .derived->attr.unlimited_polymorphic)
941 ctree = gfc_class_len_get (var);
942 gfc_add_modify (&parmse->pre, ctree,
943 fold_convert (TREE_TYPE (ctree),
944 integer_zero_node));
946 /* Pass the address of the class object. */
947 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
951 /* Takes a scalarized class array expression and returns the
952 address of a temporary scalar class object of the 'declared'
953 type.
954 OOP-TODO: This could be improved by adding code that branched on
955 the dynamic type being the same as the declared type. In this case
956 the original class expression can be passed directly.
957 optional_alloc_ptr is false when the dummy is neither allocatable
958 nor a pointer; that's relevant for the optional handling.
959 Set copyback to true if class container's _data and _vtab pointers
960 might get modified. */
962 void
963 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
964 bool elemental, bool copyback, bool optional,
965 bool optional_alloc_ptr)
967 tree ctree;
968 tree var;
969 tree tmp;
970 tree vptr;
971 tree cond = NULL_TREE;
972 tree slen = NULL_TREE;
973 gfc_ref *ref;
974 gfc_ref *class_ref;
975 stmtblock_t block;
976 bool full_array = false;
978 gfc_init_block (&block);
980 class_ref = NULL;
981 for (ref = e->ref; ref; ref = ref->next)
983 if (ref->type == REF_COMPONENT
984 && ref->u.c.component->ts.type == BT_CLASS)
985 class_ref = ref;
987 if (ref->next == NULL)
988 break;
991 if ((ref == NULL || class_ref == ref)
992 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
993 && (!class_ts.u.derived->components->as
994 || class_ts.u.derived->components->as->rank != -1))
995 return;
997 /* Test for FULL_ARRAY. */
998 if (e->rank == 0 && gfc_expr_attr (e).codimension
999 && gfc_expr_attr (e).dimension)
1000 full_array = true;
1001 else
1002 gfc_is_class_array_ref (e, &full_array);
1004 /* The derived type needs to be converted to a temporary
1005 CLASS object. */
1006 tmp = gfc_typenode_for_spec (&class_ts);
1007 var = gfc_create_var (tmp, "class");
1009 /* Set the data. */
1010 ctree = gfc_class_data_get (var);
1011 if (class_ts.u.derived->components->as
1012 && e->rank != class_ts.u.derived->components->as->rank)
1014 if (e->rank == 0)
1016 tree type = get_scalar_to_descriptor_type (parmse->expr,
1017 gfc_expr_attr (e));
1018 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1019 gfc_get_dtype (type));
1021 tmp = gfc_class_data_get (parmse->expr);
1022 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1023 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1025 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1027 else
1028 class_array_data_assign (&block, ctree, parmse->expr, false);
1030 else
1032 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1033 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1034 TREE_TYPE (ctree), parmse->expr);
1035 gfc_add_modify (&block, ctree, parmse->expr);
1038 /* Return the data component, except in the case of scalarized array
1039 references, where nullification of the cannot occur and so there
1040 is no need. */
1041 if (!elemental && full_array && copyback)
1043 if (class_ts.u.derived->components->as
1044 && e->rank != class_ts.u.derived->components->as->rank)
1046 if (e->rank == 0)
1047 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1048 gfc_conv_descriptor_data_get (ctree));
1049 else
1050 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1052 else
1053 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1056 /* Set the vptr. */
1057 ctree = gfc_class_vptr_get (var);
1059 /* The vptr is the second field of the actual argument.
1060 First we have to find the corresponding class reference. */
1062 tmp = NULL_TREE;
1063 if (gfc_is_class_array_function (e)
1064 && parmse->class_vptr != NULL_TREE)
1065 tmp = parmse->class_vptr;
1066 else if (class_ref == NULL
1067 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1069 tmp = e->symtree->n.sym->backend_decl;
1071 if (TREE_CODE (tmp) == FUNCTION_DECL)
1072 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1074 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1075 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1077 slen = build_zero_cst (size_type_node);
1079 else
1081 /* Remove everything after the last class reference, convert the
1082 expression and then recover its tailend once more. */
1083 gfc_se tmpse;
1084 ref = class_ref->next;
1085 class_ref->next = NULL;
1086 gfc_init_se (&tmpse, NULL);
1087 gfc_conv_expr (&tmpse, e);
1088 class_ref->next = ref;
1089 tmp = tmpse.expr;
1090 slen = tmpse.string_length;
1093 gcc_assert (tmp != NULL_TREE);
1095 /* Dereference if needs be. */
1096 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1097 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1099 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1100 vptr = gfc_class_vptr_get (tmp);
1101 else
1102 vptr = tmp;
1104 gfc_add_modify (&block, ctree,
1105 fold_convert (TREE_TYPE (ctree), vptr));
1107 /* Return the vptr component, except in the case of scalarized array
1108 references, where the dynamic type cannot change. */
1109 if (!elemental && full_array && copyback)
1110 gfc_add_modify (&parmse->post, vptr,
1111 fold_convert (TREE_TYPE (vptr), ctree));
1113 /* For unlimited polymorphic objects also set the _len component. */
1114 if (class_ts.type == BT_CLASS
1115 && class_ts.u.derived->components
1116 && class_ts.u.derived->components->ts.u
1117 .derived->attr.unlimited_polymorphic)
1119 ctree = gfc_class_len_get (var);
1120 if (UNLIMITED_POLY (e))
1121 tmp = gfc_class_len_get (tmp);
1122 else if (e->ts.type == BT_CHARACTER)
1124 gcc_assert (slen != NULL_TREE);
1125 tmp = slen;
1127 else
1128 tmp = build_zero_cst (size_type_node);
1129 gfc_add_modify (&parmse->pre, ctree,
1130 fold_convert (TREE_TYPE (ctree), tmp));
1132 /* Return the len component, except in the case of scalarized array
1133 references, where the dynamic type cannot change. */
1134 if (!elemental && full_array && copyback)
1135 gfc_add_modify (&parmse->post, tmp,
1136 fold_convert (TREE_TYPE (tmp), ctree));
1139 if (optional)
1141 tree tmp2;
1143 cond = gfc_conv_expr_present (e->symtree->n.sym);
1144 /* parmse->pre may contain some preparatory instructions for the
1145 temporary array descriptor. Those may only be executed when the
1146 optional argument is set, therefore add parmse->pre's instructions
1147 to block, which is later guarded by an if (optional_arg_given). */
1148 gfc_add_block_to_block (&parmse->pre, &block);
1149 block.head = parmse->pre.head;
1150 parmse->pre.head = NULL_TREE;
1151 tmp = gfc_finish_block (&block);
1153 if (optional_alloc_ptr)
1154 tmp2 = build_empty_stmt (input_location);
1155 else
1157 gfc_init_block (&block);
1159 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1160 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1161 null_pointer_node));
1162 tmp2 = gfc_finish_block (&block);
1165 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1166 cond, tmp, tmp2);
1167 gfc_add_expr_to_block (&parmse->pre, tmp);
1169 else
1170 gfc_add_block_to_block (&parmse->pre, &block);
1172 /* Pass the address of the class object. */
1173 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1175 if (optional && optional_alloc_ptr)
1176 parmse->expr = build3_loc (input_location, COND_EXPR,
1177 TREE_TYPE (parmse->expr),
1178 cond, parmse->expr,
1179 fold_convert (TREE_TYPE (parmse->expr),
1180 null_pointer_node));
1184 /* Given a class array declaration and an index, returns the address
1185 of the referenced element. */
1187 tree
1188 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1189 bool unlimited)
1191 tree data, size, tmp, ctmp, offset, ptr;
1193 data = data_comp != NULL_TREE ? data_comp :
1194 gfc_class_data_get (class_decl);
1195 size = gfc_class_vtab_size_get (class_decl);
1197 if (unlimited)
1199 tmp = fold_convert (gfc_array_index_type,
1200 gfc_class_len_get (class_decl));
1201 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1202 gfc_array_index_type, size, tmp);
1203 tmp = fold_build2_loc (input_location, GT_EXPR,
1204 logical_type_node, tmp,
1205 build_zero_cst (TREE_TYPE (tmp)));
1206 size = fold_build3_loc (input_location, COND_EXPR,
1207 gfc_array_index_type, tmp, ctmp, size);
1210 offset = fold_build2_loc (input_location, MULT_EXPR,
1211 gfc_array_index_type,
1212 index, size);
1214 data = gfc_conv_descriptor_data_get (data);
1215 ptr = fold_convert (pvoid_type_node, data);
1216 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1217 return fold_convert (TREE_TYPE (data), ptr);
1221 /* Copies one class expression to another, assuming that if either
1222 'to' or 'from' are arrays they are packed. Should 'from' be
1223 NULL_TREE, the initialization expression for 'to' is used, assuming
1224 that the _vptr is set. */
1226 tree
1227 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1229 tree fcn;
1230 tree fcn_type;
1231 tree from_data;
1232 tree from_len;
1233 tree to_data;
1234 tree to_len;
1235 tree to_ref;
1236 tree from_ref;
1237 vec<tree, va_gc> *args;
1238 tree tmp;
1239 tree stdcopy;
1240 tree extcopy;
1241 tree index;
1242 bool is_from_desc = false, is_to_class = false;
1244 args = NULL;
1245 /* To prevent warnings on uninitialized variables. */
1246 from_len = to_len = NULL_TREE;
1248 if (from != NULL_TREE)
1249 fcn = gfc_class_vtab_copy_get (from);
1250 else
1251 fcn = gfc_class_vtab_copy_get (to);
1253 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1255 if (from != NULL_TREE)
1257 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1258 if (is_from_desc)
1260 from_data = from;
1261 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1263 else
1265 /* Check that from is a class. When the class is part of a coarray,
1266 then from is a common pointer and is to be used as is. */
1267 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1268 ? build_fold_indirect_ref (from) : from;
1269 from_data =
1270 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1271 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1272 ? gfc_class_data_get (from) : from;
1273 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1276 else
1277 from_data = gfc_class_vtab_def_init_get (to);
1279 if (unlimited)
1281 if (from != NULL_TREE && unlimited)
1282 from_len = gfc_class_len_or_zero_get (from);
1283 else
1284 from_len = build_zero_cst (size_type_node);
1287 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1289 is_to_class = true;
1290 to_data = gfc_class_data_get (to);
1291 if (unlimited)
1292 to_len = gfc_class_len_get (to);
1294 else
1295 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1296 to_data = to;
1298 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1300 stmtblock_t loopbody;
1301 stmtblock_t body;
1302 stmtblock_t ifbody;
1303 gfc_loopinfo loop;
1304 tree orig_nelems = nelems; /* Needed for bounds check. */
1306 gfc_init_block (&body);
1307 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1308 gfc_array_index_type, nelems,
1309 gfc_index_one_node);
1310 nelems = gfc_evaluate_now (tmp, &body);
1311 index = gfc_create_var (gfc_array_index_type, "S");
1313 if (is_from_desc)
1315 from_ref = gfc_get_class_array_ref (index, from, from_data,
1316 unlimited);
1317 vec_safe_push (args, from_ref);
1319 else
1320 vec_safe_push (args, from_data);
1322 if (is_to_class)
1323 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1324 else
1326 tmp = gfc_conv_array_data (to);
1327 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1328 to_ref = gfc_build_addr_expr (NULL_TREE,
1329 gfc_build_array_ref (tmp, index, to));
1331 vec_safe_push (args, to_ref);
1333 /* Add bounds check. */
1334 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1336 char *msg;
1337 const char *name = "<<unknown>>";
1338 tree from_len;
1340 if (DECL_P (to))
1341 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1343 from_len = gfc_conv_descriptor_size (from_data, 1);
1344 tmp = fold_build2_loc (input_location, NE_EXPR,
1345 logical_type_node, from_len, orig_nelems);
1346 msg = xasprintf ("Array bound mismatch for dimension %d "
1347 "of array '%s' (%%ld/%%ld)",
1348 1, name);
1350 gfc_trans_runtime_check (true, false, tmp, &body,
1351 &gfc_current_locus, msg,
1352 fold_convert (long_integer_type_node, orig_nelems),
1353 fold_convert (long_integer_type_node, from_len));
1355 free (msg);
1358 tmp = build_call_vec (fcn_type, fcn, args);
1360 /* Build the body of the loop. */
1361 gfc_init_block (&loopbody);
1362 gfc_add_expr_to_block (&loopbody, tmp);
1364 /* Build the loop and return. */
1365 gfc_init_loopinfo (&loop);
1366 loop.dimen = 1;
1367 loop.from[0] = gfc_index_zero_node;
1368 loop.loopvar[0] = index;
1369 loop.to[0] = nelems;
1370 gfc_trans_scalarizing_loops (&loop, &loopbody);
1371 gfc_init_block (&ifbody);
1372 gfc_add_block_to_block (&ifbody, &loop.pre);
1373 stdcopy = gfc_finish_block (&ifbody);
1374 /* In initialization mode from_len is a constant zero. */
1375 if (unlimited && !integer_zerop (from_len))
1377 vec_safe_push (args, from_len);
1378 vec_safe_push (args, to_len);
1379 tmp = build_call_vec (fcn_type, fcn, args);
1380 /* Build the body of the loop. */
1381 gfc_init_block (&loopbody);
1382 gfc_add_expr_to_block (&loopbody, tmp);
1384 /* Build the loop and return. */
1385 gfc_init_loopinfo (&loop);
1386 loop.dimen = 1;
1387 loop.from[0] = gfc_index_zero_node;
1388 loop.loopvar[0] = index;
1389 loop.to[0] = nelems;
1390 gfc_trans_scalarizing_loops (&loop, &loopbody);
1391 gfc_init_block (&ifbody);
1392 gfc_add_block_to_block (&ifbody, &loop.pre);
1393 extcopy = gfc_finish_block (&ifbody);
1395 tmp = fold_build2_loc (input_location, GT_EXPR,
1396 logical_type_node, from_len,
1397 build_zero_cst (TREE_TYPE (from_len)));
1398 tmp = fold_build3_loc (input_location, COND_EXPR,
1399 void_type_node, tmp, extcopy, stdcopy);
1400 gfc_add_expr_to_block (&body, tmp);
1401 tmp = gfc_finish_block (&body);
1403 else
1405 gfc_add_expr_to_block (&body, stdcopy);
1406 tmp = gfc_finish_block (&body);
1408 gfc_cleanup_loop (&loop);
1410 else
1412 gcc_assert (!is_from_desc);
1413 vec_safe_push (args, from_data);
1414 vec_safe_push (args, to_data);
1415 stdcopy = build_call_vec (fcn_type, fcn, args);
1417 /* In initialization mode from_len is a constant zero. */
1418 if (unlimited && !integer_zerop (from_len))
1420 vec_safe_push (args, from_len);
1421 vec_safe_push (args, to_len);
1422 extcopy = build_call_vec (fcn_type, fcn, args);
1423 tmp = fold_build2_loc (input_location, GT_EXPR,
1424 logical_type_node, from_len,
1425 build_zero_cst (TREE_TYPE (from_len)));
1426 tmp = fold_build3_loc (input_location, COND_EXPR,
1427 void_type_node, tmp, extcopy, stdcopy);
1429 else
1430 tmp = stdcopy;
1433 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1434 if (from == NULL_TREE)
1436 tree cond;
1437 cond = fold_build2_loc (input_location, NE_EXPR,
1438 logical_type_node,
1439 from_data, null_pointer_node);
1440 tmp = fold_build3_loc (input_location, COND_EXPR,
1441 void_type_node, cond,
1442 tmp, build_empty_stmt (input_location));
1445 return tmp;
1449 static tree
1450 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1452 gfc_actual_arglist *actual;
1453 gfc_expr *ppc;
1454 gfc_code *ppc_code;
1455 tree res;
1457 actual = gfc_get_actual_arglist ();
1458 actual->expr = gfc_copy_expr (rhs);
1459 actual->next = gfc_get_actual_arglist ();
1460 actual->next->expr = gfc_copy_expr (lhs);
1461 ppc = gfc_copy_expr (obj);
1462 gfc_add_vptr_component (ppc);
1463 gfc_add_component_ref (ppc, "_copy");
1464 ppc_code = gfc_get_code (EXEC_CALL);
1465 ppc_code->resolved_sym = ppc->symtree->n.sym;
1466 /* Although '_copy' is set to be elemental in class.c, it is
1467 not staying that way. Find out why, sometime.... */
1468 ppc_code->resolved_sym->attr.elemental = 1;
1469 ppc_code->ext.actual = actual;
1470 ppc_code->expr1 = ppc;
1471 /* Since '_copy' is elemental, the scalarizer will take care
1472 of arrays in gfc_trans_call. */
1473 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1474 gfc_free_statements (ppc_code);
1476 if (UNLIMITED_POLY(obj))
1478 /* Check if rhs is non-NULL. */
1479 gfc_se src;
1480 gfc_init_se (&src, NULL);
1481 gfc_conv_expr (&src, rhs);
1482 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1483 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1484 src.expr, fold_convert (TREE_TYPE (src.expr),
1485 null_pointer_node));
1486 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1487 build_empty_stmt (input_location));
1490 return res;
1493 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1494 A MEMCPY is needed to copy the full data from the default initializer
1495 of the dynamic type. */
1497 tree
1498 gfc_trans_class_init_assign (gfc_code *code)
1500 stmtblock_t block;
1501 tree tmp;
1502 gfc_se dst,src,memsz;
1503 gfc_expr *lhs, *rhs, *sz;
1505 gfc_start_block (&block);
1507 lhs = gfc_copy_expr (code->expr1);
1508 gfc_add_data_component (lhs);
1510 rhs = gfc_copy_expr (code->expr1);
1511 gfc_add_vptr_component (rhs);
1513 /* Make sure that the component backend_decls have been built, which
1514 will not have happened if the derived types concerned have not
1515 been referenced. */
1516 gfc_get_derived_type (rhs->ts.u.derived);
1517 gfc_add_def_init_component (rhs);
1518 /* The _def_init is always scalar. */
1519 rhs->rank = 0;
1521 if (code->expr1->ts.type == BT_CLASS
1522 && CLASS_DATA (code->expr1)->attr.dimension)
1524 gfc_array_spec *tmparr = gfc_get_array_spec ();
1525 *tmparr = *CLASS_DATA (code->expr1)->as;
1526 gfc_add_full_array_ref (lhs, tmparr);
1527 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1529 else
1531 sz = gfc_copy_expr (code->expr1);
1532 gfc_add_vptr_component (sz);
1533 gfc_add_size_component (sz);
1535 gfc_init_se (&dst, NULL);
1536 gfc_init_se (&src, NULL);
1537 gfc_init_se (&memsz, NULL);
1538 gfc_conv_expr (&dst, lhs);
1539 gfc_conv_expr (&src, rhs);
1540 gfc_conv_expr (&memsz, sz);
1541 gfc_add_block_to_block (&block, &src.pre);
1542 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1544 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1546 if (UNLIMITED_POLY(code->expr1))
1548 /* Check if _def_init is non-NULL. */
1549 tree cond = fold_build2_loc (input_location, NE_EXPR,
1550 logical_type_node, src.expr,
1551 fold_convert (TREE_TYPE (src.expr),
1552 null_pointer_node));
1553 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1554 tmp, build_empty_stmt (input_location));
1558 if (code->expr1->symtree->n.sym->attr.optional
1559 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1561 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1562 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1563 present, tmp,
1564 build_empty_stmt (input_location));
1567 gfc_add_expr_to_block (&block, tmp);
1569 return gfc_finish_block (&block);
1573 /* End of prototype trans-class.c */
1576 static void
1577 realloc_lhs_warning (bt type, bool array, locus *where)
1579 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1580 gfc_warning (OPT_Wrealloc_lhs,
1581 "Code for reallocating the allocatable array at %L will "
1582 "be added", where);
1583 else if (warn_realloc_lhs_all)
1584 gfc_warning (OPT_Wrealloc_lhs_all,
1585 "Code for reallocating the allocatable variable at %L "
1586 "will be added", where);
1590 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1591 gfc_expr *);
1593 /* Copy the scalarization loop variables. */
1595 static void
1596 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1598 dest->ss = src->ss;
1599 dest->loop = src->loop;
1603 /* Initialize a simple expression holder.
1605 Care must be taken when multiple se are created with the same parent.
1606 The child se must be kept in sync. The easiest way is to delay creation
1607 of a child se until after after the previous se has been translated. */
1609 void
1610 gfc_init_se (gfc_se * se, gfc_se * parent)
1612 memset (se, 0, sizeof (gfc_se));
1613 gfc_init_block (&se->pre);
1614 gfc_init_block (&se->post);
1616 se->parent = parent;
1618 if (parent)
1619 gfc_copy_se_loopvars (se, parent);
1623 /* Advances to the next SS in the chain. Use this rather than setting
1624 se->ss = se->ss->next because all the parents needs to be kept in sync.
1625 See gfc_init_se. */
1627 void
1628 gfc_advance_se_ss_chain (gfc_se * se)
1630 gfc_se *p;
1631 gfc_ss *ss;
1633 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1635 p = se;
1636 /* Walk down the parent chain. */
1637 while (p != NULL)
1639 /* Simple consistency check. */
1640 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1641 || p->parent->ss->nested_ss == p->ss);
1643 /* If we were in a nested loop, the next scalarized expression can be
1644 on the parent ss' next pointer. Thus we should not take the next
1645 pointer blindly, but rather go up one nest level as long as next
1646 is the end of chain. */
1647 ss = p->ss;
1648 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1649 ss = ss->parent;
1651 p->ss = ss->next;
1653 p = p->parent;
1658 /* Ensures the result of the expression as either a temporary variable
1659 or a constant so that it can be used repeatedly. */
1661 void
1662 gfc_make_safe_expr (gfc_se * se)
1664 tree var;
1666 if (CONSTANT_CLASS_P (se->expr))
1667 return;
1669 /* We need a temporary for this result. */
1670 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1671 gfc_add_modify (&se->pre, var, se->expr);
1672 se->expr = var;
1676 /* Return an expression which determines if a dummy parameter is present.
1677 Also used for arguments to procedures with multiple entry points. */
1679 tree
1680 gfc_conv_expr_present (gfc_symbol * sym)
1682 tree decl, cond;
1684 gcc_assert (sym->attr.dummy);
1685 decl = gfc_get_symbol_decl (sym);
1687 /* Intrinsic scalars with VALUE attribute which are passed by value
1688 use a hidden argument to denote the present status. */
1689 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1690 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1691 && !sym->attr.dimension)
1693 char name[GFC_MAX_SYMBOL_LEN + 2];
1694 tree tree_name;
1696 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1697 name[0] = '_';
1698 strcpy (&name[1], sym->name);
1699 tree_name = get_identifier (name);
1701 /* Walk function argument list to find hidden arg. */
1702 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1703 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1704 if (DECL_NAME (cond) == tree_name)
1705 break;
1707 gcc_assert (cond);
1708 return cond;
1711 if (TREE_CODE (decl) != PARM_DECL)
1713 /* Array parameters use a temporary descriptor, we want the real
1714 parameter. */
1715 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1716 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1717 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1720 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1721 fold_convert (TREE_TYPE (decl), null_pointer_node));
1723 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1724 as actual argument to denote absent dummies. For array descriptors,
1725 we thus also need to check the array descriptor. For BT_CLASS, it
1726 can also occur for scalars and F2003 due to type->class wrapping and
1727 class->class wrapping. Note further that BT_CLASS always uses an
1728 array descriptor for arrays, also for explicit-shape/assumed-size. */
1730 if (!sym->attr.allocatable
1731 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1732 || (sym->ts.type == BT_CLASS
1733 && !CLASS_DATA (sym)->attr.allocatable
1734 && !CLASS_DATA (sym)->attr.class_pointer))
1735 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1736 || sym->ts.type == BT_CLASS))
1738 tree tmp;
1740 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1741 || sym->as->type == AS_ASSUMED_RANK
1742 || sym->attr.codimension))
1743 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1745 tmp = build_fold_indirect_ref_loc (input_location, decl);
1746 if (sym->ts.type == BT_CLASS)
1747 tmp = gfc_class_data_get (tmp);
1748 tmp = gfc_conv_array_data (tmp);
1750 else if (sym->ts.type == BT_CLASS)
1751 tmp = gfc_class_data_get (decl);
1752 else
1753 tmp = NULL_TREE;
1755 if (tmp != NULL_TREE)
1757 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1758 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1759 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1760 logical_type_node, cond, tmp);
1764 return cond;
1768 /* Converts a missing, dummy argument into a null or zero. */
1770 void
1771 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1773 tree present;
1774 tree tmp;
1776 present = gfc_conv_expr_present (arg->symtree->n.sym);
1778 if (kind > 0)
1780 /* Create a temporary and convert it to the correct type. */
1781 tmp = gfc_get_int_type (kind);
1782 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1783 se->expr));
1785 /* Test for a NULL value. */
1786 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1787 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1788 tmp = gfc_evaluate_now (tmp, &se->pre);
1789 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1791 else
1793 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1794 present, se->expr,
1795 build_zero_cst (TREE_TYPE (se->expr)));
1796 tmp = gfc_evaluate_now (tmp, &se->pre);
1797 se->expr = tmp;
1800 if (ts.type == BT_CHARACTER)
1802 tmp = build_int_cst (gfc_charlen_type_node, 0);
1803 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1804 present, se->string_length, tmp);
1805 tmp = gfc_evaluate_now (tmp, &se->pre);
1806 se->string_length = tmp;
1808 return;
1812 /* Get the character length of an expression, looking through gfc_refs
1813 if necessary. */
1815 tree
1816 gfc_get_expr_charlen (gfc_expr *e)
1818 gfc_ref *r;
1819 tree length;
1821 gcc_assert (e->expr_type == EXPR_VARIABLE
1822 && e->ts.type == BT_CHARACTER);
1824 length = NULL; /* To silence compiler warning. */
1826 if (is_subref_array (e) && e->ts.u.cl->length)
1828 gfc_se tmpse;
1829 gfc_init_se (&tmpse, NULL);
1830 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1831 e->ts.u.cl->backend_decl = tmpse.expr;
1832 return tmpse.expr;
1835 /* First candidate: if the variable is of type CHARACTER, the
1836 expression's length could be the length of the character
1837 variable. */
1838 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1839 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1841 /* Look through the reference chain for component references. */
1842 for (r = e->ref; r; r = r->next)
1844 switch (r->type)
1846 case REF_COMPONENT:
1847 if (r->u.c.component->ts.type == BT_CHARACTER)
1848 length = r->u.c.component->ts.u.cl->backend_decl;
1849 break;
1851 case REF_ARRAY:
1852 /* Do nothing. */
1853 break;
1855 default:
1856 /* We should never got substring references here. These will be
1857 broken down by the scalarizer. */
1858 gcc_unreachable ();
1859 break;
1863 gcc_assert (length != NULL);
1864 return length;
1868 /* Return for an expression the backend decl of the coarray. */
1870 tree
1871 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1873 tree caf_decl;
1874 bool found = false;
1875 gfc_ref *ref;
1877 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1879 /* Not-implemented diagnostic. */
1880 if (expr->symtree->n.sym->ts.type == BT_CLASS
1881 && UNLIMITED_POLY (expr->symtree->n.sym)
1882 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1883 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1884 "%L is not supported", &expr->where);
1886 for (ref = expr->ref; ref; ref = ref->next)
1887 if (ref->type == REF_COMPONENT)
1889 if (ref->u.c.component->ts.type == BT_CLASS
1890 && UNLIMITED_POLY (ref->u.c.component)
1891 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1892 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1893 "component at %L is not supported", &expr->where);
1896 /* Make sure the backend_decl is present before accessing it. */
1897 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1898 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1899 : expr->symtree->n.sym->backend_decl;
1901 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1903 if (expr->ref && expr->ref->type == REF_ARRAY)
1905 caf_decl = gfc_class_data_get (caf_decl);
1906 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1907 return caf_decl;
1909 for (ref = expr->ref; ref; ref = ref->next)
1911 if (ref->type == REF_COMPONENT
1912 && strcmp (ref->u.c.component->name, "_data") != 0)
1914 caf_decl = gfc_class_data_get (caf_decl);
1915 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1916 return caf_decl;
1917 break;
1919 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1920 break;
1923 if (expr->symtree->n.sym->attr.codimension)
1924 return caf_decl;
1926 /* The following code assumes that the coarray is a component reachable via
1927 only scalar components/variables; the Fortran standard guarantees this. */
1929 for (ref = expr->ref; ref; ref = ref->next)
1930 if (ref->type == REF_COMPONENT)
1932 gfc_component *comp = ref->u.c.component;
1934 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1935 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1936 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1937 TREE_TYPE (comp->backend_decl), caf_decl,
1938 comp->backend_decl, NULL_TREE);
1939 if (comp->ts.type == BT_CLASS)
1941 caf_decl = gfc_class_data_get (caf_decl);
1942 if (CLASS_DATA (comp)->attr.codimension)
1944 found = true;
1945 break;
1948 if (comp->attr.codimension)
1950 found = true;
1951 break;
1954 gcc_assert (found && caf_decl);
1955 return caf_decl;
1959 /* Obtain the Coarray token - and optionally also the offset. */
1961 void
1962 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1963 tree se_expr, gfc_expr *expr)
1965 tree tmp;
1967 /* Coarray token. */
1968 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1970 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1971 == GFC_ARRAY_ALLOCATABLE
1972 || expr->symtree->n.sym->attr.select_type_temporary);
1973 *token = gfc_conv_descriptor_token (caf_decl);
1975 else if (DECL_LANG_SPECIFIC (caf_decl)
1976 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1977 *token = GFC_DECL_TOKEN (caf_decl);
1978 else
1980 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1981 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1982 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1985 if (offset == NULL)
1986 return;
1988 /* Offset between the coarray base address and the address wanted. */
1989 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1990 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1991 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1992 *offset = build_int_cst (gfc_array_index_type, 0);
1993 else if (DECL_LANG_SPECIFIC (caf_decl)
1994 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
1995 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
1996 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
1997 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
1998 else
1999 *offset = build_int_cst (gfc_array_index_type, 0);
2001 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2002 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2004 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2005 tmp = gfc_conv_descriptor_data_get (tmp);
2007 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2008 tmp = gfc_conv_descriptor_data_get (se_expr);
2009 else
2011 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2012 tmp = se_expr;
2015 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2016 *offset, fold_convert (gfc_array_index_type, tmp));
2018 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2019 && expr->symtree->n.sym->attr.codimension
2020 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2022 gfc_expr *base_expr = gfc_copy_expr (expr);
2023 gfc_ref *ref = base_expr->ref;
2024 gfc_se base_se;
2026 // Iterate through the refs until the last one.
2027 while (ref->next)
2028 ref = ref->next;
2030 if (ref->type == REF_ARRAY
2031 && ref->u.ar.type != AR_FULL)
2033 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2034 int i;
2035 for (i = 0; i < ranksum; ++i)
2037 ref->u.ar.start[i] = NULL;
2038 ref->u.ar.end[i] = NULL;
2040 ref->u.ar.type = AR_FULL;
2042 gfc_init_se (&base_se, NULL);
2043 if (gfc_caf_attr (base_expr).dimension)
2045 gfc_conv_expr_descriptor (&base_se, base_expr);
2046 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2048 else
2050 gfc_conv_expr (&base_se, base_expr);
2051 tmp = base_se.expr;
2054 gfc_free_expr (base_expr);
2055 gfc_add_block_to_block (&se->pre, &base_se.pre);
2056 gfc_add_block_to_block (&se->post, &base_se.post);
2058 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2059 tmp = gfc_conv_descriptor_data_get (caf_decl);
2060 else
2062 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2063 tmp = caf_decl;
2066 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2067 fold_convert (gfc_array_index_type, *offset),
2068 fold_convert (gfc_array_index_type, tmp));
2072 /* Convert the coindex of a coarray into an image index; the result is
2073 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2074 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2076 tree
2077 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2079 gfc_ref *ref;
2080 tree lbound, ubound, extent, tmp, img_idx;
2081 gfc_se se;
2082 int i;
2084 for (ref = e->ref; ref; ref = ref->next)
2085 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2086 break;
2087 gcc_assert (ref != NULL);
2089 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2091 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2092 integer_zero_node);
2095 img_idx = integer_zero_node;
2096 extent = integer_one_node;
2097 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2098 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2100 gfc_init_se (&se, NULL);
2101 gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
2102 gfc_add_block_to_block (block, &se.pre);
2103 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2104 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2105 integer_type_node, se.expr,
2106 fold_convert(integer_type_node, lbound));
2107 tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
2108 extent, tmp);
2109 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2110 img_idx, tmp);
2111 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2113 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2114 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2115 tmp = fold_convert (integer_type_node, tmp);
2116 extent = fold_build2_loc (input_location, MULT_EXPR,
2117 integer_type_node, extent, tmp);
2120 else
2121 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2123 gfc_init_se (&se, NULL);
2124 gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
2125 gfc_add_block_to_block (block, &se.pre);
2126 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2127 lbound = fold_convert (integer_type_node, lbound);
2128 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2129 integer_type_node, se.expr, lbound);
2130 tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
2131 extent, tmp);
2132 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2133 img_idx, tmp);
2134 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2136 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2137 ubound = fold_convert (integer_type_node, ubound);
2138 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2139 integer_type_node, ubound, lbound);
2140 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2141 tmp, integer_one_node);
2142 extent = fold_build2_loc (input_location, MULT_EXPR,
2143 integer_type_node, extent, tmp);
2146 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2147 img_idx, integer_one_node);
2148 return img_idx;
2152 /* For each character array constructor subexpression without a ts.u.cl->length,
2153 replace it by its first element (if there aren't any elements, the length
2154 should already be set to zero). */
2156 static void
2157 flatten_array_ctors_without_strlen (gfc_expr* e)
2159 gfc_actual_arglist* arg;
2160 gfc_constructor* c;
2162 if (!e)
2163 return;
2165 switch (e->expr_type)
2168 case EXPR_OP:
2169 flatten_array_ctors_without_strlen (e->value.op.op1);
2170 flatten_array_ctors_without_strlen (e->value.op.op2);
2171 break;
2173 case EXPR_COMPCALL:
2174 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2175 gcc_unreachable ();
2177 case EXPR_FUNCTION:
2178 for (arg = e->value.function.actual; arg; arg = arg->next)
2179 flatten_array_ctors_without_strlen (arg->expr);
2180 break;
2182 case EXPR_ARRAY:
2184 /* We've found what we're looking for. */
2185 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2187 gfc_constructor *c;
2188 gfc_expr* new_expr;
2190 gcc_assert (e->value.constructor);
2192 c = gfc_constructor_first (e->value.constructor);
2193 new_expr = c->expr;
2194 c->expr = NULL;
2196 flatten_array_ctors_without_strlen (new_expr);
2197 gfc_replace_expr (e, new_expr);
2198 break;
2201 /* Otherwise, fall through to handle constructor elements. */
2202 gcc_fallthrough ();
2203 case EXPR_STRUCTURE:
2204 for (c = gfc_constructor_first (e->value.constructor);
2205 c; c = gfc_constructor_next (c))
2206 flatten_array_ctors_without_strlen (c->expr);
2207 break;
2209 default:
2210 break;
2216 /* Generate code to initialize a string length variable. Returns the
2217 value. For array constructors, cl->length might be NULL and in this case,
2218 the first element of the constructor is needed. expr is the original
2219 expression so we can access it but can be NULL if this is not needed. */
2221 void
2222 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2224 gfc_se se;
2226 gfc_init_se (&se, NULL);
2228 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2229 return;
2231 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2232 "flatten" array constructors by taking their first element; all elements
2233 should be the same length or a cl->length should be present. */
2234 if (!cl->length)
2236 gfc_expr* expr_flat;
2237 gcc_assert (expr);
2238 expr_flat = gfc_copy_expr (expr);
2239 flatten_array_ctors_without_strlen (expr_flat);
2240 gfc_resolve_expr (expr_flat);
2242 gfc_conv_expr (&se, expr_flat);
2243 gfc_add_block_to_block (pblock, &se.pre);
2244 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2246 gfc_free_expr (expr_flat);
2247 return;
2250 /* Convert cl->length. */
2252 gcc_assert (cl->length);
2254 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2255 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2256 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2257 gfc_add_block_to_block (pblock, &se.pre);
2259 if (cl->backend_decl)
2260 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2261 else
2262 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2266 static void
2267 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2268 const char *name, locus *where)
2270 tree tmp;
2271 tree type;
2272 tree fault;
2273 gfc_se start;
2274 gfc_se end;
2275 char *msg;
2276 mpz_t length;
2278 type = gfc_get_character_type (kind, ref->u.ss.length);
2279 type = build_pointer_type (type);
2281 gfc_init_se (&start, se);
2282 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2283 gfc_add_block_to_block (&se->pre, &start.pre);
2285 if (integer_onep (start.expr))
2286 gfc_conv_string_parameter (se);
2287 else
2289 tmp = start.expr;
2290 STRIP_NOPS (tmp);
2291 /* Avoid multiple evaluation of substring start. */
2292 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2293 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2295 /* Change the start of the string. */
2296 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2297 tmp = se->expr;
2298 else
2299 tmp = build_fold_indirect_ref_loc (input_location,
2300 se->expr);
2301 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2302 se->expr = gfc_build_addr_expr (type, tmp);
2305 /* Length = end + 1 - start. */
2306 gfc_init_se (&end, se);
2307 if (ref->u.ss.end == NULL)
2308 end.expr = se->string_length;
2309 else
2311 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2312 gfc_add_block_to_block (&se->pre, &end.pre);
2314 tmp = end.expr;
2315 STRIP_NOPS (tmp);
2316 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2317 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2319 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2321 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2322 logical_type_node, start.expr,
2323 end.expr);
2325 /* Check lower bound. */
2326 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2327 start.expr,
2328 build_one_cst (TREE_TYPE (start.expr)));
2329 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2330 logical_type_node, nonempty, fault);
2331 if (name)
2332 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2333 "is less than one", name);
2334 else
2335 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2336 "is less than one");
2337 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2338 fold_convert (long_integer_type_node,
2339 start.expr));
2340 free (msg);
2342 /* Check upper bound. */
2343 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2344 end.expr, se->string_length);
2345 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2346 logical_type_node, nonempty, fault);
2347 if (name)
2348 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2349 "exceeds string length (%%ld)", name);
2350 else
2351 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2352 "exceeds string length (%%ld)");
2353 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2354 fold_convert (long_integer_type_node, end.expr),
2355 fold_convert (long_integer_type_node,
2356 se->string_length));
2357 free (msg);
2360 /* Try to calculate the length from the start and end expressions. */
2361 if (ref->u.ss.end
2362 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2364 HOST_WIDE_INT i_len;
2366 i_len = gfc_mpz_get_hwi (length) + 1;
2367 if (i_len < 0)
2368 i_len = 0;
2370 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2371 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2373 else
2375 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2376 fold_convert (gfc_charlen_type_node, end.expr),
2377 fold_convert (gfc_charlen_type_node, start.expr));
2378 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2379 build_int_cst (gfc_charlen_type_node, 1), tmp);
2380 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2381 tmp, build_int_cst (gfc_charlen_type_node, 0));
2384 se->string_length = tmp;
2388 /* Convert a derived type component reference. */
2390 static void
2391 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2393 gfc_component *c;
2394 tree tmp;
2395 tree decl;
2396 tree field;
2397 tree context;
2399 c = ref->u.c.component;
2401 if (c->backend_decl == NULL_TREE
2402 && ref->u.c.sym != NULL)
2403 gfc_get_derived_type (ref->u.c.sym);
2405 field = c->backend_decl;
2406 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2407 decl = se->expr;
2408 context = DECL_FIELD_CONTEXT (field);
2410 /* Components can correspond to fields of different containing
2411 types, as components are created without context, whereas
2412 a concrete use of a component has the type of decl as context.
2413 So, if the type doesn't match, we search the corresponding
2414 FIELD_DECL in the parent type. To not waste too much time
2415 we cache this result in norestrict_decl.
2416 On the other hand, if the context is a UNION or a MAP (a
2417 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2419 if (context != TREE_TYPE (decl)
2420 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2421 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2423 tree f2 = c->norestrict_decl;
2424 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2425 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2426 if (TREE_CODE (f2) == FIELD_DECL
2427 && DECL_NAME (f2) == DECL_NAME (field))
2428 break;
2429 gcc_assert (f2);
2430 c->norestrict_decl = f2;
2431 field = f2;
2434 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2435 && strcmp ("_data", c->name) == 0)
2437 /* Found a ref to the _data component. Store the associated ref to
2438 the vptr in se->class_vptr. */
2439 se->class_vptr = gfc_class_vptr_get (decl);
2441 else
2442 se->class_vptr = NULL_TREE;
2444 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2445 decl, field, NULL_TREE);
2447 se->expr = tmp;
2449 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2450 strlen () conditional below. */
2451 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2452 && !(c->attr.allocatable && c->ts.deferred)
2453 && !c->attr.pdt_string)
2455 tmp = c->ts.u.cl->backend_decl;
2456 /* Components must always be constant length. */
2457 gcc_assert (tmp && INTEGER_CST_P (tmp));
2458 se->string_length = tmp;
2461 if (gfc_deferred_strlen (c, &field))
2463 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2464 TREE_TYPE (field),
2465 decl, field, NULL_TREE);
2466 se->string_length = tmp;
2469 if (((c->attr.pointer || c->attr.allocatable)
2470 && (!c->attr.dimension && !c->attr.codimension)
2471 && c->ts.type != BT_CHARACTER)
2472 || c->attr.proc_pointer)
2473 se->expr = build_fold_indirect_ref_loc (input_location,
2474 se->expr);
2478 /* This function deals with component references to components of the
2479 parent type for derived type extensions. */
2480 static void
2481 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2483 gfc_component *c;
2484 gfc_component *cmp;
2485 gfc_symbol *dt;
2486 gfc_ref parent;
2488 dt = ref->u.c.sym;
2489 c = ref->u.c.component;
2491 /* Return if the component is in the parent type. */
2492 for (cmp = dt->components; cmp; cmp = cmp->next)
2493 if (strcmp (c->name, cmp->name) == 0)
2494 return;
2496 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2497 parent.type = REF_COMPONENT;
2498 parent.next = NULL;
2499 parent.u.c.sym = dt;
2500 parent.u.c.component = dt->components;
2502 if (dt->backend_decl == NULL)
2503 gfc_get_derived_type (dt);
2505 /* Build the reference and call self. */
2506 gfc_conv_component_ref (se, &parent);
2507 parent.u.c.sym = dt->components->ts.u.derived;
2508 parent.u.c.component = c;
2509 conv_parent_component_references (se, &parent);
2512 /* Return the contents of a variable. Also handles reference/pointer
2513 variables (all Fortran pointer references are implicit). */
2515 static void
2516 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2518 gfc_ss *ss;
2519 gfc_ref *ref;
2520 gfc_symbol *sym;
2521 tree parent_decl = NULL_TREE;
2522 int parent_flag;
2523 bool return_value;
2524 bool alternate_entry;
2525 bool entry_master;
2526 bool is_classarray;
2527 bool first_time = true;
2529 sym = expr->symtree->n.sym;
2530 is_classarray = IS_CLASS_ARRAY (sym);
2531 ss = se->ss;
2532 if (ss != NULL)
2534 gfc_ss_info *ss_info = ss->info;
2536 /* Check that something hasn't gone horribly wrong. */
2537 gcc_assert (ss != gfc_ss_terminator);
2538 gcc_assert (ss_info->expr == expr);
2540 /* A scalarized term. We already know the descriptor. */
2541 se->expr = ss_info->data.array.descriptor;
2542 se->string_length = ss_info->string_length;
2543 ref = ss_info->data.array.ref;
2544 if (ref)
2545 gcc_assert (ref->type == REF_ARRAY
2546 && ref->u.ar.type != AR_ELEMENT);
2547 else
2548 gfc_conv_tmp_array_ref (se);
2550 else
2552 tree se_expr = NULL_TREE;
2554 se->expr = gfc_get_symbol_decl (sym);
2556 /* Deal with references to a parent results or entries by storing
2557 the current_function_decl and moving to the parent_decl. */
2558 return_value = sym->attr.function && sym->result == sym;
2559 alternate_entry = sym->attr.function && sym->attr.entry
2560 && sym->result == sym;
2561 entry_master = sym->attr.result
2562 && sym->ns->proc_name->attr.entry_master
2563 && !gfc_return_by_reference (sym->ns->proc_name);
2564 if (current_function_decl)
2565 parent_decl = DECL_CONTEXT (current_function_decl);
2567 if ((se->expr == parent_decl && return_value)
2568 || (sym->ns && sym->ns->proc_name
2569 && parent_decl
2570 && sym->ns->proc_name->backend_decl == parent_decl
2571 && (alternate_entry || entry_master)))
2572 parent_flag = 1;
2573 else
2574 parent_flag = 0;
2576 /* Special case for assigning the return value of a function.
2577 Self recursive functions must have an explicit return value. */
2578 if (return_value && (se->expr == current_function_decl || parent_flag))
2579 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2581 /* Similarly for alternate entry points. */
2582 else if (alternate_entry
2583 && (sym->ns->proc_name->backend_decl == current_function_decl
2584 || parent_flag))
2586 gfc_entry_list *el = NULL;
2588 for (el = sym->ns->entries; el; el = el->next)
2589 if (sym == el->sym)
2591 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2592 break;
2596 else if (entry_master
2597 && (sym->ns->proc_name->backend_decl == current_function_decl
2598 || parent_flag))
2599 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2601 if (se_expr)
2602 se->expr = se_expr;
2604 /* Procedure actual arguments. Look out for temporary variables
2605 with the same attributes as function values. */
2606 else if (!sym->attr.temporary
2607 && sym->attr.flavor == FL_PROCEDURE
2608 && se->expr != current_function_decl)
2610 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2612 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2613 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2615 return;
2619 /* Dereference the expression, where needed. Since characters
2620 are entirely different from other types, they are treated
2621 separately. */
2622 if (sym->ts.type == BT_CHARACTER)
2624 /* Dereference character pointer dummy arguments
2625 or results. */
2626 if ((sym->attr.pointer || sym->attr.allocatable)
2627 && (sym->attr.dummy
2628 || sym->attr.function
2629 || sym->attr.result))
2630 se->expr = build_fold_indirect_ref_loc (input_location,
2631 se->expr);
2634 else if (!sym->attr.value)
2636 /* Dereference temporaries for class array dummy arguments. */
2637 if (sym->attr.dummy && is_classarray
2638 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2640 if (!se->descriptor_only)
2641 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2643 se->expr = build_fold_indirect_ref_loc (input_location,
2644 se->expr);
2647 /* Dereference non-character scalar dummy arguments. */
2648 if (sym->attr.dummy && !sym->attr.dimension
2649 && !(sym->attr.codimension && sym->attr.allocatable)
2650 && (sym->ts.type != BT_CLASS
2651 || (!CLASS_DATA (sym)->attr.dimension
2652 && !(CLASS_DATA (sym)->attr.codimension
2653 && CLASS_DATA (sym)->attr.allocatable))))
2654 se->expr = build_fold_indirect_ref_loc (input_location,
2655 se->expr);
2657 /* Dereference scalar hidden result. */
2658 if (flag_f2c && sym->ts.type == BT_COMPLEX
2659 && (sym->attr.function || sym->attr.result)
2660 && !sym->attr.dimension && !sym->attr.pointer
2661 && !sym->attr.always_explicit)
2662 se->expr = build_fold_indirect_ref_loc (input_location,
2663 se->expr);
2665 /* Dereference non-character, non-class pointer variables.
2666 These must be dummies, results, or scalars. */
2667 if (!is_classarray
2668 && (sym->attr.pointer || sym->attr.allocatable
2669 || gfc_is_associate_pointer (sym)
2670 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2671 && (sym->attr.dummy
2672 || sym->attr.function
2673 || sym->attr.result
2674 || (!sym->attr.dimension
2675 && (!sym->attr.codimension || !sym->attr.allocatable))))
2676 se->expr = build_fold_indirect_ref_loc (input_location,
2677 se->expr);
2678 /* Now treat the class array pointer variables accordingly. */
2679 else if (sym->ts.type == BT_CLASS
2680 && sym->attr.dummy
2681 && (CLASS_DATA (sym)->attr.dimension
2682 || CLASS_DATA (sym)->attr.codimension)
2683 && ((CLASS_DATA (sym)->as
2684 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2685 || CLASS_DATA (sym)->attr.allocatable
2686 || CLASS_DATA (sym)->attr.class_pointer))
2687 se->expr = build_fold_indirect_ref_loc (input_location,
2688 se->expr);
2689 /* And the case where a non-dummy, non-result, non-function,
2690 non-allotable and non-pointer classarray is present. This case was
2691 previously covered by the first if, but with introducing the
2692 condition !is_classarray there, that case has to be covered
2693 explicitly. */
2694 else if (sym->ts.type == BT_CLASS
2695 && !sym->attr.dummy
2696 && !sym->attr.function
2697 && !sym->attr.result
2698 && (CLASS_DATA (sym)->attr.dimension
2699 || CLASS_DATA (sym)->attr.codimension)
2700 && (sym->assoc
2701 || !CLASS_DATA (sym)->attr.allocatable)
2702 && !CLASS_DATA (sym)->attr.class_pointer)
2703 se->expr = build_fold_indirect_ref_loc (input_location,
2704 se->expr);
2707 ref = expr->ref;
2710 /* For character variables, also get the length. */
2711 if (sym->ts.type == BT_CHARACTER)
2713 /* If the character length of an entry isn't set, get the length from
2714 the master function instead. */
2715 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2716 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2717 else
2718 se->string_length = sym->ts.u.cl->backend_decl;
2719 gcc_assert (se->string_length);
2722 while (ref)
2724 switch (ref->type)
2726 case REF_ARRAY:
2727 /* Return the descriptor if that's what we want and this is an array
2728 section reference. */
2729 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2730 return;
2731 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2732 /* Return the descriptor for array pointers and allocations. */
2733 if (se->want_pointer
2734 && ref->next == NULL && (se->descriptor_only))
2735 return;
2737 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2738 /* Return a pointer to an element. */
2739 break;
2741 case REF_COMPONENT:
2742 if (first_time && is_classarray && sym->attr.dummy
2743 && se->descriptor_only
2744 && !CLASS_DATA (sym)->attr.allocatable
2745 && !CLASS_DATA (sym)->attr.class_pointer
2746 && CLASS_DATA (sym)->as
2747 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2748 && strcmp ("_data", ref->u.c.component->name) == 0)
2749 /* Skip the first ref of a _data component, because for class
2750 arrays that one is already done by introducing a temporary
2751 array descriptor. */
2752 break;
2754 if (ref->u.c.sym->attr.extension)
2755 conv_parent_component_references (se, ref);
2757 gfc_conv_component_ref (se, ref);
2758 if (!ref->next && ref->u.c.sym->attr.codimension
2759 && se->want_pointer && se->descriptor_only)
2760 return;
2762 break;
2764 case REF_SUBSTRING:
2765 gfc_conv_substring (se, ref, expr->ts.kind,
2766 expr->symtree->name, &expr->where);
2767 break;
2769 default:
2770 gcc_unreachable ();
2771 break;
2773 first_time = false;
2774 ref = ref->next;
2776 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2777 separately. */
2778 if (se->want_pointer)
2780 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2781 gfc_conv_string_parameter (se);
2782 else
2783 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2788 /* Unary ops are easy... Or they would be if ! was a valid op. */
2790 static void
2791 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2793 gfc_se operand;
2794 tree type;
2796 gcc_assert (expr->ts.type != BT_CHARACTER);
2797 /* Initialize the operand. */
2798 gfc_init_se (&operand, se);
2799 gfc_conv_expr_val (&operand, expr->value.op.op1);
2800 gfc_add_block_to_block (&se->pre, &operand.pre);
2802 type = gfc_typenode_for_spec (&expr->ts);
2804 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2805 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2806 All other unary operators have an equivalent GIMPLE unary operator. */
2807 if (code == TRUTH_NOT_EXPR)
2808 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2809 build_int_cst (type, 0));
2810 else
2811 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2815 /* Expand power operator to optimal multiplications when a value is raised
2816 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2817 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2818 Programming", 3rd Edition, 1998. */
2820 /* This code is mostly duplicated from expand_powi in the backend.
2821 We establish the "optimal power tree" lookup table with the defined size.
2822 The items in the table are the exponents used to calculate the index
2823 exponents. Any integer n less than the value can get an "addition chain",
2824 with the first node being one. */
2825 #define POWI_TABLE_SIZE 256
2827 /* The table is from builtins.c. */
2828 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2830 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2831 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2832 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2833 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2834 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2835 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2836 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2837 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2838 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2839 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2840 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2841 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2842 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2843 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2844 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2845 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2846 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2847 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2848 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2849 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2850 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2851 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2852 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2853 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2854 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2855 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2856 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2857 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2858 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2859 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2860 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2861 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2864 /* If n is larger than lookup table's max index, we use the "window
2865 method". */
2866 #define POWI_WINDOW_SIZE 3
2868 /* Recursive function to expand the power operator. The temporary
2869 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2870 static tree
2871 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2873 tree op0;
2874 tree op1;
2875 tree tmp;
2876 int digit;
2878 if (n < POWI_TABLE_SIZE)
2880 if (tmpvar[n])
2881 return tmpvar[n];
2883 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2884 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2886 else if (n & 1)
2888 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2889 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2890 op1 = gfc_conv_powi (se, digit, tmpvar);
2892 else
2894 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2895 op1 = op0;
2898 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2899 tmp = gfc_evaluate_now (tmp, &se->pre);
2901 if (n < POWI_TABLE_SIZE)
2902 tmpvar[n] = tmp;
2904 return tmp;
2908 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2909 return 1. Else return 0 and a call to runtime library functions
2910 will have to be built. */
2911 static int
2912 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2914 tree cond;
2915 tree tmp;
2916 tree type;
2917 tree vartmp[POWI_TABLE_SIZE];
2918 HOST_WIDE_INT m;
2919 unsigned HOST_WIDE_INT n;
2920 int sgn;
2921 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2923 /* If exponent is too large, we won't expand it anyway, so don't bother
2924 with large integer values. */
2925 if (!wi::fits_shwi_p (wrhs))
2926 return 0;
2928 m = wrhs.to_shwi ();
2929 /* Use the wide_int's routine to reliably get the absolute value on all
2930 platforms. Then convert it to a HOST_WIDE_INT like above. */
2931 n = wi::abs (wrhs).to_shwi ();
2933 type = TREE_TYPE (lhs);
2934 sgn = tree_int_cst_sgn (rhs);
2936 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2937 || optimize_size) && (m > 2 || m < -1))
2938 return 0;
2940 /* rhs == 0 */
2941 if (sgn == 0)
2943 se->expr = gfc_build_const (type, integer_one_node);
2944 return 1;
2947 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2948 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2950 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2951 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2952 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2953 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2955 /* If rhs is even,
2956 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2957 if ((n & 1) == 0)
2959 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2960 logical_type_node, tmp, cond);
2961 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2962 tmp, build_int_cst (type, 1),
2963 build_int_cst (type, 0));
2964 return 1;
2966 /* If rhs is odd,
2967 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2968 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
2969 build_int_cst (type, -1),
2970 build_int_cst (type, 0));
2971 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2972 cond, build_int_cst (type, 1), tmp);
2973 return 1;
2976 memset (vartmp, 0, sizeof (vartmp));
2977 vartmp[1] = lhs;
2978 if (sgn == -1)
2980 tmp = gfc_build_const (type, integer_one_node);
2981 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
2982 vartmp[1]);
2985 se->expr = gfc_conv_powi (se, n, vartmp);
2987 return 1;
2991 /* Power op (**). Constant integer exponent has special handling. */
2993 static void
2994 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
2996 tree gfc_int4_type_node;
2997 int kind;
2998 int ikind;
2999 int res_ikind_1, res_ikind_2;
3000 gfc_se lse;
3001 gfc_se rse;
3002 tree fndecl = NULL;
3004 gfc_init_se (&lse, se);
3005 gfc_conv_expr_val (&lse, expr->value.op.op1);
3006 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3007 gfc_add_block_to_block (&se->pre, &lse.pre);
3009 gfc_init_se (&rse, se);
3010 gfc_conv_expr_val (&rse, expr->value.op.op2);
3011 gfc_add_block_to_block (&se->pre, &rse.pre);
3013 if (expr->value.op.op2->ts.type == BT_INTEGER
3014 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3015 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3016 return;
3018 gfc_int4_type_node = gfc_get_int_type (4);
3020 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3021 library routine. But in the end, we have to convert the result back
3022 if this case applies -- with res_ikind_K, we keep track whether operand K
3023 falls into this case. */
3024 res_ikind_1 = -1;
3025 res_ikind_2 = -1;
3027 kind = expr->value.op.op1->ts.kind;
3028 switch (expr->value.op.op2->ts.type)
3030 case BT_INTEGER:
3031 ikind = expr->value.op.op2->ts.kind;
3032 switch (ikind)
3034 case 1:
3035 case 2:
3036 rse.expr = convert (gfc_int4_type_node, rse.expr);
3037 res_ikind_2 = ikind;
3038 /* Fall through. */
3040 case 4:
3041 ikind = 0;
3042 break;
3044 case 8:
3045 ikind = 1;
3046 break;
3048 case 16:
3049 ikind = 2;
3050 break;
3052 default:
3053 gcc_unreachable ();
3055 switch (kind)
3057 case 1:
3058 case 2:
3059 if (expr->value.op.op1->ts.type == BT_INTEGER)
3061 lse.expr = convert (gfc_int4_type_node, lse.expr);
3062 res_ikind_1 = kind;
3064 else
3065 gcc_unreachable ();
3066 /* Fall through. */
3068 case 4:
3069 kind = 0;
3070 break;
3072 case 8:
3073 kind = 1;
3074 break;
3076 case 10:
3077 kind = 2;
3078 break;
3080 case 16:
3081 kind = 3;
3082 break;
3084 default:
3085 gcc_unreachable ();
3088 switch (expr->value.op.op1->ts.type)
3090 case BT_INTEGER:
3091 if (kind == 3) /* Case 16 was not handled properly above. */
3092 kind = 2;
3093 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3094 break;
3096 case BT_REAL:
3097 /* Use builtins for real ** int4. */
3098 if (ikind == 0)
3100 switch (kind)
3102 case 0:
3103 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3104 break;
3106 case 1:
3107 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3108 break;
3110 case 2:
3111 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3112 break;
3114 case 3:
3115 /* Use the __builtin_powil() only if real(kind=16) is
3116 actually the C long double type. */
3117 if (!gfc_real16_is_float128)
3118 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3119 break;
3121 default:
3122 gcc_unreachable ();
3126 /* If we don't have a good builtin for this, go for the
3127 library function. */
3128 if (!fndecl)
3129 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3130 break;
3132 case BT_COMPLEX:
3133 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3134 break;
3136 default:
3137 gcc_unreachable ();
3139 break;
3141 case BT_REAL:
3142 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3143 break;
3145 case BT_COMPLEX:
3146 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3147 break;
3149 default:
3150 gcc_unreachable ();
3151 break;
3154 se->expr = build_call_expr_loc (input_location,
3155 fndecl, 2, lse.expr, rse.expr);
3157 /* Convert the result back if it is of wrong integer kind. */
3158 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3160 /* We want the maximum of both operand kinds as result. */
3161 if (res_ikind_1 < res_ikind_2)
3162 res_ikind_1 = res_ikind_2;
3163 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3168 /* Generate code to allocate a string temporary. */
3170 tree
3171 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3173 tree var;
3174 tree tmp;
3176 if (gfc_can_put_var_on_stack (len))
3178 /* Create a temporary variable to hold the result. */
3179 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3180 TREE_TYPE (len), len,
3181 build_int_cst (TREE_TYPE (len), 1));
3182 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3184 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3185 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3186 else
3187 tmp = build_array_type (TREE_TYPE (type), tmp);
3189 var = gfc_create_var (tmp, "str");
3190 var = gfc_build_addr_expr (type, var);
3192 else
3194 /* Allocate a temporary to hold the result. */
3195 var = gfc_create_var (type, "pstr");
3196 gcc_assert (POINTER_TYPE_P (type));
3197 tmp = TREE_TYPE (type);
3198 if (TREE_CODE (tmp) == ARRAY_TYPE)
3199 tmp = TREE_TYPE (tmp);
3200 tmp = TYPE_SIZE_UNIT (tmp);
3201 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3202 fold_convert (size_type_node, len),
3203 fold_convert (size_type_node, tmp));
3204 tmp = gfc_call_malloc (&se->pre, type, tmp);
3205 gfc_add_modify (&se->pre, var, tmp);
3207 /* Free the temporary afterwards. */
3208 tmp = gfc_call_free (var);
3209 gfc_add_expr_to_block (&se->post, tmp);
3212 return var;
3216 /* Handle a string concatenation operation. A temporary will be allocated to
3217 hold the result. */
3219 static void
3220 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3222 gfc_se lse, rse;
3223 tree len, type, var, tmp, fndecl;
3225 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3226 && expr->value.op.op2->ts.type == BT_CHARACTER);
3227 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3229 gfc_init_se (&lse, se);
3230 gfc_conv_expr (&lse, expr->value.op.op1);
3231 gfc_conv_string_parameter (&lse);
3232 gfc_init_se (&rse, se);
3233 gfc_conv_expr (&rse, expr->value.op.op2);
3234 gfc_conv_string_parameter (&rse);
3236 gfc_add_block_to_block (&se->pre, &lse.pre);
3237 gfc_add_block_to_block (&se->pre, &rse.pre);
3239 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3240 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3241 if (len == NULL_TREE)
3243 len = fold_build2_loc (input_location, PLUS_EXPR,
3244 gfc_charlen_type_node,
3245 fold_convert (gfc_charlen_type_node,
3246 lse.string_length),
3247 fold_convert (gfc_charlen_type_node,
3248 rse.string_length));
3251 type = build_pointer_type (type);
3253 var = gfc_conv_string_tmp (se, type, len);
3255 /* Do the actual concatenation. */
3256 if (expr->ts.kind == 1)
3257 fndecl = gfor_fndecl_concat_string;
3258 else if (expr->ts.kind == 4)
3259 fndecl = gfor_fndecl_concat_string_char4;
3260 else
3261 gcc_unreachable ();
3263 tmp = build_call_expr_loc (input_location,
3264 fndecl, 6, len, var, lse.string_length, lse.expr,
3265 rse.string_length, rse.expr);
3266 gfc_add_expr_to_block (&se->pre, tmp);
3268 /* Add the cleanup for the operands. */
3269 gfc_add_block_to_block (&se->pre, &rse.post);
3270 gfc_add_block_to_block (&se->pre, &lse.post);
3272 se->expr = var;
3273 se->string_length = len;
3276 /* Translates an op expression. Common (binary) cases are handled by this
3277 function, others are passed on. Recursion is used in either case.
3278 We use the fact that (op1.ts == op2.ts) (except for the power
3279 operator **).
3280 Operators need no special handling for scalarized expressions as long as
3281 they call gfc_conv_simple_val to get their operands.
3282 Character strings get special handling. */
3284 static void
3285 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3287 enum tree_code code;
3288 gfc_se lse;
3289 gfc_se rse;
3290 tree tmp, type;
3291 int lop;
3292 int checkstring;
3294 checkstring = 0;
3295 lop = 0;
3296 switch (expr->value.op.op)
3298 case INTRINSIC_PARENTHESES:
3299 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3300 && flag_protect_parens)
3302 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3303 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3304 return;
3307 /* Fallthrough. */
3308 case INTRINSIC_UPLUS:
3309 gfc_conv_expr (se, expr->value.op.op1);
3310 return;
3312 case INTRINSIC_UMINUS:
3313 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3314 return;
3316 case INTRINSIC_NOT:
3317 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3318 return;
3320 case INTRINSIC_PLUS:
3321 code = PLUS_EXPR;
3322 break;
3324 case INTRINSIC_MINUS:
3325 code = MINUS_EXPR;
3326 break;
3328 case INTRINSIC_TIMES:
3329 code = MULT_EXPR;
3330 break;
3332 case INTRINSIC_DIVIDE:
3333 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3334 an integer, we must round towards zero, so we use a
3335 TRUNC_DIV_EXPR. */
3336 if (expr->ts.type == BT_INTEGER)
3337 code = TRUNC_DIV_EXPR;
3338 else
3339 code = RDIV_EXPR;
3340 break;
3342 case INTRINSIC_POWER:
3343 gfc_conv_power_op (se, expr);
3344 return;
3346 case INTRINSIC_CONCAT:
3347 gfc_conv_concat_op (se, expr);
3348 return;
3350 case INTRINSIC_AND:
3351 code = TRUTH_ANDIF_EXPR;
3352 lop = 1;
3353 break;
3355 case INTRINSIC_OR:
3356 code = TRUTH_ORIF_EXPR;
3357 lop = 1;
3358 break;
3360 /* EQV and NEQV only work on logicals, but since we represent them
3361 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3362 case INTRINSIC_EQ:
3363 case INTRINSIC_EQ_OS:
3364 case INTRINSIC_EQV:
3365 code = EQ_EXPR;
3366 checkstring = 1;
3367 lop = 1;
3368 break;
3370 case INTRINSIC_NE:
3371 case INTRINSIC_NE_OS:
3372 case INTRINSIC_NEQV:
3373 code = NE_EXPR;
3374 checkstring = 1;
3375 lop = 1;
3376 break;
3378 case INTRINSIC_GT:
3379 case INTRINSIC_GT_OS:
3380 code = GT_EXPR;
3381 checkstring = 1;
3382 lop = 1;
3383 break;
3385 case INTRINSIC_GE:
3386 case INTRINSIC_GE_OS:
3387 code = GE_EXPR;
3388 checkstring = 1;
3389 lop = 1;
3390 break;
3392 case INTRINSIC_LT:
3393 case INTRINSIC_LT_OS:
3394 code = LT_EXPR;
3395 checkstring = 1;
3396 lop = 1;
3397 break;
3399 case INTRINSIC_LE:
3400 case INTRINSIC_LE_OS:
3401 code = LE_EXPR;
3402 checkstring = 1;
3403 lop = 1;
3404 break;
3406 case INTRINSIC_USER:
3407 case INTRINSIC_ASSIGN:
3408 /* These should be converted into function calls by the frontend. */
3409 gcc_unreachable ();
3411 default:
3412 fatal_error (input_location, "Unknown intrinsic op");
3413 return;
3416 /* The only exception to this is **, which is handled separately anyway. */
3417 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3419 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3420 checkstring = 0;
3422 /* lhs */
3423 gfc_init_se (&lse, se);
3424 gfc_conv_expr (&lse, expr->value.op.op1);
3425 gfc_add_block_to_block (&se->pre, &lse.pre);
3427 /* rhs */
3428 gfc_init_se (&rse, se);
3429 gfc_conv_expr (&rse, expr->value.op.op2);
3430 gfc_add_block_to_block (&se->pre, &rse.pre);
3432 if (checkstring)
3434 gfc_conv_string_parameter (&lse);
3435 gfc_conv_string_parameter (&rse);
3437 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3438 rse.string_length, rse.expr,
3439 expr->value.op.op1->ts.kind,
3440 code);
3441 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3442 gfc_add_block_to_block (&lse.post, &rse.post);
3445 type = gfc_typenode_for_spec (&expr->ts);
3447 if (lop)
3449 /* The result of logical ops is always logical_type_node. */
3450 tmp = fold_build2_loc (input_location, code, logical_type_node,
3451 lse.expr, rse.expr);
3452 se->expr = convert (type, tmp);
3454 else
3455 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3457 /* Add the post blocks. */
3458 gfc_add_block_to_block (&se->post, &rse.post);
3459 gfc_add_block_to_block (&se->post, &lse.post);
3462 /* If a string's length is one, we convert it to a single character. */
3464 tree
3465 gfc_string_to_single_character (tree len, tree str, int kind)
3468 if (len == NULL
3469 || !tree_fits_uhwi_p (len)
3470 || !POINTER_TYPE_P (TREE_TYPE (str)))
3471 return NULL_TREE;
3473 if (TREE_INT_CST_LOW (len) == 1)
3475 str = fold_convert (gfc_get_pchar_type (kind), str);
3476 return build_fold_indirect_ref_loc (input_location, str);
3479 if (kind == 1
3480 && TREE_CODE (str) == ADDR_EXPR
3481 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3482 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3483 && array_ref_low_bound (TREE_OPERAND (str, 0))
3484 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3485 && TREE_INT_CST_LOW (len) > 1
3486 && TREE_INT_CST_LOW (len)
3487 == (unsigned HOST_WIDE_INT)
3488 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3490 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3491 ret = build_fold_indirect_ref_loc (input_location, ret);
3492 if (TREE_CODE (ret) == INTEGER_CST)
3494 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3495 int i, length = TREE_STRING_LENGTH (string_cst);
3496 const char *ptr = TREE_STRING_POINTER (string_cst);
3498 for (i = 1; i < length; i++)
3499 if (ptr[i] != ' ')
3500 return NULL_TREE;
3502 return ret;
3506 return NULL_TREE;
3510 void
3511 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3514 if (sym->backend_decl)
3516 /* This becomes the nominal_type in
3517 function.c:assign_parm_find_data_types. */
3518 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3519 /* This becomes the passed_type in
3520 function.c:assign_parm_find_data_types. C promotes char to
3521 integer for argument passing. */
3522 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3524 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3527 if (expr != NULL)
3529 /* If we have a constant character expression, make it into an
3530 integer. */
3531 if ((*expr)->expr_type == EXPR_CONSTANT)
3533 gfc_typespec ts;
3534 gfc_clear_ts (&ts);
3536 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3537 (int)(*expr)->value.character.string[0]);
3538 if ((*expr)->ts.kind != gfc_c_int_kind)
3540 /* The expr needs to be compatible with a C int. If the
3541 conversion fails, then the 2 causes an ICE. */
3542 ts.type = BT_INTEGER;
3543 ts.kind = gfc_c_int_kind;
3544 gfc_convert_type (*expr, &ts, 2);
3547 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3549 if ((*expr)->ref == NULL)
3551 se->expr = gfc_string_to_single_character
3552 (build_int_cst (integer_type_node, 1),
3553 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3554 gfc_get_symbol_decl
3555 ((*expr)->symtree->n.sym)),
3556 (*expr)->ts.kind);
3558 else
3560 gfc_conv_variable (se, *expr);
3561 se->expr = gfc_string_to_single_character
3562 (build_int_cst (integer_type_node, 1),
3563 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3564 se->expr),
3565 (*expr)->ts.kind);
3571 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3572 if STR is a string literal, otherwise return -1. */
3574 static int
3575 gfc_optimize_len_trim (tree len, tree str, int kind)
3577 if (kind == 1
3578 && TREE_CODE (str) == ADDR_EXPR
3579 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3580 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3581 && array_ref_low_bound (TREE_OPERAND (str, 0))
3582 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3583 && tree_fits_uhwi_p (len)
3584 && tree_to_uhwi (len) >= 1
3585 && tree_to_uhwi (len)
3586 == (unsigned HOST_WIDE_INT)
3587 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3589 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3590 folded = build_fold_indirect_ref_loc (input_location, folded);
3591 if (TREE_CODE (folded) == INTEGER_CST)
3593 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3594 int length = TREE_STRING_LENGTH (string_cst);
3595 const char *ptr = TREE_STRING_POINTER (string_cst);
3597 for (; length > 0; length--)
3598 if (ptr[length - 1] != ' ')
3599 break;
3601 return length;
3604 return -1;
3607 /* Helper to build a call to memcmp. */
3609 static tree
3610 build_memcmp_call (tree s1, tree s2, tree n)
3612 tree tmp;
3614 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3615 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3616 else
3617 s1 = fold_convert (pvoid_type_node, s1);
3619 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3620 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3621 else
3622 s2 = fold_convert (pvoid_type_node, s2);
3624 n = fold_convert (size_type_node, n);
3626 tmp = build_call_expr_loc (input_location,
3627 builtin_decl_explicit (BUILT_IN_MEMCMP),
3628 3, s1, s2, n);
3630 return fold_convert (integer_type_node, tmp);
3633 /* Compare two strings. If they are all single characters, the result is the
3634 subtraction of them. Otherwise, we build a library call. */
3636 tree
3637 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3638 enum tree_code code)
3640 tree sc1;
3641 tree sc2;
3642 tree fndecl;
3644 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3645 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3647 sc1 = gfc_string_to_single_character (len1, str1, kind);
3648 sc2 = gfc_string_to_single_character (len2, str2, kind);
3650 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3652 /* Deal with single character specially. */
3653 sc1 = fold_convert (integer_type_node, sc1);
3654 sc2 = fold_convert (integer_type_node, sc2);
3655 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3656 sc1, sc2);
3659 if ((code == EQ_EXPR || code == NE_EXPR)
3660 && optimize
3661 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3663 /* If one string is a string literal with LEN_TRIM longer
3664 than the length of the second string, the strings
3665 compare unequal. */
3666 int len = gfc_optimize_len_trim (len1, str1, kind);
3667 if (len > 0 && compare_tree_int (len2, len) < 0)
3668 return integer_one_node;
3669 len = gfc_optimize_len_trim (len2, str2, kind);
3670 if (len > 0 && compare_tree_int (len1, len) < 0)
3671 return integer_one_node;
3674 /* We can compare via memcpy if the strings are known to be equal
3675 in length and they are
3676 - kind=1
3677 - kind=4 and the comparison is for (in)equality. */
3679 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3680 && tree_int_cst_equal (len1, len2)
3681 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3683 tree tmp;
3684 tree chartype;
3686 chartype = gfc_get_char_type (kind);
3687 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3688 fold_convert (TREE_TYPE(len1),
3689 TYPE_SIZE_UNIT(chartype)),
3690 len1);
3691 return build_memcmp_call (str1, str2, tmp);
3694 /* Build a call for the comparison. */
3695 if (kind == 1)
3696 fndecl = gfor_fndecl_compare_string;
3697 else if (kind == 4)
3698 fndecl = gfor_fndecl_compare_string_char4;
3699 else
3700 gcc_unreachable ();
3702 return build_call_expr_loc (input_location, fndecl, 4,
3703 len1, str1, len2, str2);
3707 /* Return the backend_decl for a procedure pointer component. */
3709 static tree
3710 get_proc_ptr_comp (gfc_expr *e)
3712 gfc_se comp_se;
3713 gfc_expr *e2;
3714 expr_t old_type;
3716 gfc_init_se (&comp_se, NULL);
3717 e2 = gfc_copy_expr (e);
3718 /* We have to restore the expr type later so that gfc_free_expr frees
3719 the exact same thing that was allocated.
3720 TODO: This is ugly. */
3721 old_type = e2->expr_type;
3722 e2->expr_type = EXPR_VARIABLE;
3723 gfc_conv_expr (&comp_se, e2);
3724 e2->expr_type = old_type;
3725 gfc_free_expr (e2);
3726 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3730 /* Convert a typebound function reference from a class object. */
3731 static void
3732 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3734 gfc_ref *ref;
3735 tree var;
3737 if (!VAR_P (base_object))
3739 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3740 gfc_add_modify (&se->pre, var, base_object);
3742 se->expr = gfc_class_vptr_get (base_object);
3743 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3744 ref = expr->ref;
3745 while (ref && ref->next)
3746 ref = ref->next;
3747 gcc_assert (ref && ref->type == REF_COMPONENT);
3748 if (ref->u.c.sym->attr.extension)
3749 conv_parent_component_references (se, ref);
3750 gfc_conv_component_ref (se, ref);
3751 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3755 static void
3756 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3758 tree tmp;
3760 if (gfc_is_proc_ptr_comp (expr))
3761 tmp = get_proc_ptr_comp (expr);
3762 else if (sym->attr.dummy)
3764 tmp = gfc_get_symbol_decl (sym);
3765 if (sym->attr.proc_pointer)
3766 tmp = build_fold_indirect_ref_loc (input_location,
3767 tmp);
3768 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3769 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3771 else
3773 if (!sym->backend_decl)
3774 sym->backend_decl = gfc_get_extern_function_decl (sym);
3776 TREE_USED (sym->backend_decl) = 1;
3778 tmp = sym->backend_decl;
3780 if (sym->attr.cray_pointee)
3782 /* TODO - make the cray pointee a pointer to a procedure,
3783 assign the pointer to it and use it for the call. This
3784 will do for now! */
3785 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3786 gfc_get_symbol_decl (sym->cp_pointer));
3787 tmp = gfc_evaluate_now (tmp, &se->pre);
3790 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3792 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3793 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3796 se->expr = tmp;
3800 /* Initialize MAPPING. */
3802 void
3803 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3805 mapping->syms = NULL;
3806 mapping->charlens = NULL;
3810 /* Free all memory held by MAPPING (but not MAPPING itself). */
3812 void
3813 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3815 gfc_interface_sym_mapping *sym;
3816 gfc_interface_sym_mapping *nextsym;
3817 gfc_charlen *cl;
3818 gfc_charlen *nextcl;
3820 for (sym = mapping->syms; sym; sym = nextsym)
3822 nextsym = sym->next;
3823 sym->new_sym->n.sym->formal = NULL;
3824 gfc_free_symbol (sym->new_sym->n.sym);
3825 gfc_free_expr (sym->expr);
3826 free (sym->new_sym);
3827 free (sym);
3829 for (cl = mapping->charlens; cl; cl = nextcl)
3831 nextcl = cl->next;
3832 gfc_free_expr (cl->length);
3833 free (cl);
3838 /* Return a copy of gfc_charlen CL. Add the returned structure to
3839 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3841 static gfc_charlen *
3842 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3843 gfc_charlen * cl)
3845 gfc_charlen *new_charlen;
3847 new_charlen = gfc_get_charlen ();
3848 new_charlen->next = mapping->charlens;
3849 new_charlen->length = gfc_copy_expr (cl->length);
3851 mapping->charlens = new_charlen;
3852 return new_charlen;
3856 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3857 array variable that can be used as the actual argument for dummy
3858 argument SYM. Add any initialization code to BLOCK. PACKED is as
3859 for gfc_get_nodesc_array_type and DATA points to the first element
3860 in the passed array. */
3862 static tree
3863 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3864 gfc_packed packed, tree data)
3866 tree type;
3867 tree var;
3869 type = gfc_typenode_for_spec (&sym->ts);
3870 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3871 !sym->attr.target && !sym->attr.pointer
3872 && !sym->attr.proc_pointer);
3874 var = gfc_create_var (type, "ifm");
3875 gfc_add_modify (block, var, fold_convert (type, data));
3877 return var;
3881 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3882 and offset of descriptorless array type TYPE given that it has the same
3883 size as DESC. Add any set-up code to BLOCK. */
3885 static void
3886 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
3888 int n;
3889 tree dim;
3890 tree offset;
3891 tree tmp;
3893 offset = gfc_index_zero_node;
3894 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
3896 dim = gfc_rank_cst[n];
3897 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
3898 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
3900 GFC_TYPE_ARRAY_LBOUND (type, n)
3901 = gfc_conv_descriptor_lbound_get (desc, dim);
3902 GFC_TYPE_ARRAY_UBOUND (type, n)
3903 = gfc_conv_descriptor_ubound_get (desc, dim);
3905 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
3907 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3908 gfc_array_index_type,
3909 gfc_conv_descriptor_ubound_get (desc, dim),
3910 gfc_conv_descriptor_lbound_get (desc, dim));
3911 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3912 gfc_array_index_type,
3913 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
3914 tmp = gfc_evaluate_now (tmp, block);
3915 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
3917 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3918 GFC_TYPE_ARRAY_LBOUND (type, n),
3919 GFC_TYPE_ARRAY_STRIDE (type, n));
3920 offset = fold_build2_loc (input_location, MINUS_EXPR,
3921 gfc_array_index_type, offset, tmp);
3923 offset = gfc_evaluate_now (offset, block);
3924 GFC_TYPE_ARRAY_OFFSET (type) = offset;
3928 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3929 in SE. The caller may still use se->expr and se->string_length after
3930 calling this function. */
3932 void
3933 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
3934 gfc_symbol * sym, gfc_se * se,
3935 gfc_expr *expr)
3937 gfc_interface_sym_mapping *sm;
3938 tree desc;
3939 tree tmp;
3940 tree value;
3941 gfc_symbol *new_sym;
3942 gfc_symtree *root;
3943 gfc_symtree *new_symtree;
3945 /* Create a new symbol to represent the actual argument. */
3946 new_sym = gfc_new_symbol (sym->name, NULL);
3947 new_sym->ts = sym->ts;
3948 new_sym->as = gfc_copy_array_spec (sym->as);
3949 new_sym->attr.referenced = 1;
3950 new_sym->attr.dimension = sym->attr.dimension;
3951 new_sym->attr.contiguous = sym->attr.contiguous;
3952 new_sym->attr.codimension = sym->attr.codimension;
3953 new_sym->attr.pointer = sym->attr.pointer;
3954 new_sym->attr.allocatable = sym->attr.allocatable;
3955 new_sym->attr.flavor = sym->attr.flavor;
3956 new_sym->attr.function = sym->attr.function;
3958 /* Ensure that the interface is available and that
3959 descriptors are passed for array actual arguments. */
3960 if (sym->attr.flavor == FL_PROCEDURE)
3962 new_sym->formal = expr->symtree->n.sym->formal;
3963 new_sym->attr.always_explicit
3964 = expr->symtree->n.sym->attr.always_explicit;
3967 /* Create a fake symtree for it. */
3968 root = NULL;
3969 new_symtree = gfc_new_symtree (&root, sym->name);
3970 new_symtree->n.sym = new_sym;
3971 gcc_assert (new_symtree == root);
3973 /* Create a dummy->actual mapping. */
3974 sm = XCNEW (gfc_interface_sym_mapping);
3975 sm->next = mapping->syms;
3976 sm->old = sym;
3977 sm->new_sym = new_symtree;
3978 sm->expr = gfc_copy_expr (expr);
3979 mapping->syms = sm;
3981 /* Stabilize the argument's value. */
3982 if (!sym->attr.function && se)
3983 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3985 if (sym->ts.type == BT_CHARACTER)
3987 /* Create a copy of the dummy argument's length. */
3988 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
3989 sm->expr->ts.u.cl = new_sym->ts.u.cl;
3991 /* If the length is specified as "*", record the length that
3992 the caller is passing. We should use the callee's length
3993 in all other cases. */
3994 if (!new_sym->ts.u.cl->length && se)
3996 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
3997 new_sym->ts.u.cl->backend_decl = se->string_length;
4001 if (!se)
4002 return;
4004 /* Use the passed value as-is if the argument is a function. */
4005 if (sym->attr.flavor == FL_PROCEDURE)
4006 value = se->expr;
4008 /* If the argument is a pass-by-value scalar, use the value as is. */
4009 else if (!sym->attr.dimension && sym->attr.value)
4010 value = se->expr;
4012 /* If the argument is either a string or a pointer to a string,
4013 convert it to a boundless character type. */
4014 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4016 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4017 tmp = build_pointer_type (tmp);
4018 if (sym->attr.pointer)
4019 value = build_fold_indirect_ref_loc (input_location,
4020 se->expr);
4021 else
4022 value = se->expr;
4023 value = fold_convert (tmp, value);
4026 /* If the argument is a scalar, a pointer to an array or an allocatable,
4027 dereference it. */
4028 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4029 value = build_fold_indirect_ref_loc (input_location,
4030 se->expr);
4032 /* For character(*), use the actual argument's descriptor. */
4033 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4034 value = build_fold_indirect_ref_loc (input_location,
4035 se->expr);
4037 /* If the argument is an array descriptor, use it to determine
4038 information about the actual argument's shape. */
4039 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4040 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4042 /* Get the actual argument's descriptor. */
4043 desc = build_fold_indirect_ref_loc (input_location,
4044 se->expr);
4046 /* Create the replacement variable. */
4047 tmp = gfc_conv_descriptor_data_get (desc);
4048 value = gfc_get_interface_mapping_array (&se->pre, sym,
4049 PACKED_NO, tmp);
4051 /* Use DESC to work out the upper bounds, strides and offset. */
4052 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4054 else
4055 /* Otherwise we have a packed array. */
4056 value = gfc_get_interface_mapping_array (&se->pre, sym,
4057 PACKED_FULL, se->expr);
4059 new_sym->backend_decl = value;
4063 /* Called once all dummy argument mappings have been added to MAPPING,
4064 but before the mapping is used to evaluate expressions. Pre-evaluate
4065 the length of each argument, adding any initialization code to PRE and
4066 any finalization code to POST. */
4068 void
4069 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4070 stmtblock_t * pre, stmtblock_t * post)
4072 gfc_interface_sym_mapping *sym;
4073 gfc_expr *expr;
4074 gfc_se se;
4076 for (sym = mapping->syms; sym; sym = sym->next)
4077 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4078 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4080 expr = sym->new_sym->n.sym->ts.u.cl->length;
4081 gfc_apply_interface_mapping_to_expr (mapping, expr);
4082 gfc_init_se (&se, NULL);
4083 gfc_conv_expr (&se, expr);
4084 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4085 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4086 gfc_add_block_to_block (pre, &se.pre);
4087 gfc_add_block_to_block (post, &se.post);
4089 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4094 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4095 constructor C. */
4097 static void
4098 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4099 gfc_constructor_base base)
4101 gfc_constructor *c;
4102 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4104 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4105 if (c->iterator)
4107 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4108 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4109 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4115 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4116 reference REF. */
4118 static void
4119 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4120 gfc_ref * ref)
4122 int n;
4124 for (; ref; ref = ref->next)
4125 switch (ref->type)
4127 case REF_ARRAY:
4128 for (n = 0; n < ref->u.ar.dimen; n++)
4130 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4131 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4132 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4134 break;
4136 case REF_COMPONENT:
4137 break;
4139 case REF_SUBSTRING:
4140 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4141 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4142 break;
4147 /* Convert intrinsic function calls into result expressions. */
4149 static bool
4150 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4152 gfc_symbol *sym;
4153 gfc_expr *new_expr;
4154 gfc_expr *arg1;
4155 gfc_expr *arg2;
4156 int d, dup;
4158 arg1 = expr->value.function.actual->expr;
4159 if (expr->value.function.actual->next)
4160 arg2 = expr->value.function.actual->next->expr;
4161 else
4162 arg2 = NULL;
4164 sym = arg1->symtree->n.sym;
4166 if (sym->attr.dummy)
4167 return false;
4169 new_expr = NULL;
4171 switch (expr->value.function.isym->id)
4173 case GFC_ISYM_LEN:
4174 /* TODO figure out why this condition is necessary. */
4175 if (sym->attr.function
4176 && (arg1->ts.u.cl->length == NULL
4177 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4178 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4179 return false;
4181 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4182 break;
4184 case GFC_ISYM_LEN_TRIM:
4185 new_expr = gfc_copy_expr (arg1);
4186 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4188 if (!new_expr)
4189 return false;
4191 gfc_replace_expr (arg1, new_expr);
4192 return true;
4194 case GFC_ISYM_SIZE:
4195 if (!sym->as || sym->as->rank == 0)
4196 return false;
4198 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4200 dup = mpz_get_si (arg2->value.integer);
4201 d = dup - 1;
4203 else
4205 dup = sym->as->rank;
4206 d = 0;
4209 for (; d < dup; d++)
4211 gfc_expr *tmp;
4213 if (!sym->as->upper[d] || !sym->as->lower[d])
4215 gfc_free_expr (new_expr);
4216 return false;
4219 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4220 gfc_get_int_expr (gfc_default_integer_kind,
4221 NULL, 1));
4222 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4223 if (new_expr)
4224 new_expr = gfc_multiply (new_expr, tmp);
4225 else
4226 new_expr = tmp;
4228 break;
4230 case GFC_ISYM_LBOUND:
4231 case GFC_ISYM_UBOUND:
4232 /* TODO These implementations of lbound and ubound do not limit if
4233 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4235 if (!sym->as || sym->as->rank == 0)
4236 return false;
4238 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4239 d = mpz_get_si (arg2->value.integer) - 1;
4240 else
4241 return false;
4243 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4245 if (sym->as->lower[d])
4246 new_expr = gfc_copy_expr (sym->as->lower[d]);
4248 else
4250 if (sym->as->upper[d])
4251 new_expr = gfc_copy_expr (sym->as->upper[d]);
4253 break;
4255 default:
4256 break;
4259 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4260 if (!new_expr)
4261 return false;
4263 gfc_replace_expr (expr, new_expr);
4264 return true;
4268 static void
4269 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4270 gfc_interface_mapping * mapping)
4272 gfc_formal_arglist *f;
4273 gfc_actual_arglist *actual;
4275 actual = expr->value.function.actual;
4276 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4278 for (; f && actual; f = f->next, actual = actual->next)
4280 if (!actual->expr)
4281 continue;
4283 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4286 if (map_expr->symtree->n.sym->attr.dimension)
4288 int d;
4289 gfc_array_spec *as;
4291 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4293 for (d = 0; d < as->rank; d++)
4295 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4296 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4299 expr->value.function.esym->as = as;
4302 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4304 expr->value.function.esym->ts.u.cl->length
4305 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4307 gfc_apply_interface_mapping_to_expr (mapping,
4308 expr->value.function.esym->ts.u.cl->length);
4313 /* EXPR is a copy of an expression that appeared in the interface
4314 associated with MAPPING. Walk it recursively looking for references to
4315 dummy arguments that MAPPING maps to actual arguments. Replace each such
4316 reference with a reference to the associated actual argument. */
4318 static void
4319 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4320 gfc_expr * expr)
4322 gfc_interface_sym_mapping *sym;
4323 gfc_actual_arglist *actual;
4325 if (!expr)
4326 return;
4328 /* Copying an expression does not copy its length, so do that here. */
4329 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4331 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4332 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4335 /* Apply the mapping to any references. */
4336 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4338 /* ...and to the expression's symbol, if it has one. */
4339 /* TODO Find out why the condition on expr->symtree had to be moved into
4340 the loop rather than being outside it, as originally. */
4341 for (sym = mapping->syms; sym; sym = sym->next)
4342 if (expr->symtree && sym->old == expr->symtree->n.sym)
4344 if (sym->new_sym->n.sym->backend_decl)
4345 expr->symtree = sym->new_sym;
4346 else if (sym->expr)
4347 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4350 /* ...and to subexpressions in expr->value. */
4351 switch (expr->expr_type)
4353 case EXPR_VARIABLE:
4354 case EXPR_CONSTANT:
4355 case EXPR_NULL:
4356 case EXPR_SUBSTRING:
4357 break;
4359 case EXPR_OP:
4360 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4361 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4362 break;
4364 case EXPR_FUNCTION:
4365 for (actual = expr->value.function.actual; actual; actual = actual->next)
4366 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4368 if (expr->value.function.esym == NULL
4369 && expr->value.function.isym != NULL
4370 && expr->value.function.actual
4371 && expr->value.function.actual->expr
4372 && expr->value.function.actual->expr->symtree
4373 && gfc_map_intrinsic_function (expr, mapping))
4374 break;
4376 for (sym = mapping->syms; sym; sym = sym->next)
4377 if (sym->old == expr->value.function.esym)
4379 expr->value.function.esym = sym->new_sym->n.sym;
4380 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4381 expr->value.function.esym->result = sym->new_sym->n.sym;
4383 break;
4385 case EXPR_ARRAY:
4386 case EXPR_STRUCTURE:
4387 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4388 break;
4390 case EXPR_COMPCALL:
4391 case EXPR_PPC:
4392 gcc_unreachable ();
4393 break;
4396 return;
4400 /* Evaluate interface expression EXPR using MAPPING. Store the result
4401 in SE. */
4403 void
4404 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4405 gfc_se * se, gfc_expr * expr)
4407 expr = gfc_copy_expr (expr);
4408 gfc_apply_interface_mapping_to_expr (mapping, expr);
4409 gfc_conv_expr (se, expr);
4410 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4411 gfc_free_expr (expr);
4415 /* Returns a reference to a temporary array into which a component of
4416 an actual argument derived type array is copied and then returned
4417 after the function call. */
4418 void
4419 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4420 sym_intent intent, bool formal_ptr)
4422 gfc_se lse;
4423 gfc_se rse;
4424 gfc_ss *lss;
4425 gfc_ss *rss;
4426 gfc_loopinfo loop;
4427 gfc_loopinfo loop2;
4428 gfc_array_info *info;
4429 tree offset;
4430 tree tmp_index;
4431 tree tmp;
4432 tree base_type;
4433 tree size;
4434 stmtblock_t body;
4435 int n;
4436 int dimen;
4438 gfc_init_se (&lse, NULL);
4439 gfc_init_se (&rse, NULL);
4441 /* Walk the argument expression. */
4442 rss = gfc_walk_expr (expr);
4444 gcc_assert (rss != gfc_ss_terminator);
4446 /* Initialize the scalarizer. */
4447 gfc_init_loopinfo (&loop);
4448 gfc_add_ss_to_loop (&loop, rss);
4450 /* Calculate the bounds of the scalarization. */
4451 gfc_conv_ss_startstride (&loop);
4453 /* Build an ss for the temporary. */
4454 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4455 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4457 base_type = gfc_typenode_for_spec (&expr->ts);
4458 if (GFC_ARRAY_TYPE_P (base_type)
4459 || GFC_DESCRIPTOR_TYPE_P (base_type))
4460 base_type = gfc_get_element_type (base_type);
4462 if (expr->ts.type == BT_CLASS)
4463 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4465 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4466 ? expr->ts.u.cl->backend_decl
4467 : NULL),
4468 loop.dimen);
4470 parmse->string_length = loop.temp_ss->info->string_length;
4472 /* Associate the SS with the loop. */
4473 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4475 /* Setup the scalarizing loops. */
4476 gfc_conv_loop_setup (&loop, &expr->where);
4478 /* Pass the temporary descriptor back to the caller. */
4479 info = &loop.temp_ss->info->data.array;
4480 parmse->expr = info->descriptor;
4482 /* Setup the gfc_se structures. */
4483 gfc_copy_loopinfo_to_se (&lse, &loop);
4484 gfc_copy_loopinfo_to_se (&rse, &loop);
4486 rse.ss = rss;
4487 lse.ss = loop.temp_ss;
4488 gfc_mark_ss_chain_used (rss, 1);
4489 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4491 /* Start the scalarized loop body. */
4492 gfc_start_scalarized_body (&loop, &body);
4494 /* Translate the expression. */
4495 gfc_conv_expr (&rse, expr);
4497 /* Reset the offset for the function call since the loop
4498 is zero based on the data pointer. Note that the temp
4499 comes first in the loop chain since it is added second. */
4500 if (gfc_is_class_array_function (expr))
4502 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4503 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4504 gfc_index_zero_node);
4507 gfc_conv_tmp_array_ref (&lse);
4509 if (intent != INTENT_OUT)
4511 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4512 gfc_add_expr_to_block (&body, tmp);
4513 gcc_assert (rse.ss == gfc_ss_terminator);
4514 gfc_trans_scalarizing_loops (&loop, &body);
4516 else
4518 /* Make sure that the temporary declaration survives by merging
4519 all the loop declarations into the current context. */
4520 for (n = 0; n < loop.dimen; n++)
4522 gfc_merge_block_scope (&body);
4523 body = loop.code[loop.order[n]];
4525 gfc_merge_block_scope (&body);
4528 /* Add the post block after the second loop, so that any
4529 freeing of allocated memory is done at the right time. */
4530 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4532 /**********Copy the temporary back again.*********/
4534 gfc_init_se (&lse, NULL);
4535 gfc_init_se (&rse, NULL);
4537 /* Walk the argument expression. */
4538 lss = gfc_walk_expr (expr);
4539 rse.ss = loop.temp_ss;
4540 lse.ss = lss;
4542 /* Initialize the scalarizer. */
4543 gfc_init_loopinfo (&loop2);
4544 gfc_add_ss_to_loop (&loop2, lss);
4546 dimen = rse.ss->dimen;
4548 /* Skip the write-out loop for this case. */
4549 if (gfc_is_class_array_function (expr))
4550 goto class_array_fcn;
4552 /* Calculate the bounds of the scalarization. */
4553 gfc_conv_ss_startstride (&loop2);
4555 /* Setup the scalarizing loops. */
4556 gfc_conv_loop_setup (&loop2, &expr->where);
4558 gfc_copy_loopinfo_to_se (&lse, &loop2);
4559 gfc_copy_loopinfo_to_se (&rse, &loop2);
4561 gfc_mark_ss_chain_used (lss, 1);
4562 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4564 /* Declare the variable to hold the temporary offset and start the
4565 scalarized loop body. */
4566 offset = gfc_create_var (gfc_array_index_type, NULL);
4567 gfc_start_scalarized_body (&loop2, &body);
4569 /* Build the offsets for the temporary from the loop variables. The
4570 temporary array has lbounds of zero and strides of one in all
4571 dimensions, so this is very simple. The offset is only computed
4572 outside the innermost loop, so the overall transfer could be
4573 optimized further. */
4574 info = &rse.ss->info->data.array;
4576 tmp_index = gfc_index_zero_node;
4577 for (n = dimen - 1; n > 0; n--)
4579 tree tmp_str;
4580 tmp = rse.loop->loopvar[n];
4581 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4582 tmp, rse.loop->from[n]);
4583 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4584 tmp, tmp_index);
4586 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4587 gfc_array_index_type,
4588 rse.loop->to[n-1], rse.loop->from[n-1]);
4589 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4590 gfc_array_index_type,
4591 tmp_str, gfc_index_one_node);
4593 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4594 gfc_array_index_type, tmp, tmp_str);
4597 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4598 gfc_array_index_type,
4599 tmp_index, rse.loop->from[0]);
4600 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4602 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4603 gfc_array_index_type,
4604 rse.loop->loopvar[0], offset);
4606 /* Now use the offset for the reference. */
4607 tmp = build_fold_indirect_ref_loc (input_location,
4608 info->data);
4609 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4611 if (expr->ts.type == BT_CHARACTER)
4612 rse.string_length = expr->ts.u.cl->backend_decl;
4614 gfc_conv_expr (&lse, expr);
4616 gcc_assert (lse.ss == gfc_ss_terminator);
4618 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4619 gfc_add_expr_to_block (&body, tmp);
4621 /* Generate the copying loops. */
4622 gfc_trans_scalarizing_loops (&loop2, &body);
4624 /* Wrap the whole thing up by adding the second loop to the post-block
4625 and following it by the post-block of the first loop. In this way,
4626 if the temporary needs freeing, it is done after use! */
4627 if (intent != INTENT_IN)
4629 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4630 gfc_add_block_to_block (&parmse->post, &loop2.post);
4633 class_array_fcn:
4635 gfc_add_block_to_block (&parmse->post, &loop.post);
4637 gfc_cleanup_loop (&loop);
4638 gfc_cleanup_loop (&loop2);
4640 /* Pass the string length to the argument expression. */
4641 if (expr->ts.type == BT_CHARACTER)
4642 parmse->string_length = expr->ts.u.cl->backend_decl;
4644 /* Determine the offset for pointer formal arguments and set the
4645 lbounds to one. */
4646 if (formal_ptr)
4648 size = gfc_index_one_node;
4649 offset = gfc_index_zero_node;
4650 for (n = 0; n < dimen; n++)
4652 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4653 gfc_rank_cst[n]);
4654 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4655 gfc_array_index_type, tmp,
4656 gfc_index_one_node);
4657 gfc_conv_descriptor_ubound_set (&parmse->pre,
4658 parmse->expr,
4659 gfc_rank_cst[n],
4660 tmp);
4661 gfc_conv_descriptor_lbound_set (&parmse->pre,
4662 parmse->expr,
4663 gfc_rank_cst[n],
4664 gfc_index_one_node);
4665 size = gfc_evaluate_now (size, &parmse->pre);
4666 offset = fold_build2_loc (input_location, MINUS_EXPR,
4667 gfc_array_index_type,
4668 offset, size);
4669 offset = gfc_evaluate_now (offset, &parmse->pre);
4670 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4671 gfc_array_index_type,
4672 rse.loop->to[n], rse.loop->from[n]);
4673 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4674 gfc_array_index_type,
4675 tmp, gfc_index_one_node);
4676 size = fold_build2_loc (input_location, MULT_EXPR,
4677 gfc_array_index_type, size, tmp);
4680 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4681 offset);
4684 /* We want either the address for the data or the address of the descriptor,
4685 depending on the mode of passing array arguments. */
4686 if (g77)
4687 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4688 else
4689 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4691 return;
4695 /* Generate the code for argument list functions. */
4697 static void
4698 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4700 /* Pass by value for g77 %VAL(arg), pass the address
4701 indirectly for %LOC, else by reference. Thus %REF
4702 is a "do-nothing" and %LOC is the same as an F95
4703 pointer. */
4704 if (strncmp (name, "%VAL", 4) == 0)
4705 gfc_conv_expr (se, expr);
4706 else if (strncmp (name, "%LOC", 4) == 0)
4708 gfc_conv_expr_reference (se, expr);
4709 se->expr = gfc_build_addr_expr (NULL, se->expr);
4711 else if (strncmp (name, "%REF", 4) == 0)
4712 gfc_conv_expr_reference (se, expr);
4713 else
4714 gfc_error ("Unknown argument list function at %L", &expr->where);
4718 /* This function tells whether the middle-end representation of the expression
4719 E given as input may point to data otherwise accessible through a variable
4720 (sub-)reference.
4721 It is assumed that the only expressions that may alias are variables,
4722 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4723 may alias.
4724 This function is used to decide whether freeing an expression's allocatable
4725 components is safe or should be avoided.
4727 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4728 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4729 is necessary because for array constructors, aliasing depends on how
4730 the array is used:
4731 - If E is an array constructor used as argument to an elemental procedure,
4732 the array, which is generated through shallow copy by the scalarizer,
4733 is used directly and can alias the expressions it was copied from.
4734 - If E is an array constructor used as argument to a non-elemental
4735 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4736 the array as in the previous case, but then that array is used
4737 to initialize a new descriptor through deep copy. There is no alias
4738 possible in that case.
4739 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4740 above. */
4742 static bool
4743 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4745 gfc_constructor *c;
4747 if (e->expr_type == EXPR_VARIABLE)
4748 return true;
4749 else if (e->expr_type == EXPR_FUNCTION)
4751 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4753 if (proc_ifc->result != NULL
4754 && ((proc_ifc->result->ts.type == BT_CLASS
4755 && proc_ifc->result->ts.u.derived->attr.is_class
4756 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4757 || proc_ifc->result->attr.pointer))
4758 return true;
4759 else
4760 return false;
4762 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4763 return false;
4765 for (c = gfc_constructor_first (e->value.constructor);
4766 c; c = gfc_constructor_next (c))
4767 if (c->expr
4768 && expr_may_alias_variables (c->expr, array_may_alias))
4769 return true;
4771 return false;
4775 /* Generate code for a procedure call. Note can return se->post != NULL.
4776 If se->direct_byref is set then se->expr contains the return parameter.
4777 Return nonzero, if the call has alternate specifiers.
4778 'expr' is only needed for procedure pointer components. */
4781 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4782 gfc_actual_arglist * args, gfc_expr * expr,
4783 vec<tree, va_gc> *append_args)
4785 gfc_interface_mapping mapping;
4786 vec<tree, va_gc> *arglist;
4787 vec<tree, va_gc> *retargs;
4788 tree tmp;
4789 tree fntype;
4790 gfc_se parmse;
4791 gfc_array_info *info;
4792 int byref;
4793 int parm_kind;
4794 tree type;
4795 tree var;
4796 tree len;
4797 tree base_object;
4798 vec<tree, va_gc> *stringargs;
4799 vec<tree, va_gc> *optionalargs;
4800 tree result = NULL;
4801 gfc_formal_arglist *formal;
4802 gfc_actual_arglist *arg;
4803 int has_alternate_specifier = 0;
4804 bool need_interface_mapping;
4805 bool callee_alloc;
4806 bool ulim_copy;
4807 gfc_typespec ts;
4808 gfc_charlen cl;
4809 gfc_expr *e;
4810 gfc_symbol *fsym;
4811 stmtblock_t post;
4812 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4813 gfc_component *comp = NULL;
4814 int arglen;
4815 unsigned int argc;
4817 arglist = NULL;
4818 retargs = NULL;
4819 stringargs = NULL;
4820 optionalargs = NULL;
4821 var = NULL_TREE;
4822 len = NULL_TREE;
4823 gfc_clear_ts (&ts);
4825 comp = gfc_get_proc_ptr_comp (expr);
4827 bool elemental_proc = (comp
4828 && comp->ts.interface
4829 && comp->ts.interface->attr.elemental)
4830 || (comp && comp->attr.elemental)
4831 || sym->attr.elemental;
4833 if (se->ss != NULL)
4835 if (!elemental_proc)
4837 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4838 if (se->ss->info->useflags)
4840 gcc_assert ((!comp && gfc_return_by_reference (sym)
4841 && sym->result->attr.dimension)
4842 || (comp && comp->attr.dimension)
4843 || gfc_is_class_array_function (expr));
4844 gcc_assert (se->loop != NULL);
4845 /* Access the previously obtained result. */
4846 gfc_conv_tmp_array_ref (se);
4847 return 0;
4850 info = &se->ss->info->data.array;
4852 else
4853 info = NULL;
4855 gfc_init_block (&post);
4856 gfc_init_interface_mapping (&mapping);
4857 if (!comp)
4859 formal = gfc_sym_get_dummy_args (sym);
4860 need_interface_mapping = sym->attr.dimension ||
4861 (sym->ts.type == BT_CHARACTER
4862 && sym->ts.u.cl->length
4863 && sym->ts.u.cl->length->expr_type
4864 != EXPR_CONSTANT);
4866 else
4868 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4869 need_interface_mapping = comp->attr.dimension ||
4870 (comp->ts.type == BT_CHARACTER
4871 && comp->ts.u.cl->length
4872 && comp->ts.u.cl->length->expr_type
4873 != EXPR_CONSTANT);
4876 base_object = NULL_TREE;
4877 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4878 is the third and fourth argument to such a function call a value
4879 denoting the number of elements to copy (i.e., most of the time the
4880 length of a deferred length string). */
4881 ulim_copy = (formal == NULL)
4882 && UNLIMITED_POLY (sym)
4883 && comp && (strcmp ("_copy", comp->name) == 0);
4885 /* Evaluate the arguments. */
4886 for (arg = args, argc = 0; arg != NULL;
4887 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
4889 e = arg->expr;
4890 fsym = formal ? formal->sym : NULL;
4891 parm_kind = MISSING;
4893 /* If the procedure requires an explicit interface, the actual
4894 argument is passed according to the corresponding formal
4895 argument. If the corresponding formal argument is a POINTER,
4896 ALLOCATABLE or assumed shape, we do not use g77's calling
4897 convention, and pass the address of the array descriptor
4898 instead. Otherwise we use g77's calling convention, in other words
4899 pass the array data pointer without descriptor. */
4900 bool nodesc_arg = fsym != NULL
4901 && !(fsym->attr.pointer || fsym->attr.allocatable)
4902 && fsym->as
4903 && fsym->as->type != AS_ASSUMED_SHAPE
4904 && fsym->as->type != AS_ASSUMED_RANK;
4905 if (comp)
4906 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
4907 else
4908 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
4910 /* Class array expressions are sometimes coming completely unadorned
4911 with either arrayspec or _data component. Correct that here.
4912 OOP-TODO: Move this to the frontend. */
4913 if (e && e->expr_type == EXPR_VARIABLE
4914 && !e->ref
4915 && e->ts.type == BT_CLASS
4916 && (CLASS_DATA (e)->attr.codimension
4917 || CLASS_DATA (e)->attr.dimension))
4919 gfc_typespec temp_ts = e->ts;
4920 gfc_add_class_array_ref (e);
4921 e->ts = temp_ts;
4924 if (e == NULL)
4926 if (se->ignore_optional)
4928 /* Some intrinsics have already been resolved to the correct
4929 parameters. */
4930 continue;
4932 else if (arg->label)
4934 has_alternate_specifier = 1;
4935 continue;
4937 else
4939 gfc_init_se (&parmse, NULL);
4941 /* For scalar arguments with VALUE attribute which are passed by
4942 value, pass "0" and a hidden argument gives the optional
4943 status. */
4944 if (fsym && fsym->attr.optional && fsym->attr.value
4945 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
4946 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
4948 parmse.expr = fold_convert (gfc_sym_type (fsym),
4949 integer_zero_node);
4950 vec_safe_push (optionalargs, boolean_false_node);
4952 else
4954 /* Pass a NULL pointer for an absent arg. */
4955 parmse.expr = null_pointer_node;
4956 if (arg->missing_arg_type == BT_CHARACTER)
4957 parmse.string_length = build_int_cst (gfc_charlen_type_node,
4962 else if (arg->expr->expr_type == EXPR_NULL
4963 && fsym && !fsym->attr.pointer
4964 && (fsym->ts.type != BT_CLASS
4965 || !CLASS_DATA (fsym)->attr.class_pointer))
4967 /* Pass a NULL pointer to denote an absent arg. */
4968 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
4969 && (fsym->ts.type != BT_CLASS
4970 || !CLASS_DATA (fsym)->attr.allocatable));
4971 gfc_init_se (&parmse, NULL);
4972 parmse.expr = null_pointer_node;
4973 if (arg->missing_arg_type == BT_CHARACTER)
4974 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4976 else if (fsym && fsym->ts.type == BT_CLASS
4977 && e->ts.type == BT_DERIVED)
4979 /* The derived type needs to be converted to a temporary
4980 CLASS object. */
4981 gfc_init_se (&parmse, se);
4982 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
4983 fsym->attr.optional
4984 && e->expr_type == EXPR_VARIABLE
4985 && e->symtree->n.sym->attr.optional,
4986 CLASS_DATA (fsym)->attr.class_pointer
4987 || CLASS_DATA (fsym)->attr.allocatable);
4989 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
4991 /* The intrinsic type needs to be converted to a temporary
4992 CLASS object for the unlimited polymorphic formal. */
4993 gfc_init_se (&parmse, se);
4994 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
4996 else if (se->ss && se->ss->info->useflags)
4998 gfc_ss *ss;
5000 ss = se->ss;
5002 /* An elemental function inside a scalarized loop. */
5003 gfc_init_se (&parmse, se);
5004 parm_kind = ELEMENTAL;
5006 /* When no fsym is present, ulim_copy is set and this is a third or
5007 fourth argument, use call-by-value instead of by reference to
5008 hand the length properties to the copy routine (i.e., most of the
5009 time this will be a call to a __copy_character_* routine where the
5010 third and fourth arguments are the lengths of a deferred length
5011 char array). */
5012 if ((fsym && fsym->attr.value)
5013 || (ulim_copy && (argc == 2 || argc == 3)))
5014 gfc_conv_expr (&parmse, e);
5015 else
5016 gfc_conv_expr_reference (&parmse, e);
5018 if (e->ts.type == BT_CHARACTER && !e->rank
5019 && e->expr_type == EXPR_FUNCTION)
5020 parmse.expr = build_fold_indirect_ref_loc (input_location,
5021 parmse.expr);
5023 if (fsym && fsym->ts.type == BT_DERIVED
5024 && gfc_is_class_container_ref (e))
5026 parmse.expr = gfc_class_data_get (parmse.expr);
5028 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5029 && e->symtree->n.sym->attr.optional)
5031 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5032 parmse.expr = build3_loc (input_location, COND_EXPR,
5033 TREE_TYPE (parmse.expr),
5034 cond, parmse.expr,
5035 fold_convert (TREE_TYPE (parmse.expr),
5036 null_pointer_node));
5040 /* If we are passing an absent array as optional dummy to an
5041 elemental procedure, make sure that we pass NULL when the data
5042 pointer is NULL. We need this extra conditional because of
5043 scalarization which passes arrays elements to the procedure,
5044 ignoring the fact that the array can be absent/unallocated/... */
5045 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5047 tree descriptor_data;
5049 descriptor_data = ss->info->data.array.data;
5050 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5051 descriptor_data,
5052 fold_convert (TREE_TYPE (descriptor_data),
5053 null_pointer_node));
5054 parmse.expr
5055 = fold_build3_loc (input_location, COND_EXPR,
5056 TREE_TYPE (parmse.expr),
5057 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5058 fold_convert (TREE_TYPE (parmse.expr),
5059 null_pointer_node),
5060 parmse.expr);
5063 /* The scalarizer does not repackage the reference to a class
5064 array - instead it returns a pointer to the data element. */
5065 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5066 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5067 fsym->attr.intent != INTENT_IN
5068 && (CLASS_DATA (fsym)->attr.class_pointer
5069 || CLASS_DATA (fsym)->attr.allocatable),
5070 fsym->attr.optional
5071 && e->expr_type == EXPR_VARIABLE
5072 && e->symtree->n.sym->attr.optional,
5073 CLASS_DATA (fsym)->attr.class_pointer
5074 || CLASS_DATA (fsym)->attr.allocatable);
5076 else
5078 bool scalar;
5079 gfc_ss *argss;
5081 gfc_init_se (&parmse, NULL);
5083 /* Check whether the expression is a scalar or not; we cannot use
5084 e->rank as it can be nonzero for functions arguments. */
5085 argss = gfc_walk_expr (e);
5086 scalar = argss == gfc_ss_terminator;
5087 if (!scalar)
5088 gfc_free_ss_chain (argss);
5090 /* Special handling for passing scalar polymorphic coarrays;
5091 otherwise one passes "class->_data.data" instead of "&class". */
5092 if (e->rank == 0 && e->ts.type == BT_CLASS
5093 && fsym && fsym->ts.type == BT_CLASS
5094 && CLASS_DATA (fsym)->attr.codimension
5095 && !CLASS_DATA (fsym)->attr.dimension)
5097 gfc_add_class_array_ref (e);
5098 parmse.want_coarray = 1;
5099 scalar = false;
5102 /* A scalar or transformational function. */
5103 if (scalar)
5105 if (e->expr_type == EXPR_VARIABLE
5106 && e->symtree->n.sym->attr.cray_pointee
5107 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5109 /* The Cray pointer needs to be converted to a pointer to
5110 a type given by the expression. */
5111 gfc_conv_expr (&parmse, e);
5112 type = build_pointer_type (TREE_TYPE (parmse.expr));
5113 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5114 parmse.expr = convert (type, tmp);
5116 else if (fsym && fsym->attr.value)
5118 if (fsym->ts.type == BT_CHARACTER
5119 && fsym->ts.is_c_interop
5120 && fsym->ns->proc_name != NULL
5121 && fsym->ns->proc_name->attr.is_bind_c)
5123 parmse.expr = NULL;
5124 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5125 if (parmse.expr == NULL)
5126 gfc_conv_expr (&parmse, e);
5128 else
5130 gfc_conv_expr (&parmse, e);
5131 if (fsym->attr.optional
5132 && fsym->ts.type != BT_CLASS
5133 && fsym->ts.type != BT_DERIVED)
5135 if (e->expr_type != EXPR_VARIABLE
5136 || !e->symtree->n.sym->attr.optional
5137 || e->ref != NULL)
5138 vec_safe_push (optionalargs, boolean_true_node);
5139 else
5141 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5142 if (!e->symtree->n.sym->attr.value)
5143 parmse.expr
5144 = fold_build3_loc (input_location, COND_EXPR,
5145 TREE_TYPE (parmse.expr),
5146 tmp, parmse.expr,
5147 fold_convert (TREE_TYPE (parmse.expr),
5148 integer_zero_node));
5150 vec_safe_push (optionalargs, tmp);
5155 else if (arg->name && arg->name[0] == '%')
5156 /* Argument list functions %VAL, %LOC and %REF are signalled
5157 through arg->name. */
5158 conv_arglist_function (&parmse, arg->expr, arg->name);
5159 else if ((e->expr_type == EXPR_FUNCTION)
5160 && ((e->value.function.esym
5161 && e->value.function.esym->result->attr.pointer)
5162 || (!e->value.function.esym
5163 && e->symtree->n.sym->attr.pointer))
5164 && fsym && fsym->attr.target)
5166 gfc_conv_expr (&parmse, e);
5167 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5169 else if (e->expr_type == EXPR_FUNCTION
5170 && e->symtree->n.sym->result
5171 && e->symtree->n.sym->result != e->symtree->n.sym
5172 && e->symtree->n.sym->result->attr.proc_pointer)
5174 /* Functions returning procedure pointers. */
5175 gfc_conv_expr (&parmse, e);
5176 if (fsym && fsym->attr.proc_pointer)
5177 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5179 else
5181 if (e->ts.type == BT_CLASS && fsym
5182 && fsym->ts.type == BT_CLASS
5183 && (!CLASS_DATA (fsym)->as
5184 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5185 && CLASS_DATA (e)->attr.codimension)
5187 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5188 gcc_assert (!CLASS_DATA (fsym)->as);
5189 gfc_add_class_array_ref (e);
5190 parmse.want_coarray = 1;
5191 gfc_conv_expr_reference (&parmse, e);
5192 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5193 fsym->attr.optional
5194 && e->expr_type == EXPR_VARIABLE);
5196 else if (e->ts.type == BT_CLASS && fsym
5197 && fsym->ts.type == BT_CLASS
5198 && !CLASS_DATA (fsym)->as
5199 && !CLASS_DATA (e)->as
5200 && strcmp (fsym->ts.u.derived->name,
5201 e->ts.u.derived->name))
5203 type = gfc_typenode_for_spec (&fsym->ts);
5204 var = gfc_create_var (type, fsym->name);
5205 gfc_conv_expr (&parmse, e);
5206 if (fsym->attr.optional
5207 && e->expr_type == EXPR_VARIABLE
5208 && e->symtree->n.sym->attr.optional)
5210 stmtblock_t block;
5211 tree cond;
5212 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5213 cond = fold_build2_loc (input_location, NE_EXPR,
5214 logical_type_node, tmp,
5215 fold_convert (TREE_TYPE (tmp),
5216 null_pointer_node));
5217 gfc_start_block (&block);
5218 gfc_add_modify (&block, var,
5219 fold_build1_loc (input_location,
5220 VIEW_CONVERT_EXPR,
5221 type, parmse.expr));
5222 gfc_add_expr_to_block (&parmse.pre,
5223 fold_build3_loc (input_location,
5224 COND_EXPR, void_type_node,
5225 cond, gfc_finish_block (&block),
5226 build_empty_stmt (input_location)));
5227 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5228 parmse.expr = build3_loc (input_location, COND_EXPR,
5229 TREE_TYPE (parmse.expr),
5230 cond, parmse.expr,
5231 fold_convert (TREE_TYPE (parmse.expr),
5232 null_pointer_node));
5234 else
5236 /* Since the internal representation of unlimited
5237 polymorphic expressions includes an extra field
5238 that other class objects do not, a cast to the
5239 formal type does not work. */
5240 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5242 tree efield;
5244 /* Set the _data field. */
5245 tmp = gfc_class_data_get (var);
5246 efield = fold_convert (TREE_TYPE (tmp),
5247 gfc_class_data_get (parmse.expr));
5248 gfc_add_modify (&parmse.pre, tmp, efield);
5250 /* Set the _vptr field. */
5251 tmp = gfc_class_vptr_get (var);
5252 efield = fold_convert (TREE_TYPE (tmp),
5253 gfc_class_vptr_get (parmse.expr));
5254 gfc_add_modify (&parmse.pre, tmp, efield);
5256 /* Set the _len field. */
5257 tmp = gfc_class_len_get (var);
5258 gfc_add_modify (&parmse.pre, tmp,
5259 build_int_cst (TREE_TYPE (tmp), 0));
5261 else
5263 tmp = fold_build1_loc (input_location,
5264 VIEW_CONVERT_EXPR,
5265 type, parmse.expr);
5266 gfc_add_modify (&parmse.pre, var, tmp);
5269 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5272 else
5273 gfc_conv_expr_reference (&parmse, e);
5275 /* Catch base objects that are not variables. */
5276 if (e->ts.type == BT_CLASS
5277 && e->expr_type != EXPR_VARIABLE
5278 && expr && e == expr->base_expr)
5279 base_object = build_fold_indirect_ref_loc (input_location,
5280 parmse.expr);
5282 /* A class array element needs converting back to be a
5283 class object, if the formal argument is a class object. */
5284 if (fsym && fsym->ts.type == BT_CLASS
5285 && e->ts.type == BT_CLASS
5286 && ((CLASS_DATA (fsym)->as
5287 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5288 || CLASS_DATA (e)->attr.dimension))
5289 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5290 fsym->attr.intent != INTENT_IN
5291 && (CLASS_DATA (fsym)->attr.class_pointer
5292 || CLASS_DATA (fsym)->attr.allocatable),
5293 fsym->attr.optional
5294 && e->expr_type == EXPR_VARIABLE
5295 && e->symtree->n.sym->attr.optional,
5296 CLASS_DATA (fsym)->attr.class_pointer
5297 || CLASS_DATA (fsym)->attr.allocatable);
5299 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5300 allocated on entry, it must be deallocated. */
5301 if (fsym && fsym->attr.intent == INTENT_OUT
5302 && (fsym->attr.allocatable
5303 || (fsym->ts.type == BT_CLASS
5304 && CLASS_DATA (fsym)->attr.allocatable)))
5306 stmtblock_t block;
5307 tree ptr;
5309 gfc_init_block (&block);
5310 ptr = parmse.expr;
5311 if (e->ts.type == BT_CLASS)
5312 ptr = gfc_class_data_get (ptr);
5314 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5315 NULL_TREE, true,
5316 e, e->ts);
5317 gfc_add_expr_to_block (&block, tmp);
5318 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5319 void_type_node, ptr,
5320 null_pointer_node);
5321 gfc_add_expr_to_block (&block, tmp);
5323 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5325 gfc_add_modify (&block, ptr,
5326 fold_convert (TREE_TYPE (ptr),
5327 null_pointer_node));
5328 gfc_add_expr_to_block (&block, tmp);
5330 else if (fsym->ts.type == BT_CLASS)
5332 gfc_symbol *vtab;
5333 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5334 tmp = gfc_get_symbol_decl (vtab);
5335 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5336 ptr = gfc_class_vptr_get (parmse.expr);
5337 gfc_add_modify (&block, ptr,
5338 fold_convert (TREE_TYPE (ptr), tmp));
5339 gfc_add_expr_to_block (&block, tmp);
5342 if (fsym->attr.optional
5343 && e->expr_type == EXPR_VARIABLE
5344 && e->symtree->n.sym->attr.optional)
5346 tmp = fold_build3_loc (input_location, COND_EXPR,
5347 void_type_node,
5348 gfc_conv_expr_present (e->symtree->n.sym),
5349 gfc_finish_block (&block),
5350 build_empty_stmt (input_location));
5352 else
5353 tmp = gfc_finish_block (&block);
5355 gfc_add_expr_to_block (&se->pre, tmp);
5358 if (fsym && (fsym->ts.type == BT_DERIVED
5359 || fsym->ts.type == BT_ASSUMED)
5360 && e->ts.type == BT_CLASS
5361 && !CLASS_DATA (e)->attr.dimension
5362 && !CLASS_DATA (e)->attr.codimension)
5363 parmse.expr = gfc_class_data_get (parmse.expr);
5365 /* Wrap scalar variable in a descriptor. We need to convert
5366 the address of a pointer back to the pointer itself before,
5367 we can assign it to the data field. */
5369 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5370 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5372 tmp = parmse.expr;
5373 if (TREE_CODE (tmp) == ADDR_EXPR)
5374 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5375 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5376 fsym->attr);
5377 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5378 parmse.expr);
5380 else if (fsym && e->expr_type != EXPR_NULL
5381 && ((fsym->attr.pointer
5382 && fsym->attr.flavor != FL_PROCEDURE)
5383 || (fsym->attr.proc_pointer
5384 && !(e->expr_type == EXPR_VARIABLE
5385 && e->symtree->n.sym->attr.dummy))
5386 || (fsym->attr.proc_pointer
5387 && e->expr_type == EXPR_VARIABLE
5388 && gfc_is_proc_ptr_comp (e))
5389 || (fsym->attr.allocatable
5390 && fsym->attr.flavor != FL_PROCEDURE)))
5392 /* Scalar pointer dummy args require an extra level of
5393 indirection. The null pointer already contains
5394 this level of indirection. */
5395 parm_kind = SCALAR_POINTER;
5396 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5400 else if (e->ts.type == BT_CLASS
5401 && fsym && fsym->ts.type == BT_CLASS
5402 && (CLASS_DATA (fsym)->attr.dimension
5403 || CLASS_DATA (fsym)->attr.codimension))
5405 /* Pass a class array. */
5406 parmse.use_offset = 1;
5407 gfc_conv_expr_descriptor (&parmse, e);
5409 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5410 allocated on entry, it must be deallocated. */
5411 if (fsym->attr.intent == INTENT_OUT
5412 && CLASS_DATA (fsym)->attr.allocatable)
5414 stmtblock_t block;
5415 tree ptr;
5417 gfc_init_block (&block);
5418 ptr = parmse.expr;
5419 ptr = gfc_class_data_get (ptr);
5421 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5422 NULL_TREE, NULL_TREE,
5423 NULL_TREE, true, e,
5424 GFC_CAF_COARRAY_NOCOARRAY);
5425 gfc_add_expr_to_block (&block, tmp);
5426 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5427 void_type_node, ptr,
5428 null_pointer_node);
5429 gfc_add_expr_to_block (&block, tmp);
5430 gfc_reset_vptr (&block, e);
5432 if (fsym->attr.optional
5433 && e->expr_type == EXPR_VARIABLE
5434 && (!e->ref
5435 || (e->ref->type == REF_ARRAY
5436 && e->ref->u.ar.type != AR_FULL))
5437 && e->symtree->n.sym->attr.optional)
5439 tmp = fold_build3_loc (input_location, COND_EXPR,
5440 void_type_node,
5441 gfc_conv_expr_present (e->symtree->n.sym),
5442 gfc_finish_block (&block),
5443 build_empty_stmt (input_location));
5445 else
5446 tmp = gfc_finish_block (&block);
5448 gfc_add_expr_to_block (&se->pre, tmp);
5451 /* The conversion does not repackage the reference to a class
5452 array - _data descriptor. */
5453 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5454 fsym->attr.intent != INTENT_IN
5455 && (CLASS_DATA (fsym)->attr.class_pointer
5456 || CLASS_DATA (fsym)->attr.allocatable),
5457 fsym->attr.optional
5458 && e->expr_type == EXPR_VARIABLE
5459 && e->symtree->n.sym->attr.optional,
5460 CLASS_DATA (fsym)->attr.class_pointer
5461 || CLASS_DATA (fsym)->attr.allocatable);
5463 else
5465 /* If the argument is a function call that may not create
5466 a temporary for the result, we have to check that we
5467 can do it, i.e. that there is no alias between this
5468 argument and another one. */
5469 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5471 gfc_expr *iarg;
5472 sym_intent intent;
5474 if (fsym != NULL)
5475 intent = fsym->attr.intent;
5476 else
5477 intent = INTENT_UNKNOWN;
5479 if (gfc_check_fncall_dependency (e, intent, sym, args,
5480 NOT_ELEMENTAL))
5481 parmse.force_tmp = 1;
5483 iarg = e->value.function.actual->expr;
5485 /* Temporary needed if aliasing due to host association. */
5486 if (sym->attr.contained
5487 && !sym->attr.pure
5488 && !sym->attr.implicit_pure
5489 && !sym->attr.use_assoc
5490 && iarg->expr_type == EXPR_VARIABLE
5491 && sym->ns == iarg->symtree->n.sym->ns)
5492 parmse.force_tmp = 1;
5494 /* Ditto within module. */
5495 if (sym->attr.use_assoc
5496 && !sym->attr.pure
5497 && !sym->attr.implicit_pure
5498 && iarg->expr_type == EXPR_VARIABLE
5499 && sym->module == iarg->symtree->n.sym->module)
5500 parmse.force_tmp = 1;
5503 if (e->expr_type == EXPR_VARIABLE
5504 && is_subref_array (e)
5505 && !(fsym && fsym->attr.pointer))
5506 /* The actual argument is a component reference to an
5507 array of derived types. In this case, the argument
5508 is converted to a temporary, which is passed and then
5509 written back after the procedure call. */
5510 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5511 fsym ? fsym->attr.intent : INTENT_INOUT,
5512 fsym && fsym->attr.pointer);
5513 else if (gfc_is_class_array_ref (e, NULL)
5514 && fsym && fsym->ts.type == BT_DERIVED)
5515 /* The actual argument is a component reference to an
5516 array of derived types. In this case, the argument
5517 is converted to a temporary, which is passed and then
5518 written back after the procedure call.
5519 OOP-TODO: Insert code so that if the dynamic type is
5520 the same as the declared type, copy-in/copy-out does
5521 not occur. */
5522 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5523 fsym ? fsym->attr.intent : INTENT_INOUT,
5524 fsym && fsym->attr.pointer);
5526 else if (gfc_is_class_array_function (e)
5527 && fsym && fsym->ts.type == BT_DERIVED)
5528 /* See previous comment. For function actual argument,
5529 the write out is not needed so the intent is set as
5530 intent in. */
5532 e->must_finalize = 1;
5533 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5534 INTENT_IN,
5535 fsym && fsym->attr.pointer);
5537 else
5538 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5539 sym->name, NULL);
5541 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5542 allocated on entry, it must be deallocated. */
5543 if (fsym && fsym->attr.allocatable
5544 && fsym->attr.intent == INTENT_OUT)
5546 if (fsym->ts.type == BT_DERIVED
5547 && fsym->ts.u.derived->attr.alloc_comp)
5549 // deallocate the components first
5550 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5551 parmse.expr, e->rank);
5552 if (tmp != NULL_TREE)
5553 gfc_add_expr_to_block (&se->pre, tmp);
5556 tmp = build_fold_indirect_ref_loc (input_location,
5557 parmse.expr);
5558 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5559 tmp = gfc_conv_descriptor_data_get (tmp);
5560 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5561 NULL_TREE, NULL_TREE, true,
5563 GFC_CAF_COARRAY_NOCOARRAY);
5564 if (fsym->attr.optional
5565 && e->expr_type == EXPR_VARIABLE
5566 && e->symtree->n.sym->attr.optional)
5567 tmp = fold_build3_loc (input_location, COND_EXPR,
5568 void_type_node,
5569 gfc_conv_expr_present (e->symtree->n.sym),
5570 tmp, build_empty_stmt (input_location));
5571 gfc_add_expr_to_block (&se->pre, tmp);
5576 /* The case with fsym->attr.optional is that of a user subroutine
5577 with an interface indicating an optional argument. When we call
5578 an intrinsic subroutine, however, fsym is NULL, but we might still
5579 have an optional argument, so we proceed to the substitution
5580 just in case. */
5581 if (e && (fsym == NULL || fsym->attr.optional))
5583 /* If an optional argument is itself an optional dummy argument,
5584 check its presence and substitute a null if absent. This is
5585 only needed when passing an array to an elemental procedure
5586 as then array elements are accessed - or no NULL pointer is
5587 allowed and a "1" or "0" should be passed if not present.
5588 When passing a non-array-descriptor full array to a
5589 non-array-descriptor dummy, no check is needed. For
5590 array-descriptor actual to array-descriptor dummy, see
5591 PR 41911 for why a check has to be inserted.
5592 fsym == NULL is checked as intrinsics required the descriptor
5593 but do not always set fsym. */
5594 if (e->expr_type == EXPR_VARIABLE
5595 && e->symtree->n.sym->attr.optional
5596 && ((e->rank != 0 && elemental_proc)
5597 || e->representation.length || e->ts.type == BT_CHARACTER
5598 || (e->rank != 0
5599 && (fsym == NULL
5600 || (fsym-> as
5601 && (fsym->as->type == AS_ASSUMED_SHAPE
5602 || fsym->as->type == AS_ASSUMED_RANK
5603 || fsym->as->type == AS_DEFERRED))))))
5604 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5605 e->representation.length);
5608 if (fsym && e)
5610 /* Obtain the character length of an assumed character length
5611 length procedure from the typespec. */
5612 if (fsym->ts.type == BT_CHARACTER
5613 && parmse.string_length == NULL_TREE
5614 && e->ts.type == BT_PROCEDURE
5615 && e->symtree->n.sym->ts.type == BT_CHARACTER
5616 && e->symtree->n.sym->ts.u.cl->length != NULL
5617 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5619 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5620 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5624 if (fsym && need_interface_mapping && e)
5625 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5627 gfc_add_block_to_block (&se->pre, &parmse.pre);
5628 gfc_add_block_to_block (&post, &parmse.post);
5630 /* Allocated allocatable components of derived types must be
5631 deallocated for non-variable scalars, array arguments to elemental
5632 procedures, and array arguments with descriptor to non-elemental
5633 procedures. As bounds information for descriptorless arrays is no
5634 longer available here, they are dealt with in trans-array.c
5635 (gfc_conv_array_parameter). */
5636 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5637 && e->ts.u.derived->attr.alloc_comp
5638 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5639 && !expr_may_alias_variables (e, elemental_proc))
5641 int parm_rank;
5642 /* It is known the e returns a structure type with at least one
5643 allocatable component. When e is a function, ensure that the
5644 function is called once only by using a temporary variable. */
5645 if (!DECL_P (parmse.expr))
5646 parmse.expr = gfc_evaluate_now_loc (input_location,
5647 parmse.expr, &se->pre);
5649 if (fsym && fsym->attr.value)
5650 tmp = parmse.expr;
5651 else
5652 tmp = build_fold_indirect_ref_loc (input_location,
5653 parmse.expr);
5655 parm_rank = e->rank;
5656 switch (parm_kind)
5658 case (ELEMENTAL):
5659 case (SCALAR):
5660 parm_rank = 0;
5661 break;
5663 case (SCALAR_POINTER):
5664 tmp = build_fold_indirect_ref_loc (input_location,
5665 tmp);
5666 break;
5669 if (e->expr_type == EXPR_OP
5670 && e->value.op.op == INTRINSIC_PARENTHESES
5671 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5673 tree local_tmp;
5674 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5675 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5676 parm_rank, 0);
5677 gfc_add_expr_to_block (&se->post, local_tmp);
5680 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5682 /* The derived type is passed to gfc_deallocate_alloc_comp.
5683 Therefore, class actuals can handled correctly but derived
5684 types passed to class formals need the _data component. */
5685 tmp = gfc_class_data_get (tmp);
5686 if (!CLASS_DATA (fsym)->attr.dimension)
5687 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5690 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
5692 gfc_prepend_expr_to_block (&post, tmp);
5695 /* Add argument checking of passing an unallocated/NULL actual to
5696 a nonallocatable/nonpointer dummy. */
5698 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5700 symbol_attribute attr;
5701 char *msg;
5702 tree cond;
5704 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5705 attr = gfc_expr_attr (e);
5706 else
5707 goto end_pointer_check;
5709 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5710 allocatable to an optional dummy, cf. 12.5.2.12. */
5711 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5712 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5713 goto end_pointer_check;
5715 if (attr.optional)
5717 /* If the actual argument is an optional pointer/allocatable and
5718 the formal argument takes an nonpointer optional value,
5719 it is invalid to pass a non-present argument on, even
5720 though there is no technical reason for this in gfortran.
5721 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5722 tree present, null_ptr, type;
5724 if (attr.allocatable
5725 && (fsym == NULL || !fsym->attr.allocatable))
5726 msg = xasprintf ("Allocatable actual argument '%s' is not "
5727 "allocated or not present",
5728 e->symtree->n.sym->name);
5729 else if (attr.pointer
5730 && (fsym == NULL || !fsym->attr.pointer))
5731 msg = xasprintf ("Pointer actual argument '%s' is not "
5732 "associated or not present",
5733 e->symtree->n.sym->name);
5734 else if (attr.proc_pointer
5735 && (fsym == NULL || !fsym->attr.proc_pointer))
5736 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5737 "associated or not present",
5738 e->symtree->n.sym->name);
5739 else
5740 goto end_pointer_check;
5742 present = gfc_conv_expr_present (e->symtree->n.sym);
5743 type = TREE_TYPE (present);
5744 present = fold_build2_loc (input_location, EQ_EXPR,
5745 logical_type_node, present,
5746 fold_convert (type,
5747 null_pointer_node));
5748 type = TREE_TYPE (parmse.expr);
5749 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5750 logical_type_node, parmse.expr,
5751 fold_convert (type,
5752 null_pointer_node));
5753 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5754 logical_type_node, present, null_ptr);
5756 else
5758 if (attr.allocatable
5759 && (fsym == NULL || !fsym->attr.allocatable))
5760 msg = xasprintf ("Allocatable actual argument '%s' is not "
5761 "allocated", e->symtree->n.sym->name);
5762 else if (attr.pointer
5763 && (fsym == NULL || !fsym->attr.pointer))
5764 msg = xasprintf ("Pointer actual argument '%s' is not "
5765 "associated", e->symtree->n.sym->name);
5766 else if (attr.proc_pointer
5767 && (fsym == NULL || !fsym->attr.proc_pointer))
5768 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5769 "associated", e->symtree->n.sym->name);
5770 else
5771 goto end_pointer_check;
5773 tmp = parmse.expr;
5775 /* If the argument is passed by value, we need to strip the
5776 INDIRECT_REF. */
5777 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5778 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5780 cond = fold_build2_loc (input_location, EQ_EXPR,
5781 logical_type_node, tmp,
5782 fold_convert (TREE_TYPE (tmp),
5783 null_pointer_node));
5786 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5787 msg);
5788 free (msg);
5790 end_pointer_check:
5792 /* Deferred length dummies pass the character length by reference
5793 so that the value can be returned. */
5794 if (parmse.string_length && fsym && fsym->ts.deferred)
5796 if (INDIRECT_REF_P (parmse.string_length))
5797 /* In chains of functions/procedure calls the string_length already
5798 is a pointer to the variable holding the length. Therefore
5799 remove the deref on call. */
5800 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5801 else
5803 tmp = parmse.string_length;
5804 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5805 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5806 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5810 /* Character strings are passed as two parameters, a length and a
5811 pointer - except for Bind(c) which only passes the pointer.
5812 An unlimited polymorphic formal argument likewise does not
5813 need the length. */
5814 if (parmse.string_length != NULL_TREE
5815 && !sym->attr.is_bind_c
5816 && !(fsym && UNLIMITED_POLY (fsym)))
5817 vec_safe_push (stringargs, parmse.string_length);
5819 /* When calling __copy for character expressions to unlimited
5820 polymorphic entities, the dst argument needs a string length. */
5821 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
5822 && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
5823 && arg->next && arg->next->expr
5824 && (arg->next->expr->ts.type == BT_DERIVED
5825 || arg->next->expr->ts.type == BT_CLASS)
5826 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
5827 vec_safe_push (stringargs, parmse.string_length);
5829 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5830 pass the token and the offset as additional arguments. */
5831 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
5832 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5833 && !fsym->attr.allocatable)
5834 || (fsym->ts.type == BT_CLASS
5835 && CLASS_DATA (fsym)->attr.codimension
5836 && !CLASS_DATA (fsym)->attr.allocatable)))
5838 /* Token and offset. */
5839 vec_safe_push (stringargs, null_pointer_node);
5840 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
5841 gcc_assert (fsym->attr.optional);
5843 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
5844 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5845 && !fsym->attr.allocatable)
5846 || (fsym->ts.type == BT_CLASS
5847 && CLASS_DATA (fsym)->attr.codimension
5848 && !CLASS_DATA (fsym)->attr.allocatable)))
5850 tree caf_decl, caf_type;
5851 tree offset, tmp2;
5853 caf_decl = gfc_get_tree_for_caf_expr (e);
5854 caf_type = TREE_TYPE (caf_decl);
5856 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5857 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
5858 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
5859 tmp = gfc_conv_descriptor_token (caf_decl);
5860 else if (DECL_LANG_SPECIFIC (caf_decl)
5861 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
5862 tmp = GFC_DECL_TOKEN (caf_decl);
5863 else
5865 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
5866 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
5867 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
5870 vec_safe_push (stringargs, tmp);
5872 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5873 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
5874 offset = build_int_cst (gfc_array_index_type, 0);
5875 else if (DECL_LANG_SPECIFIC (caf_decl)
5876 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
5877 offset = GFC_DECL_CAF_OFFSET (caf_decl);
5878 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
5879 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
5880 else
5881 offset = build_int_cst (gfc_array_index_type, 0);
5883 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
5884 tmp = gfc_conv_descriptor_data_get (caf_decl);
5885 else
5887 gcc_assert (POINTER_TYPE_P (caf_type));
5888 tmp = caf_decl;
5891 tmp2 = fsym->ts.type == BT_CLASS
5892 ? gfc_class_data_get (parmse.expr) : parmse.expr;
5893 if ((fsym->ts.type != BT_CLASS
5894 && (fsym->as->type == AS_ASSUMED_SHAPE
5895 || fsym->as->type == AS_ASSUMED_RANK))
5896 || (fsym->ts.type == BT_CLASS
5897 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
5898 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
5900 if (fsym->ts.type == BT_CLASS)
5901 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
5902 else
5904 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5905 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
5907 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
5908 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5910 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
5911 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5912 else
5914 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5917 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5918 gfc_array_index_type,
5919 fold_convert (gfc_array_index_type, tmp2),
5920 fold_convert (gfc_array_index_type, tmp));
5921 offset = fold_build2_loc (input_location, PLUS_EXPR,
5922 gfc_array_index_type, offset, tmp);
5924 vec_safe_push (stringargs, offset);
5927 vec_safe_push (arglist, parmse.expr);
5929 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
5931 if (comp)
5932 ts = comp->ts;
5933 else if (sym->ts.type == BT_CLASS)
5934 ts = CLASS_DATA (sym)->ts;
5935 else
5936 ts = sym->ts;
5938 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
5939 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
5940 else if (ts.type == BT_CHARACTER)
5942 if (ts.u.cl->length == NULL)
5944 /* Assumed character length results are not allowed by 5.1.1.5 of the
5945 standard and are trapped in resolve.c; except in the case of SPREAD
5946 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5947 we take the character length of the first argument for the result.
5948 For dummies, we have to look through the formal argument list for
5949 this function and use the character length found there.*/
5950 if (ts.deferred)
5951 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
5952 else if (!sym->attr.dummy)
5953 cl.backend_decl = (*stringargs)[0];
5954 else
5956 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
5957 for (; formal; formal = formal->next)
5958 if (strcmp (formal->sym->name, sym->name) == 0)
5959 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
5961 len = cl.backend_decl;
5963 else
5965 tree tmp;
5967 /* Calculate the length of the returned string. */
5968 gfc_init_se (&parmse, NULL);
5969 if (need_interface_mapping)
5970 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
5971 else
5972 gfc_conv_expr (&parmse, ts.u.cl->length);
5973 gfc_add_block_to_block (&se->pre, &parmse.pre);
5974 gfc_add_block_to_block (&se->post, &parmse.post);
5975 tmp = parmse.expr;
5976 /* TODO: It would be better to have the charlens as
5977 gfc_charlen_type_node already when the interface is
5978 created instead of converting it here (see PR 84615). */
5979 tmp = fold_build2_loc (input_location, MAX_EXPR,
5980 gfc_charlen_type_node,
5981 fold_convert (gfc_charlen_type_node, tmp),
5982 build_zero_cst (gfc_charlen_type_node));
5983 cl.backend_decl = tmp;
5986 /* Set up a charlen structure for it. */
5987 cl.next = NULL;
5988 cl.length = NULL;
5989 ts.u.cl = &cl;
5991 len = cl.backend_decl;
5994 byref = (comp && (comp->attr.dimension
5995 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
5996 || (!comp && gfc_return_by_reference (sym));
5997 if (byref)
5999 if (se->direct_byref)
6001 /* Sometimes, too much indirection can be applied; e.g. for
6002 function_result = array_valued_recursive_function. */
6003 if (TREE_TYPE (TREE_TYPE (se->expr))
6004 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6005 && GFC_DESCRIPTOR_TYPE_P
6006 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6007 se->expr = build_fold_indirect_ref_loc (input_location,
6008 se->expr);
6010 /* If the lhs of an assignment x = f(..) is allocatable and
6011 f2003 is allowed, we must do the automatic reallocation.
6012 TODO - deal with intrinsics, without using a temporary. */
6013 if (flag_realloc_lhs
6014 && se->ss && se->ss->loop_chain
6015 && se->ss->loop_chain->is_alloc_lhs
6016 && !expr->value.function.isym
6017 && sym->result->as != NULL)
6019 /* Evaluate the bounds of the result, if known. */
6020 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6021 sym->result->as);
6023 /* Perform the automatic reallocation. */
6024 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6025 expr, NULL);
6026 gfc_add_expr_to_block (&se->pre, tmp);
6028 /* Pass the temporary as the first argument. */
6029 result = info->descriptor;
6031 else
6032 result = build_fold_indirect_ref_loc (input_location,
6033 se->expr);
6034 vec_safe_push (retargs, se->expr);
6036 else if (comp && comp->attr.dimension)
6038 gcc_assert (se->loop && info);
6040 /* Set the type of the array. */
6041 tmp = gfc_typenode_for_spec (&comp->ts);
6042 gcc_assert (se->ss->dimen == se->loop->dimen);
6044 /* Evaluate the bounds of the result, if known. */
6045 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6047 /* If the lhs of an assignment x = f(..) is allocatable and
6048 f2003 is allowed, we must not generate the function call
6049 here but should just send back the results of the mapping.
6050 This is signalled by the function ss being flagged. */
6051 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6053 gfc_free_interface_mapping (&mapping);
6054 return has_alternate_specifier;
6057 /* Create a temporary to store the result. In case the function
6058 returns a pointer, the temporary will be a shallow copy and
6059 mustn't be deallocated. */
6060 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6061 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6062 tmp, NULL_TREE, false,
6063 !comp->attr.pointer, callee_alloc,
6064 &se->ss->info->expr->where);
6066 /* Pass the temporary as the first argument. */
6067 result = info->descriptor;
6068 tmp = gfc_build_addr_expr (NULL_TREE, result);
6069 vec_safe_push (retargs, tmp);
6071 else if (!comp && sym->result->attr.dimension)
6073 gcc_assert (se->loop && info);
6075 /* Set the type of the array. */
6076 tmp = gfc_typenode_for_spec (&ts);
6077 gcc_assert (se->ss->dimen == se->loop->dimen);
6079 /* Evaluate the bounds of the result, if known. */
6080 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6082 /* If the lhs of an assignment x = f(..) is allocatable and
6083 f2003 is allowed, we must not generate the function call
6084 here but should just send back the results of the mapping.
6085 This is signalled by the function ss being flagged. */
6086 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6088 gfc_free_interface_mapping (&mapping);
6089 return has_alternate_specifier;
6092 /* Create a temporary to store the result. In case the function
6093 returns a pointer, the temporary will be a shallow copy and
6094 mustn't be deallocated. */
6095 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6096 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6097 tmp, NULL_TREE, false,
6098 !sym->attr.pointer, callee_alloc,
6099 &se->ss->info->expr->where);
6101 /* Pass the temporary as the first argument. */
6102 result = info->descriptor;
6103 tmp = gfc_build_addr_expr (NULL_TREE, result);
6104 vec_safe_push (retargs, tmp);
6106 else if (ts.type == BT_CHARACTER)
6108 /* Pass the string length. */
6109 type = gfc_get_character_type (ts.kind, ts.u.cl);
6110 type = build_pointer_type (type);
6112 /* Emit a DECL_EXPR for the VLA type. */
6113 tmp = TREE_TYPE (type);
6114 if (TYPE_SIZE (tmp)
6115 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6117 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6118 DECL_ARTIFICIAL (tmp) = 1;
6119 DECL_IGNORED_P (tmp) = 1;
6120 tmp = fold_build1_loc (input_location, DECL_EXPR,
6121 TREE_TYPE (tmp), tmp);
6122 gfc_add_expr_to_block (&se->pre, tmp);
6125 /* Return an address to a char[0:len-1]* temporary for
6126 character pointers. */
6127 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6128 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6130 var = gfc_create_var (type, "pstr");
6132 if ((!comp && sym->attr.allocatable)
6133 || (comp && comp->attr.allocatable))
6135 gfc_add_modify (&se->pre, var,
6136 fold_convert (TREE_TYPE (var),
6137 null_pointer_node));
6138 tmp = gfc_call_free (var);
6139 gfc_add_expr_to_block (&se->post, tmp);
6142 /* Provide an address expression for the function arguments. */
6143 var = gfc_build_addr_expr (NULL_TREE, var);
6145 else
6146 var = gfc_conv_string_tmp (se, type, len);
6148 vec_safe_push (retargs, var);
6150 else
6152 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6154 type = gfc_get_complex_type (ts.kind);
6155 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6156 vec_safe_push (retargs, var);
6159 /* Add the string length to the argument list. */
6160 if (ts.type == BT_CHARACTER && ts.deferred)
6162 tmp = len;
6163 if (!VAR_P (tmp))
6164 tmp = gfc_evaluate_now (len, &se->pre);
6165 TREE_STATIC (tmp) = 1;
6166 gfc_add_modify (&se->pre, tmp,
6167 build_int_cst (TREE_TYPE (tmp), 0));
6168 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6169 vec_safe_push (retargs, tmp);
6171 else if (ts.type == BT_CHARACTER)
6172 vec_safe_push (retargs, len);
6174 gfc_free_interface_mapping (&mapping);
6176 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6177 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6178 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6179 vec_safe_reserve (retargs, arglen);
6181 /* Add the return arguments. */
6182 vec_safe_splice (retargs, arglist);
6184 /* Add the hidden present status for optional+value to the arguments. */
6185 vec_safe_splice (retargs, optionalargs);
6187 /* Add the hidden string length parameters to the arguments. */
6188 vec_safe_splice (retargs, stringargs);
6190 /* We may want to append extra arguments here. This is used e.g. for
6191 calls to libgfortran_matmul_??, which need extra information. */
6192 vec_safe_splice (retargs, append_args);
6194 arglist = retargs;
6196 /* Generate the actual call. */
6197 if (base_object == NULL_TREE)
6198 conv_function_val (se, sym, expr);
6199 else
6200 conv_base_obj_fcn_val (se, base_object, expr);
6202 /* If there are alternate return labels, function type should be
6203 integer. Can't modify the type in place though, since it can be shared
6204 with other functions. For dummy arguments, the typing is done to
6205 this result, even if it has to be repeated for each call. */
6206 if (has_alternate_specifier
6207 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6209 if (!sym->attr.dummy)
6211 TREE_TYPE (sym->backend_decl)
6212 = build_function_type (integer_type_node,
6213 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6214 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6216 else
6217 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6220 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6221 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6223 /* Allocatable scalar function results must be freed and nullified
6224 after use. This necessitates the creation of a temporary to
6225 hold the result to prevent duplicate calls. */
6226 if (!byref && sym->ts.type != BT_CHARACTER
6227 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6228 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6230 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6231 gfc_add_modify (&se->pre, tmp, se->expr);
6232 se->expr = tmp;
6233 tmp = gfc_call_free (tmp);
6234 gfc_add_expr_to_block (&post, tmp);
6235 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6238 /* If we have a pointer function, but we don't want a pointer, e.g.
6239 something like
6240 x = f()
6241 where f is pointer valued, we have to dereference the result. */
6242 if (!se->want_pointer && !byref
6243 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6244 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6245 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6247 /* f2c calling conventions require a scalar default real function to
6248 return a double precision result. Convert this back to default
6249 real. We only care about the cases that can happen in Fortran 77.
6251 if (flag_f2c && sym->ts.type == BT_REAL
6252 && sym->ts.kind == gfc_default_real_kind
6253 && !sym->attr.always_explicit)
6254 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6256 /* A pure function may still have side-effects - it may modify its
6257 parameters. */
6258 TREE_SIDE_EFFECTS (se->expr) = 1;
6259 #if 0
6260 if (!sym->attr.pure)
6261 TREE_SIDE_EFFECTS (se->expr) = 1;
6262 #endif
6264 if (byref)
6266 /* Add the function call to the pre chain. There is no expression. */
6267 gfc_add_expr_to_block (&se->pre, se->expr);
6268 se->expr = NULL_TREE;
6270 if (!se->direct_byref)
6272 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6274 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6276 /* Check the data pointer hasn't been modified. This would
6277 happen in a function returning a pointer. */
6278 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6279 tmp = fold_build2_loc (input_location, NE_EXPR,
6280 logical_type_node,
6281 tmp, info->data);
6282 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6283 gfc_msg_fault);
6285 se->expr = info->descriptor;
6286 /* Bundle in the string length. */
6287 se->string_length = len;
6289 else if (ts.type == BT_CHARACTER)
6291 /* Dereference for character pointer results. */
6292 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6293 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6294 se->expr = build_fold_indirect_ref_loc (input_location, var);
6295 else
6296 se->expr = var;
6298 se->string_length = len;
6300 else
6302 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6303 se->expr = build_fold_indirect_ref_loc (input_location, var);
6308 /* Associate the rhs class object's meta-data with the result, when the
6309 result is a temporary. */
6310 if (args && args->expr && args->expr->ts.type == BT_CLASS
6311 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6312 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6314 gfc_se parmse;
6315 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6317 gfc_init_se (&parmse, NULL);
6318 parmse.data_not_needed = 1;
6319 gfc_conv_expr (&parmse, class_expr);
6320 if (!DECL_LANG_SPECIFIC (result))
6321 gfc_allocate_lang_decl (result);
6322 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6323 gfc_free_expr (class_expr);
6324 gcc_assert (parmse.pre.head == NULL_TREE
6325 && parmse.post.head == NULL_TREE);
6328 /* Follow the function call with the argument post block. */
6329 if (byref)
6331 gfc_add_block_to_block (&se->pre, &post);
6333 /* Transformational functions of derived types with allocatable
6334 components must have the result allocatable components copied when the
6335 argument is actually given. */
6336 arg = expr->value.function.actual;
6337 if (result && arg && expr->rank
6338 && expr->value.function.isym
6339 && expr->value.function.isym->transformational
6340 && arg->expr
6341 && arg->expr->ts.type == BT_DERIVED
6342 && arg->expr->ts.u.derived->attr.alloc_comp)
6344 tree tmp2;
6345 /* Copy the allocatable components. We have to use a
6346 temporary here to prevent source allocatable components
6347 from being corrupted. */
6348 tmp2 = gfc_evaluate_now (result, &se->pre);
6349 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6350 result, tmp2, expr->rank, 0);
6351 gfc_add_expr_to_block (&se->pre, tmp);
6352 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6353 expr->rank);
6354 gfc_add_expr_to_block (&se->pre, tmp);
6356 /* Finally free the temporary's data field. */
6357 tmp = gfc_conv_descriptor_data_get (tmp2);
6358 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6359 NULL_TREE, NULL_TREE, true,
6360 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6361 gfc_add_expr_to_block (&se->pre, tmp);
6364 else
6366 /* For a function with a class array result, save the result as
6367 a temporary, set the info fields needed by the scalarizer and
6368 call the finalization function of the temporary. Note that the
6369 nullification of allocatable components needed by the result
6370 is done in gfc_trans_assignment_1. */
6371 if (expr && ((gfc_is_class_array_function (expr)
6372 && se->ss && se->ss->loop)
6373 || gfc_is_alloc_class_scalar_function (expr))
6374 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6375 && expr->must_finalize)
6377 tree final_fndecl;
6378 tree is_final;
6379 int n;
6380 if (se->ss && se->ss->loop)
6382 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6383 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6384 tmp = gfc_class_data_get (se->expr);
6385 info->descriptor = tmp;
6386 info->data = gfc_conv_descriptor_data_get (tmp);
6387 info->offset = gfc_conv_descriptor_offset_get (tmp);
6388 for (n = 0; n < se->ss->loop->dimen; n++)
6390 tree dim = gfc_rank_cst[n];
6391 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6392 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6395 else
6397 /* TODO Eliminate the doubling of temporaries. This
6398 one is necessary to ensure no memory leakage. */
6399 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6400 tmp = gfc_class_data_get (se->expr);
6401 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6402 CLASS_DATA (expr->value.function.esym->result)->attr);
6405 if ((gfc_is_class_array_function (expr)
6406 || gfc_is_alloc_class_scalar_function (expr))
6407 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6408 goto no_finalization;
6410 final_fndecl = gfc_class_vtab_final_get (se->expr);
6411 is_final = fold_build2_loc (input_location, NE_EXPR,
6412 logical_type_node,
6413 final_fndecl,
6414 fold_convert (TREE_TYPE (final_fndecl),
6415 null_pointer_node));
6416 final_fndecl = build_fold_indirect_ref_loc (input_location,
6417 final_fndecl);
6418 tmp = build_call_expr_loc (input_location,
6419 final_fndecl, 3,
6420 gfc_build_addr_expr (NULL, tmp),
6421 gfc_class_vtab_size_get (se->expr),
6422 boolean_false_node);
6423 tmp = fold_build3_loc (input_location, COND_EXPR,
6424 void_type_node, is_final, tmp,
6425 build_empty_stmt (input_location));
6427 if (se->ss && se->ss->loop)
6429 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6430 tmp = gfc_call_free (info->data);
6431 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6433 else
6435 gfc_add_expr_to_block (&se->post, tmp);
6436 tmp = gfc_class_data_get (se->expr);
6437 tmp = gfc_call_free (tmp);
6438 gfc_add_expr_to_block (&se->post, tmp);
6441 no_finalization:
6442 expr->must_finalize = 0;
6445 gfc_add_block_to_block (&se->post, &post);
6448 return has_alternate_specifier;
6452 /* Fill a character string with spaces. */
6454 static tree
6455 fill_with_spaces (tree start, tree type, tree size)
6457 stmtblock_t block, loop;
6458 tree i, el, exit_label, cond, tmp;
6460 /* For a simple char type, we can call memset(). */
6461 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6462 return build_call_expr_loc (input_location,
6463 builtin_decl_explicit (BUILT_IN_MEMSET),
6464 3, start,
6465 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6466 lang_hooks.to_target_charset (' ')),
6467 fold_convert (size_type_node, size));
6469 /* Otherwise, we use a loop:
6470 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6471 *el = (type) ' ';
6474 /* Initialize variables. */
6475 gfc_init_block (&block);
6476 i = gfc_create_var (sizetype, "i");
6477 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6478 el = gfc_create_var (build_pointer_type (type), "el");
6479 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6480 exit_label = gfc_build_label_decl (NULL_TREE);
6481 TREE_USED (exit_label) = 1;
6484 /* Loop body. */
6485 gfc_init_block (&loop);
6487 /* Exit condition. */
6488 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6489 build_zero_cst (sizetype));
6490 tmp = build1_v (GOTO_EXPR, exit_label);
6491 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6492 build_empty_stmt (input_location));
6493 gfc_add_expr_to_block (&loop, tmp);
6495 /* Assignment. */
6496 gfc_add_modify (&loop,
6497 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6498 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6500 /* Increment loop variables. */
6501 gfc_add_modify (&loop, i,
6502 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6503 TYPE_SIZE_UNIT (type)));
6504 gfc_add_modify (&loop, el,
6505 fold_build_pointer_plus_loc (input_location,
6506 el, TYPE_SIZE_UNIT (type)));
6508 /* Making the loop... actually loop! */
6509 tmp = gfc_finish_block (&loop);
6510 tmp = build1_v (LOOP_EXPR, tmp);
6511 gfc_add_expr_to_block (&block, tmp);
6513 /* The exit label. */
6514 tmp = build1_v (LABEL_EXPR, exit_label);
6515 gfc_add_expr_to_block (&block, tmp);
6518 return gfc_finish_block (&block);
6522 /* Generate code to copy a string. */
6524 void
6525 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6526 int dkind, tree slength, tree src, int skind)
6528 tree tmp, dlen, slen;
6529 tree dsc;
6530 tree ssc;
6531 tree cond;
6532 tree cond2;
6533 tree tmp2;
6534 tree tmp3;
6535 tree tmp4;
6536 tree chartype;
6537 stmtblock_t tempblock;
6539 gcc_assert (dkind == skind);
6541 if (slength != NULL_TREE)
6543 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6544 ssc = gfc_string_to_single_character (slen, src, skind);
6546 else
6548 slen = build_one_cst (gfc_charlen_type_node);
6549 ssc = src;
6552 if (dlength != NULL_TREE)
6554 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6555 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6557 else
6559 dlen = build_one_cst (gfc_charlen_type_node);
6560 dsc = dest;
6563 /* Assign directly if the types are compatible. */
6564 if (dsc != NULL_TREE && ssc != NULL_TREE
6565 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6567 gfc_add_modify (block, dsc, ssc);
6568 return;
6571 /* The string copy algorithm below generates code like
6573 if (destlen > 0)
6575 if (srclen < destlen)
6577 memmove (dest, src, srclen);
6578 // Pad with spaces.
6579 memset (&dest[srclen], ' ', destlen - srclen);
6581 else
6583 // Truncate if too long.
6584 memmove (dest, src, destlen);
6589 /* Do nothing if the destination length is zero. */
6590 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6591 build_zero_cst (TREE_TYPE (dlen)));
6593 /* For non-default character kinds, we have to multiply the string
6594 length by the base type size. */
6595 chartype = gfc_get_char_type (dkind);
6596 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6597 slen,
6598 fold_convert (TREE_TYPE (slen),
6599 TYPE_SIZE_UNIT (chartype)));
6600 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
6601 dlen,
6602 fold_convert (TREE_TYPE (dlen),
6603 TYPE_SIZE_UNIT (chartype)));
6605 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6606 dest = fold_convert (pvoid_type_node, dest);
6607 else
6608 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6610 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6611 src = fold_convert (pvoid_type_node, src);
6612 else
6613 src = gfc_build_addr_expr (pvoid_type_node, src);
6615 /* Truncate string if source is too long. */
6616 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
6617 dlen);
6619 /* Copy and pad with spaces. */
6620 tmp3 = build_call_expr_loc (input_location,
6621 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6622 3, dest, src,
6623 fold_convert (size_type_node, slen));
6625 /* Wstringop-overflow appears at -O3 even though this warning is not
6626 explicitly available in fortran nor can it be switched off. If the
6627 source length is a constant, its negative appears as a very large
6628 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6629 the result of the MINUS_EXPR suppresses this spurious warning. */
6630 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6631 TREE_TYPE(dlen), dlen, slen);
6632 if (slength && TREE_CONSTANT (slength))
6633 tmp = gfc_evaluate_now (tmp, block);
6635 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6636 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6638 gfc_init_block (&tempblock);
6639 gfc_add_expr_to_block (&tempblock, tmp3);
6640 gfc_add_expr_to_block (&tempblock, tmp4);
6641 tmp3 = gfc_finish_block (&tempblock);
6643 /* The truncated memmove if the slen >= dlen. */
6644 tmp2 = build_call_expr_loc (input_location,
6645 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6646 3, dest, src,
6647 fold_convert (size_type_node, dlen));
6649 /* The whole copy_string function is there. */
6650 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6651 tmp3, tmp2);
6652 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6653 build_empty_stmt (input_location));
6654 gfc_add_expr_to_block (block, tmp);
6658 /* Translate a statement function.
6659 The value of a statement function reference is obtained by evaluating the
6660 expression using the values of the actual arguments for the values of the
6661 corresponding dummy arguments. */
6663 static void
6664 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6666 gfc_symbol *sym;
6667 gfc_symbol *fsym;
6668 gfc_formal_arglist *fargs;
6669 gfc_actual_arglist *args;
6670 gfc_se lse;
6671 gfc_se rse;
6672 gfc_saved_var *saved_vars;
6673 tree *temp_vars;
6674 tree type;
6675 tree tmp;
6676 int n;
6678 sym = expr->symtree->n.sym;
6679 args = expr->value.function.actual;
6680 gfc_init_se (&lse, NULL);
6681 gfc_init_se (&rse, NULL);
6683 n = 0;
6684 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6685 n++;
6686 saved_vars = XCNEWVEC (gfc_saved_var, n);
6687 temp_vars = XCNEWVEC (tree, n);
6689 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6690 fargs = fargs->next, n++)
6692 /* Each dummy shall be specified, explicitly or implicitly, to be
6693 scalar. */
6694 gcc_assert (fargs->sym->attr.dimension == 0);
6695 fsym = fargs->sym;
6697 if (fsym->ts.type == BT_CHARACTER)
6699 /* Copy string arguments. */
6700 tree arglen;
6702 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6703 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6705 /* Create a temporary to hold the value. */
6706 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6707 fsym->ts.u.cl->backend_decl
6708 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6710 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6711 temp_vars[n] = gfc_create_var (type, fsym->name);
6713 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6715 gfc_conv_expr (&rse, args->expr);
6716 gfc_conv_string_parameter (&rse);
6717 gfc_add_block_to_block (&se->pre, &lse.pre);
6718 gfc_add_block_to_block (&se->pre, &rse.pre);
6720 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6721 rse.string_length, rse.expr, fsym->ts.kind);
6722 gfc_add_block_to_block (&se->pre, &lse.post);
6723 gfc_add_block_to_block (&se->pre, &rse.post);
6725 else
6727 /* For everything else, just evaluate the expression. */
6729 /* Create a temporary to hold the value. */
6730 type = gfc_typenode_for_spec (&fsym->ts);
6731 temp_vars[n] = gfc_create_var (type, fsym->name);
6733 gfc_conv_expr (&lse, args->expr);
6735 gfc_add_block_to_block (&se->pre, &lse.pre);
6736 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6737 gfc_add_block_to_block (&se->pre, &lse.post);
6740 args = args->next;
6743 /* Use the temporary variables in place of the real ones. */
6744 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6745 fargs = fargs->next, n++)
6746 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6748 gfc_conv_expr (se, sym->value);
6750 if (sym->ts.type == BT_CHARACTER)
6752 gfc_conv_const_charlen (sym->ts.u.cl);
6754 /* Force the expression to the correct length. */
6755 if (!INTEGER_CST_P (se->string_length)
6756 || tree_int_cst_lt (se->string_length,
6757 sym->ts.u.cl->backend_decl))
6759 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6760 tmp = gfc_create_var (type, sym->name);
6761 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6762 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6763 sym->ts.kind, se->string_length, se->expr,
6764 sym->ts.kind);
6765 se->expr = tmp;
6767 se->string_length = sym->ts.u.cl->backend_decl;
6770 /* Restore the original variables. */
6771 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6772 fargs = fargs->next, n++)
6773 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6774 free (temp_vars);
6775 free (saved_vars);
6779 /* Translate a function expression. */
6781 static void
6782 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6784 gfc_symbol *sym;
6786 if (expr->value.function.isym)
6788 gfc_conv_intrinsic_function (se, expr);
6789 return;
6792 /* expr.value.function.esym is the resolved (specific) function symbol for
6793 most functions. However this isn't set for dummy procedures. */
6794 sym = expr->value.function.esym;
6795 if (!sym)
6796 sym = expr->symtree->n.sym;
6798 /* The IEEE_ARITHMETIC functions are caught here. */
6799 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6800 if (gfc_conv_ieee_arithmetic_function (se, expr))
6801 return;
6803 /* We distinguish statement functions from general functions to improve
6804 runtime performance. */
6805 if (sym->attr.proc == PROC_ST_FUNCTION)
6807 gfc_conv_statement_function (se, expr);
6808 return;
6811 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6812 NULL);
6816 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6818 static bool
6819 is_zero_initializer_p (gfc_expr * expr)
6821 if (expr->expr_type != EXPR_CONSTANT)
6822 return false;
6824 /* We ignore constants with prescribed memory representations for now. */
6825 if (expr->representation.string)
6826 return false;
6828 switch (expr->ts.type)
6830 case BT_INTEGER:
6831 return mpz_cmp_si (expr->value.integer, 0) == 0;
6833 case BT_REAL:
6834 return mpfr_zero_p (expr->value.real)
6835 && MPFR_SIGN (expr->value.real) >= 0;
6837 case BT_LOGICAL:
6838 return expr->value.logical == 0;
6840 case BT_COMPLEX:
6841 return mpfr_zero_p (mpc_realref (expr->value.complex))
6842 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
6843 && mpfr_zero_p (mpc_imagref (expr->value.complex))
6844 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
6846 default:
6847 break;
6849 return false;
6853 static void
6854 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
6856 gfc_ss *ss;
6858 ss = se->ss;
6859 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
6860 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
6862 gfc_conv_tmp_array_ref (se);
6866 /* Build a static initializer. EXPR is the expression for the initial value.
6867 The other parameters describe the variable of the component being
6868 initialized. EXPR may be null. */
6870 tree
6871 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
6872 bool array, bool pointer, bool procptr)
6874 gfc_se se;
6876 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
6877 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6878 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
6879 return build_constructor (type, NULL);
6881 if (!(expr || pointer || procptr))
6882 return NULL_TREE;
6884 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6885 (these are the only two iso_c_binding derived types that can be
6886 used as initialization expressions). If so, we need to modify
6887 the 'expr' to be that for a (void *). */
6888 if (expr != NULL && expr->ts.type == BT_DERIVED
6889 && expr->ts.is_iso_c && expr->ts.u.derived)
6891 gfc_symbol *derived = expr->ts.u.derived;
6893 /* The derived symbol has already been converted to a (void *). Use
6894 its kind. */
6895 if (derived->ts.kind == 0)
6896 derived->ts.kind = gfc_default_integer_kind;
6897 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
6898 expr->ts.f90_type = derived->ts.f90_type;
6900 gfc_init_se (&se, NULL);
6901 gfc_conv_constant (&se, expr);
6902 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6903 return se.expr;
6906 if (array && !procptr)
6908 tree ctor;
6909 /* Arrays need special handling. */
6910 if (pointer)
6911 ctor = gfc_build_null_descriptor (type);
6912 /* Special case assigning an array to zero. */
6913 else if (is_zero_initializer_p (expr))
6914 ctor = build_constructor (type, NULL);
6915 else
6916 ctor = gfc_conv_array_initializer (type, expr);
6917 TREE_STATIC (ctor) = 1;
6918 return ctor;
6920 else if (pointer || procptr)
6922 if (ts->type == BT_CLASS && !procptr)
6924 gfc_init_se (&se, NULL);
6925 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
6926 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
6927 TREE_STATIC (se.expr) = 1;
6928 return se.expr;
6930 else if (!expr || expr->expr_type == EXPR_NULL)
6931 return fold_convert (type, null_pointer_node);
6932 else
6934 gfc_init_se (&se, NULL);
6935 se.want_pointer = 1;
6936 gfc_conv_expr (&se, expr);
6937 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6938 return se.expr;
6941 else
6943 switch (ts->type)
6945 case_bt_struct:
6946 case BT_CLASS:
6947 gfc_init_se (&se, NULL);
6948 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
6949 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
6950 else
6951 gfc_conv_structure (&se, expr, 1);
6952 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
6953 TREE_STATIC (se.expr) = 1;
6954 return se.expr;
6956 case BT_CHARACTER:
6958 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
6959 TREE_STATIC (ctor) = 1;
6960 return ctor;
6963 default:
6964 gfc_init_se (&se, NULL);
6965 gfc_conv_constant (&se, expr);
6966 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6967 return se.expr;
6972 static tree
6973 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
6975 gfc_se rse;
6976 gfc_se lse;
6977 gfc_ss *rss;
6978 gfc_ss *lss;
6979 gfc_array_info *lss_array;
6980 stmtblock_t body;
6981 stmtblock_t block;
6982 gfc_loopinfo loop;
6983 int n;
6984 tree tmp;
6986 gfc_start_block (&block);
6988 /* Initialize the scalarizer. */
6989 gfc_init_loopinfo (&loop);
6991 gfc_init_se (&lse, NULL);
6992 gfc_init_se (&rse, NULL);
6994 /* Walk the rhs. */
6995 rss = gfc_walk_expr (expr);
6996 if (rss == gfc_ss_terminator)
6997 /* The rhs is scalar. Add a ss for the expression. */
6998 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7000 /* Create a SS for the destination. */
7001 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7002 GFC_SS_COMPONENT);
7003 lss_array = &lss->info->data.array;
7004 lss_array->shape = gfc_get_shape (cm->as->rank);
7005 lss_array->descriptor = dest;
7006 lss_array->data = gfc_conv_array_data (dest);
7007 lss_array->offset = gfc_conv_array_offset (dest);
7008 for (n = 0; n < cm->as->rank; n++)
7010 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7011 lss_array->stride[n] = gfc_index_one_node;
7013 mpz_init (lss_array->shape[n]);
7014 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7015 cm->as->lower[n]->value.integer);
7016 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7019 /* Associate the SS with the loop. */
7020 gfc_add_ss_to_loop (&loop, lss);
7021 gfc_add_ss_to_loop (&loop, rss);
7023 /* Calculate the bounds of the scalarization. */
7024 gfc_conv_ss_startstride (&loop);
7026 /* Setup the scalarizing loops. */
7027 gfc_conv_loop_setup (&loop, &expr->where);
7029 /* Setup the gfc_se structures. */
7030 gfc_copy_loopinfo_to_se (&lse, &loop);
7031 gfc_copy_loopinfo_to_se (&rse, &loop);
7033 rse.ss = rss;
7034 gfc_mark_ss_chain_used (rss, 1);
7035 lse.ss = lss;
7036 gfc_mark_ss_chain_used (lss, 1);
7038 /* Start the scalarized loop body. */
7039 gfc_start_scalarized_body (&loop, &body);
7041 gfc_conv_tmp_array_ref (&lse);
7042 if (cm->ts.type == BT_CHARACTER)
7043 lse.string_length = cm->ts.u.cl->backend_decl;
7045 gfc_conv_expr (&rse, expr);
7047 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7048 gfc_add_expr_to_block (&body, tmp);
7050 gcc_assert (rse.ss == gfc_ss_terminator);
7052 /* Generate the copying loops. */
7053 gfc_trans_scalarizing_loops (&loop, &body);
7055 /* Wrap the whole thing up. */
7056 gfc_add_block_to_block (&block, &loop.pre);
7057 gfc_add_block_to_block (&block, &loop.post);
7059 gcc_assert (lss_array->shape != NULL);
7060 gfc_free_shape (&lss_array->shape, cm->as->rank);
7061 gfc_cleanup_loop (&loop);
7063 return gfc_finish_block (&block);
7067 static tree
7068 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7069 gfc_expr * expr)
7071 gfc_se se;
7072 stmtblock_t block;
7073 tree offset;
7074 int n;
7075 tree tmp;
7076 tree tmp2;
7077 gfc_array_spec *as;
7078 gfc_expr *arg = NULL;
7080 gfc_start_block (&block);
7081 gfc_init_se (&se, NULL);
7083 /* Get the descriptor for the expressions. */
7084 se.want_pointer = 0;
7085 gfc_conv_expr_descriptor (&se, expr);
7086 gfc_add_block_to_block (&block, &se.pre);
7087 gfc_add_modify (&block, dest, se.expr);
7089 /* Deal with arrays of derived types with allocatable components. */
7090 if (gfc_bt_struct (cm->ts.type)
7091 && cm->ts.u.derived->attr.alloc_comp)
7092 // TODO: Fix caf_mode
7093 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7094 se.expr, dest,
7095 cm->as->rank, 0);
7096 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7097 && CLASS_DATA(cm)->attr.allocatable)
7099 if (cm->ts.u.derived->attr.alloc_comp)
7100 // TODO: Fix caf_mode
7101 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7102 se.expr, dest,
7103 expr->rank, 0);
7104 else
7106 tmp = TREE_TYPE (dest);
7107 tmp = gfc_duplicate_allocatable (dest, se.expr,
7108 tmp, expr->rank, NULL_TREE);
7111 else
7112 tmp = gfc_duplicate_allocatable (dest, se.expr,
7113 TREE_TYPE(cm->backend_decl),
7114 cm->as->rank, NULL_TREE);
7116 gfc_add_expr_to_block (&block, tmp);
7117 gfc_add_block_to_block (&block, &se.post);
7119 if (expr->expr_type != EXPR_VARIABLE)
7120 gfc_conv_descriptor_data_set (&block, se.expr,
7121 null_pointer_node);
7123 /* We need to know if the argument of a conversion function is a
7124 variable, so that the correct lower bound can be used. */
7125 if (expr->expr_type == EXPR_FUNCTION
7126 && expr->value.function.isym
7127 && expr->value.function.isym->conversion
7128 && expr->value.function.actual->expr
7129 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7130 arg = expr->value.function.actual->expr;
7132 /* Obtain the array spec of full array references. */
7133 if (arg)
7134 as = gfc_get_full_arrayspec_from_expr (arg);
7135 else
7136 as = gfc_get_full_arrayspec_from_expr (expr);
7138 /* Shift the lbound and ubound of temporaries to being unity,
7139 rather than zero, based. Always calculate the offset. */
7140 offset = gfc_conv_descriptor_offset_get (dest);
7141 gfc_add_modify (&block, offset, gfc_index_zero_node);
7142 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7144 for (n = 0; n < expr->rank; n++)
7146 tree span;
7147 tree lbound;
7149 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7150 TODO It looks as if gfc_conv_expr_descriptor should return
7151 the correct bounds and that the following should not be
7152 necessary. This would simplify gfc_conv_intrinsic_bound
7153 as well. */
7154 if (as && as->lower[n])
7156 gfc_se lbse;
7157 gfc_init_se (&lbse, NULL);
7158 gfc_conv_expr (&lbse, as->lower[n]);
7159 gfc_add_block_to_block (&block, &lbse.pre);
7160 lbound = gfc_evaluate_now (lbse.expr, &block);
7162 else if (as && arg)
7164 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7165 lbound = gfc_conv_descriptor_lbound_get (tmp,
7166 gfc_rank_cst[n]);
7168 else if (as)
7169 lbound = gfc_conv_descriptor_lbound_get (dest,
7170 gfc_rank_cst[n]);
7171 else
7172 lbound = gfc_index_one_node;
7174 lbound = fold_convert (gfc_array_index_type, lbound);
7176 /* Shift the bounds and set the offset accordingly. */
7177 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7178 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7179 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7180 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7181 span, lbound);
7182 gfc_conv_descriptor_ubound_set (&block, dest,
7183 gfc_rank_cst[n], tmp);
7184 gfc_conv_descriptor_lbound_set (&block, dest,
7185 gfc_rank_cst[n], lbound);
7187 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7188 gfc_conv_descriptor_lbound_get (dest,
7189 gfc_rank_cst[n]),
7190 gfc_conv_descriptor_stride_get (dest,
7191 gfc_rank_cst[n]));
7192 gfc_add_modify (&block, tmp2, tmp);
7193 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7194 offset, tmp2);
7195 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7198 if (arg)
7200 /* If a conversion expression has a null data pointer
7201 argument, nullify the allocatable component. */
7202 tree non_null_expr;
7203 tree null_expr;
7205 if (arg->symtree->n.sym->attr.allocatable
7206 || arg->symtree->n.sym->attr.pointer)
7208 non_null_expr = gfc_finish_block (&block);
7209 gfc_start_block (&block);
7210 gfc_conv_descriptor_data_set (&block, dest,
7211 null_pointer_node);
7212 null_expr = gfc_finish_block (&block);
7213 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7214 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7215 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7216 return build3_v (COND_EXPR, tmp,
7217 null_expr, non_null_expr);
7221 return gfc_finish_block (&block);
7225 /* Allocate or reallocate scalar component, as necessary. */
7227 static void
7228 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7229 tree comp,
7230 gfc_component *cm,
7231 gfc_expr *expr2,
7232 gfc_symbol *sym)
7234 tree tmp;
7235 tree ptr;
7236 tree size;
7237 tree size_in_bytes;
7238 tree lhs_cl_size = NULL_TREE;
7240 if (!comp)
7241 return;
7243 if (!expr2 || expr2->rank)
7244 return;
7246 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7248 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7250 char name[GFC_MAX_SYMBOL_LEN+9];
7251 gfc_component *strlen;
7252 /* Use the rhs string length and the lhs element size. */
7253 gcc_assert (expr2->ts.type == BT_CHARACTER);
7254 if (!expr2->ts.u.cl->backend_decl)
7256 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7257 gcc_assert (expr2->ts.u.cl->backend_decl);
7260 size = expr2->ts.u.cl->backend_decl;
7262 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7263 component. */
7264 sprintf (name, "_%s_length", cm->name);
7265 strlen = gfc_find_component (sym, name, true, true, NULL);
7266 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7267 gfc_charlen_type_node,
7268 TREE_OPERAND (comp, 0),
7269 strlen->backend_decl, NULL_TREE);
7271 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7272 tmp = TYPE_SIZE_UNIT (tmp);
7273 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7274 TREE_TYPE (tmp), tmp,
7275 fold_convert (TREE_TYPE (tmp), size));
7277 else if (cm->ts.type == BT_CLASS)
7279 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7280 if (expr2->ts.type == BT_DERIVED)
7282 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7283 size = TYPE_SIZE_UNIT (tmp);
7285 else
7287 gfc_expr *e2vtab;
7288 gfc_se se;
7289 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7290 gfc_add_vptr_component (e2vtab);
7291 gfc_add_size_component (e2vtab);
7292 gfc_init_se (&se, NULL);
7293 gfc_conv_expr (&se, e2vtab);
7294 gfc_add_block_to_block (block, &se.pre);
7295 size = fold_convert (size_type_node, se.expr);
7296 gfc_free_expr (e2vtab);
7298 size_in_bytes = size;
7300 else
7302 /* Otherwise use the length in bytes of the rhs. */
7303 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7304 size_in_bytes = size;
7307 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7308 size_in_bytes, size_one_node);
7310 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7312 tmp = build_call_expr_loc (input_location,
7313 builtin_decl_explicit (BUILT_IN_CALLOC),
7314 2, build_one_cst (size_type_node),
7315 size_in_bytes);
7316 tmp = fold_convert (TREE_TYPE (comp), tmp);
7317 gfc_add_modify (block, comp, tmp);
7319 else
7321 tmp = build_call_expr_loc (input_location,
7322 builtin_decl_explicit (BUILT_IN_MALLOC),
7323 1, size_in_bytes);
7324 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7325 ptr = gfc_class_data_get (comp);
7326 else
7327 ptr = comp;
7328 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7329 gfc_add_modify (block, ptr, tmp);
7332 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7333 /* Update the lhs character length. */
7334 gfc_add_modify (block, lhs_cl_size,
7335 fold_convert (TREE_TYPE (lhs_cl_size), size));
7339 /* Assign a single component of a derived type constructor. */
7341 static tree
7342 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7343 gfc_symbol *sym, bool init)
7345 gfc_se se;
7346 gfc_se lse;
7347 stmtblock_t block;
7348 tree tmp;
7349 tree vtab;
7351 gfc_start_block (&block);
7353 if (cm->attr.pointer || cm->attr.proc_pointer)
7355 /* Only care about pointers here, not about allocatables. */
7356 gfc_init_se (&se, NULL);
7357 /* Pointer component. */
7358 if ((cm->attr.dimension || cm->attr.codimension)
7359 && !cm->attr.proc_pointer)
7361 /* Array pointer. */
7362 if (expr->expr_type == EXPR_NULL)
7363 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7364 else
7366 se.direct_byref = 1;
7367 se.expr = dest;
7368 gfc_conv_expr_descriptor (&se, expr);
7369 gfc_add_block_to_block (&block, &se.pre);
7370 gfc_add_block_to_block (&block, &se.post);
7373 else
7375 /* Scalar pointers. */
7376 se.want_pointer = 1;
7377 gfc_conv_expr (&se, expr);
7378 gfc_add_block_to_block (&block, &se.pre);
7380 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7381 && expr->symtree->n.sym->attr.dummy)
7382 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7384 gfc_add_modify (&block, dest,
7385 fold_convert (TREE_TYPE (dest), se.expr));
7386 gfc_add_block_to_block (&block, &se.post);
7389 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7391 /* NULL initialization for CLASS components. */
7392 tmp = gfc_trans_structure_assign (dest,
7393 gfc_class_initializer (&cm->ts, expr),
7394 false);
7395 gfc_add_expr_to_block (&block, tmp);
7397 else if ((cm->attr.dimension || cm->attr.codimension)
7398 && !cm->attr.proc_pointer)
7400 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7401 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7402 else if (cm->attr.allocatable || cm->attr.pdt_array)
7404 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7405 gfc_add_expr_to_block (&block, tmp);
7407 else
7409 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7410 gfc_add_expr_to_block (&block, tmp);
7413 else if (cm->ts.type == BT_CLASS
7414 && CLASS_DATA (cm)->attr.dimension
7415 && CLASS_DATA (cm)->attr.allocatable
7416 && expr->ts.type == BT_DERIVED)
7418 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7419 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7420 tmp = gfc_class_vptr_get (dest);
7421 gfc_add_modify (&block, tmp,
7422 fold_convert (TREE_TYPE (tmp), vtab));
7423 tmp = gfc_class_data_get (dest);
7424 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7425 gfc_add_expr_to_block (&block, tmp);
7427 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7429 /* NULL initialization for allocatable components. */
7430 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7431 null_pointer_node));
7433 else if (init && (cm->attr.allocatable
7434 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7435 && expr->ts.type != BT_CLASS)))
7437 /* Take care about non-array allocatable components here. The alloc_*
7438 routine below is motivated by the alloc_scalar_allocatable_for_
7439 assignment() routine, but with the realloc portions removed and
7440 different input. */
7441 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7442 dest,
7444 expr,
7445 sym);
7446 /* The remainder of these instructions follow the if (cm->attr.pointer)
7447 if (!cm->attr.dimension) part above. */
7448 gfc_init_se (&se, NULL);
7449 gfc_conv_expr (&se, expr);
7450 gfc_add_block_to_block (&block, &se.pre);
7452 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7453 && expr->symtree->n.sym->attr.dummy)
7454 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7456 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7458 tmp = gfc_class_data_get (dest);
7459 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7460 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7461 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7462 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7463 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7465 else
7466 tmp = build_fold_indirect_ref_loc (input_location, dest);
7468 /* For deferred strings insert a memcpy. */
7469 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7471 tree size;
7472 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7473 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7474 ? se.string_length
7475 : expr->ts.u.cl->backend_decl);
7476 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7477 gfc_add_expr_to_block (&block, tmp);
7479 else
7480 gfc_add_modify (&block, tmp,
7481 fold_convert (TREE_TYPE (tmp), se.expr));
7482 gfc_add_block_to_block (&block, &se.post);
7484 else if (expr->ts.type == BT_UNION)
7486 tree tmp;
7487 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7488 /* We mark that the entire union should be initialized with a contrived
7489 EXPR_NULL expression at the beginning. */
7490 if (c != NULL && c->n.component == NULL
7491 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7493 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7494 dest, build_constructor (TREE_TYPE (dest), NULL));
7495 gfc_add_expr_to_block (&block, tmp);
7496 c = gfc_constructor_next (c);
7498 /* The following constructor expression, if any, represents a specific
7499 map intializer, as given by the user. */
7500 if (c != NULL && c->expr != NULL)
7502 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7503 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7504 gfc_add_expr_to_block (&block, tmp);
7507 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7509 if (expr->expr_type != EXPR_STRUCTURE)
7511 tree dealloc = NULL_TREE;
7512 gfc_init_se (&se, NULL);
7513 gfc_conv_expr (&se, expr);
7514 gfc_add_block_to_block (&block, &se.pre);
7515 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7516 expression in a temporary variable and deallocate the allocatable
7517 components. Then we can the copy the expression to the result. */
7518 if (cm->ts.u.derived->attr.alloc_comp
7519 && expr->expr_type != EXPR_VARIABLE)
7521 se.expr = gfc_evaluate_now (se.expr, &block);
7522 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7523 expr->rank);
7525 gfc_add_modify (&block, dest,
7526 fold_convert (TREE_TYPE (dest), se.expr));
7527 if (cm->ts.u.derived->attr.alloc_comp
7528 && expr->expr_type != EXPR_NULL)
7530 // TODO: Fix caf_mode
7531 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7532 dest, expr->rank, 0);
7533 gfc_add_expr_to_block (&block, tmp);
7534 if (dealloc != NULL_TREE)
7535 gfc_add_expr_to_block (&block, dealloc);
7537 gfc_add_block_to_block (&block, &se.post);
7539 else
7541 /* Nested constructors. */
7542 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7543 gfc_add_expr_to_block (&block, tmp);
7546 else if (gfc_deferred_strlen (cm, &tmp))
7548 tree strlen;
7549 strlen = tmp;
7550 gcc_assert (strlen);
7551 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7552 TREE_TYPE (strlen),
7553 TREE_OPERAND (dest, 0),
7554 strlen, NULL_TREE);
7556 if (expr->expr_type == EXPR_NULL)
7558 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7559 gfc_add_modify (&block, dest, tmp);
7560 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7561 gfc_add_modify (&block, strlen, tmp);
7563 else
7565 tree size;
7566 gfc_init_se (&se, NULL);
7567 gfc_conv_expr (&se, expr);
7568 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7569 tmp = build_call_expr_loc (input_location,
7570 builtin_decl_explicit (BUILT_IN_MALLOC),
7571 1, size);
7572 gfc_add_modify (&block, dest,
7573 fold_convert (TREE_TYPE (dest), tmp));
7574 gfc_add_modify (&block, strlen,
7575 fold_convert (TREE_TYPE (strlen), se.string_length));
7576 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7577 gfc_add_expr_to_block (&block, tmp);
7580 else if (!cm->attr.artificial)
7582 /* Scalar component (excluding deferred parameters). */
7583 gfc_init_se (&se, NULL);
7584 gfc_init_se (&lse, NULL);
7586 gfc_conv_expr (&se, expr);
7587 if (cm->ts.type == BT_CHARACTER)
7588 lse.string_length = cm->ts.u.cl->backend_decl;
7589 lse.expr = dest;
7590 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7591 gfc_add_expr_to_block (&block, tmp);
7593 return gfc_finish_block (&block);
7596 /* Assign a derived type constructor to a variable. */
7598 tree
7599 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7601 gfc_constructor *c;
7602 gfc_component *cm;
7603 stmtblock_t block;
7604 tree field;
7605 tree tmp;
7606 gfc_se se;
7608 gfc_start_block (&block);
7609 cm = expr->ts.u.derived->components;
7611 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7612 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7613 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7615 gfc_se lse;
7617 gfc_init_se (&se, NULL);
7618 gfc_init_se (&lse, NULL);
7619 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7620 lse.expr = dest;
7621 gfc_add_modify (&block, lse.expr,
7622 fold_convert (TREE_TYPE (lse.expr), se.expr));
7624 return gfc_finish_block (&block);
7627 if (coarray)
7628 gfc_init_se (&se, NULL);
7630 for (c = gfc_constructor_first (expr->value.constructor);
7631 c; c = gfc_constructor_next (c), cm = cm->next)
7633 /* Skip absent members in default initializers. */
7634 if (!c->expr && !cm->attr.allocatable)
7635 continue;
7637 /* Register the component with the caf-lib before it is initialized.
7638 Register only allocatable components, that are not coarray'ed
7639 components (%comp[*]). Only register when the constructor is not the
7640 null-expression. */
7641 if (coarray && !cm->attr.codimension
7642 && (cm->attr.allocatable || cm->attr.pointer)
7643 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7645 tree token, desc, size;
7646 bool is_array = cm->ts.type == BT_CLASS
7647 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7649 field = cm->backend_decl;
7650 field = fold_build3_loc (input_location, COMPONENT_REF,
7651 TREE_TYPE (field), dest, field, NULL_TREE);
7652 if (cm->ts.type == BT_CLASS)
7653 field = gfc_class_data_get (field);
7655 token = is_array ? gfc_conv_descriptor_token (field)
7656 : fold_build3_loc (input_location, COMPONENT_REF,
7657 TREE_TYPE (cm->caf_token), dest,
7658 cm->caf_token, NULL_TREE);
7660 if (is_array)
7662 /* The _caf_register routine looks at the rank of the array
7663 descriptor to decide whether the data registered is an array
7664 or not. */
7665 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7666 : cm->as->rank;
7667 /* When the rank is not known just set a positive rank, which
7668 suffices to recognize the data as array. */
7669 if (rank < 0)
7670 rank = 1;
7671 size = integer_zero_node;
7672 desc = field;
7673 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
7674 build_int_cst (signed_char_type_node, rank));
7676 else
7678 desc = gfc_conv_scalar_to_descriptor (&se, field,
7679 cm->ts.type == BT_CLASS
7680 ? CLASS_DATA (cm)->attr
7681 : cm->attr);
7682 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7684 gfc_add_block_to_block (&block, &se.pre);
7685 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7686 7, size, build_int_cst (
7687 integer_type_node,
7688 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7689 gfc_build_addr_expr (pvoid_type_node,
7690 token),
7691 gfc_build_addr_expr (NULL_TREE, desc),
7692 null_pointer_node, null_pointer_node,
7693 integer_zero_node);
7694 gfc_add_expr_to_block (&block, tmp);
7696 field = cm->backend_decl;
7697 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7698 dest, field, NULL_TREE);
7699 if (!c->expr)
7701 gfc_expr *e = gfc_get_null_expr (NULL);
7702 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7703 init);
7704 gfc_free_expr (e);
7706 else
7707 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7708 expr->ts.u.derived, init);
7709 gfc_add_expr_to_block (&block, tmp);
7711 return gfc_finish_block (&block);
7714 void
7715 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7716 gfc_component *un, gfc_expr *init)
7718 gfc_constructor *ctor;
7720 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7721 return;
7723 ctor = gfc_constructor_first (init->value.constructor);
7725 if (ctor == NULL || ctor->expr == NULL)
7726 return;
7728 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7730 /* If we have an 'initialize all' constructor, do it first. */
7731 if (ctor->expr->expr_type == EXPR_NULL)
7733 tree union_type = TREE_TYPE (un->backend_decl);
7734 tree val = build_constructor (union_type, NULL);
7735 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7736 ctor = gfc_constructor_next (ctor);
7739 /* Add the map initializer on top. */
7740 if (ctor != NULL && ctor->expr != NULL)
7742 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7743 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7744 TREE_TYPE (un->backend_decl),
7745 un->attr.dimension, un->attr.pointer,
7746 un->attr.proc_pointer);
7747 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7751 /* Build an expression for a constructor. If init is nonzero then
7752 this is part of a static variable initializer. */
7754 void
7755 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7757 gfc_constructor *c;
7758 gfc_component *cm;
7759 tree val;
7760 tree type;
7761 tree tmp;
7762 vec<constructor_elt, va_gc> *v = NULL;
7764 gcc_assert (se->ss == NULL);
7765 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7766 type = gfc_typenode_for_spec (&expr->ts);
7768 if (!init)
7770 /* Create a temporary variable and fill it in. */
7771 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7772 /* The symtree in expr is NULL, if the code to generate is for
7773 initializing the static members only. */
7774 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7775 se->want_coarray);
7776 gfc_add_expr_to_block (&se->pre, tmp);
7777 return;
7780 cm = expr->ts.u.derived->components;
7782 for (c = gfc_constructor_first (expr->value.constructor);
7783 c; c = gfc_constructor_next (c), cm = cm->next)
7785 /* Skip absent members in default initializers and allocatable
7786 components. Although the latter have a default initializer
7787 of EXPR_NULL,... by default, the static nullify is not needed
7788 since this is done every time we come into scope. */
7789 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7790 continue;
7792 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7793 && strcmp (cm->name, "_extends") == 0
7794 && cm->initializer->symtree)
7796 tree vtab;
7797 gfc_symbol *vtabs;
7798 vtabs = cm->initializer->symtree->n.sym;
7799 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7800 vtab = unshare_expr_without_location (vtab);
7801 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
7803 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
7805 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
7806 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7807 fold_convert (TREE_TYPE (cm->backend_decl),
7808 val));
7810 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
7811 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7812 fold_convert (TREE_TYPE (cm->backend_decl),
7813 integer_zero_node));
7814 else if (cm->ts.type == BT_UNION)
7815 gfc_conv_union_initializer (v, cm, c->expr);
7816 else
7818 val = gfc_conv_initializer (c->expr, &cm->ts,
7819 TREE_TYPE (cm->backend_decl),
7820 cm->attr.dimension, cm->attr.pointer,
7821 cm->attr.proc_pointer);
7822 val = unshare_expr_without_location (val);
7824 /* Append it to the constructor list. */
7825 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
7829 se->expr = build_constructor (type, v);
7830 if (init)
7831 TREE_CONSTANT (se->expr) = 1;
7835 /* Translate a substring expression. */
7837 static void
7838 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
7840 gfc_ref *ref;
7842 ref = expr->ref;
7844 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
7846 se->expr = gfc_build_wide_string_const (expr->ts.kind,
7847 expr->value.character.length,
7848 expr->value.character.string);
7850 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
7851 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
7853 if (ref)
7854 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
7858 /* Entry point for expression translation. Evaluates a scalar quantity.
7859 EXPR is the expression to be translated, and SE is the state structure if
7860 called from within the scalarized. */
7862 void
7863 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
7865 gfc_ss *ss;
7867 ss = se->ss;
7868 if (ss && ss->info->expr == expr
7869 && (ss->info->type == GFC_SS_SCALAR
7870 || ss->info->type == GFC_SS_REFERENCE))
7872 gfc_ss_info *ss_info;
7874 ss_info = ss->info;
7875 /* Substitute a scalar expression evaluated outside the scalarization
7876 loop. */
7877 se->expr = ss_info->data.scalar.value;
7878 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
7879 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7881 se->string_length = ss_info->string_length;
7882 gfc_advance_se_ss_chain (se);
7883 return;
7886 /* We need to convert the expressions for the iso_c_binding derived types.
7887 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7888 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7889 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7890 updated to be an integer with a kind equal to the size of a (void *). */
7891 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
7892 && expr->ts.u.derived->attr.is_bind_c)
7894 if (expr->expr_type == EXPR_VARIABLE
7895 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
7896 || expr->symtree->n.sym->intmod_sym_id
7897 == ISOCBINDING_NULL_FUNPTR))
7899 /* Set expr_type to EXPR_NULL, which will result in
7900 null_pointer_node being used below. */
7901 expr->expr_type = EXPR_NULL;
7903 else
7905 /* Update the type/kind of the expression to be what the new
7906 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7907 expr->ts.type = BT_INTEGER;
7908 expr->ts.f90_type = BT_VOID;
7909 expr->ts.kind = gfc_index_integer_kind;
7913 gfc_fix_class_refs (expr);
7915 switch (expr->expr_type)
7917 case EXPR_OP:
7918 gfc_conv_expr_op (se, expr);
7919 break;
7921 case EXPR_FUNCTION:
7922 gfc_conv_function_expr (se, expr);
7923 break;
7925 case EXPR_CONSTANT:
7926 gfc_conv_constant (se, expr);
7927 break;
7929 case EXPR_VARIABLE:
7930 gfc_conv_variable (se, expr);
7931 break;
7933 case EXPR_NULL:
7934 se->expr = null_pointer_node;
7935 break;
7937 case EXPR_SUBSTRING:
7938 gfc_conv_substring_expr (se, expr);
7939 break;
7941 case EXPR_STRUCTURE:
7942 gfc_conv_structure (se, expr, 0);
7943 break;
7945 case EXPR_ARRAY:
7946 gfc_conv_array_constructor_expr (se, expr);
7947 break;
7949 default:
7950 gcc_unreachable ();
7951 break;
7955 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7956 of an assignment. */
7957 void
7958 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
7960 gfc_conv_expr (se, expr);
7961 /* All numeric lvalues should have empty post chains. If not we need to
7962 figure out a way of rewriting an lvalue so that it has no post chain. */
7963 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
7966 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7967 numeric expressions. Used for scalar values where inserting cleanup code
7968 is inconvenient. */
7969 void
7970 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
7972 tree val;
7974 gcc_assert (expr->ts.type != BT_CHARACTER);
7975 gfc_conv_expr (se, expr);
7976 if (se->post.head)
7978 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
7979 gfc_add_modify (&se->pre, val, se->expr);
7980 se->expr = val;
7981 gfc_add_block_to_block (&se->pre, &se->post);
7985 /* Helper to translate an expression and convert it to a particular type. */
7986 void
7987 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
7989 gfc_conv_expr_val (se, expr);
7990 se->expr = convert (type, se->expr);
7994 /* Converts an expression so that it can be passed by reference. Scalar
7995 values only. */
7997 void
7998 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
8000 gfc_ss *ss;
8001 tree var;
8003 ss = se->ss;
8004 if (ss && ss->info->expr == expr
8005 && ss->info->type == GFC_SS_REFERENCE)
8007 /* Returns a reference to the scalar evaluated outside the loop
8008 for this case. */
8009 gfc_conv_expr (se, expr);
8011 if (expr->ts.type == BT_CHARACTER
8012 && expr->expr_type != EXPR_FUNCTION)
8013 gfc_conv_string_parameter (se);
8014 else
8015 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8017 return;
8020 if (expr->ts.type == BT_CHARACTER)
8022 gfc_conv_expr (se, expr);
8023 gfc_conv_string_parameter (se);
8024 return;
8027 if (expr->expr_type == EXPR_VARIABLE)
8029 se->want_pointer = 1;
8030 gfc_conv_expr (se, expr);
8031 if (se->post.head)
8033 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8034 gfc_add_modify (&se->pre, var, se->expr);
8035 gfc_add_block_to_block (&se->pre, &se->post);
8036 se->expr = var;
8038 return;
8041 if (expr->expr_type == EXPR_FUNCTION
8042 && ((expr->value.function.esym
8043 && expr->value.function.esym->result->attr.pointer
8044 && !expr->value.function.esym->result->attr.dimension)
8045 || (!expr->value.function.esym && !expr->ref
8046 && expr->symtree->n.sym->attr.pointer
8047 && !expr->symtree->n.sym->attr.dimension)))
8049 se->want_pointer = 1;
8050 gfc_conv_expr (se, expr);
8051 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8052 gfc_add_modify (&se->pre, var, se->expr);
8053 se->expr = var;
8054 return;
8057 gfc_conv_expr (se, expr);
8059 /* Create a temporary var to hold the value. */
8060 if (TREE_CONSTANT (se->expr))
8062 tree tmp = se->expr;
8063 STRIP_TYPE_NOPS (tmp);
8064 var = build_decl (input_location,
8065 CONST_DECL, NULL, TREE_TYPE (tmp));
8066 DECL_INITIAL (var) = tmp;
8067 TREE_STATIC (var) = 1;
8068 pushdecl (var);
8070 else
8072 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8073 gfc_add_modify (&se->pre, var, se->expr);
8075 gfc_add_block_to_block (&se->pre, &se->post);
8077 /* Take the address of that value. */
8078 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8082 /* Get the _len component for an unlimited polymorphic expression. */
8084 static tree
8085 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8087 gfc_se se;
8088 gfc_ref *ref = expr->ref;
8090 gfc_init_se (&se, NULL);
8091 while (ref && ref->next)
8092 ref = ref->next;
8093 gfc_add_len_component (expr);
8094 gfc_conv_expr (&se, expr);
8095 gfc_add_block_to_block (block, &se.pre);
8096 gcc_assert (se.post.head == NULL_TREE);
8097 if (ref)
8099 gfc_free_ref_list (ref->next);
8100 ref->next = NULL;
8102 else
8104 gfc_free_ref_list (expr->ref);
8105 expr->ref = NULL;
8107 return se.expr;
8111 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8112 statement-list outside of the scalarizer-loop. When code is generated, that
8113 depends on the scalarized expression, it is added to RSE.PRE.
8114 Returns le's _vptr tree and when set the len expressions in to_lenp and
8115 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8116 expression. */
8118 static tree
8119 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8120 gfc_expr * re, gfc_se *rse,
8121 tree * to_lenp, tree * from_lenp)
8123 gfc_se se;
8124 gfc_expr * vptr_expr;
8125 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8126 bool set_vptr = false, temp_rhs = false;
8127 stmtblock_t *pre = block;
8129 /* Create a temporary for complicated expressions. */
8130 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8131 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8133 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8134 pre = &rse->pre;
8135 gfc_add_modify (&rse->pre, tmp, rse->expr);
8136 rse->expr = tmp;
8137 temp_rhs = true;
8140 /* Get the _vptr for the left-hand side expression. */
8141 gfc_init_se (&se, NULL);
8142 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8143 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8145 /* Care about _len for unlimited polymorphic entities. */
8146 if (UNLIMITED_POLY (vptr_expr)
8147 || (vptr_expr->ts.type == BT_DERIVED
8148 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8149 to_len = trans_get_upoly_len (block, vptr_expr);
8150 gfc_add_vptr_component (vptr_expr);
8151 set_vptr = true;
8153 else
8154 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8155 se.want_pointer = 1;
8156 gfc_conv_expr (&se, vptr_expr);
8157 gfc_free_expr (vptr_expr);
8158 gfc_add_block_to_block (block, &se.pre);
8159 gcc_assert (se.post.head == NULL_TREE);
8160 lhs_vptr = se.expr;
8161 STRIP_NOPS (lhs_vptr);
8163 /* Set the _vptr only when the left-hand side of the assignment is a
8164 class-object. */
8165 if (set_vptr)
8167 /* Get the vptr from the rhs expression only, when it is variable.
8168 Functions are expected to be assigned to a temporary beforehand. */
8169 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8170 ? gfc_find_and_cut_at_last_class_ref (re)
8171 : NULL;
8172 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8174 if (to_len != NULL_TREE)
8176 /* Get the _len information from the rhs. */
8177 if (UNLIMITED_POLY (vptr_expr)
8178 || (vptr_expr->ts.type == BT_DERIVED
8179 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8180 from_len = trans_get_upoly_len (block, vptr_expr);
8182 gfc_add_vptr_component (vptr_expr);
8184 else
8186 if (re->expr_type == EXPR_VARIABLE
8187 && DECL_P (re->symtree->n.sym->backend_decl)
8188 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8189 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8190 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8191 re->symtree->n.sym->backend_decl))))
8193 vptr_expr = NULL;
8194 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8195 re->symtree->n.sym->backend_decl));
8196 if (to_len)
8197 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8198 re->symtree->n.sym->backend_decl));
8200 else if (temp_rhs && re->ts.type == BT_CLASS)
8202 vptr_expr = NULL;
8203 se.expr = gfc_class_vptr_get (rse->expr);
8204 if (UNLIMITED_POLY (re))
8205 from_len = gfc_class_len_get (rse->expr);
8207 else if (re->expr_type != EXPR_NULL)
8208 /* Only when rhs is non-NULL use its declared type for vptr
8209 initialisation. */
8210 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8211 else
8212 /* When the rhs is NULL use the vtab of lhs' declared type. */
8213 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8216 if (vptr_expr)
8218 gfc_init_se (&se, NULL);
8219 se.want_pointer = 1;
8220 gfc_conv_expr (&se, vptr_expr);
8221 gfc_free_expr (vptr_expr);
8222 gfc_add_block_to_block (block, &se.pre);
8223 gcc_assert (se.post.head == NULL_TREE);
8225 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8226 se.expr));
8228 if (to_len != NULL_TREE)
8230 /* The _len component needs to be set. Figure how to get the
8231 value of the right-hand side. */
8232 if (from_len == NULL_TREE)
8234 if (rse->string_length != NULL_TREE)
8235 from_len = rse->string_length;
8236 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8238 from_len = gfc_get_expr_charlen (re);
8239 gfc_init_se (&se, NULL);
8240 gfc_conv_expr (&se, re->ts.u.cl->length);
8241 gfc_add_block_to_block (block, &se.pre);
8242 gcc_assert (se.post.head == NULL_TREE);
8243 from_len = gfc_evaluate_now (se.expr, block);
8245 else
8246 from_len = build_zero_cst (gfc_charlen_type_node);
8248 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8249 from_len));
8253 /* Return the _len trees only, when requested. */
8254 if (to_lenp)
8255 *to_lenp = to_len;
8256 if (from_lenp)
8257 *from_lenp = from_len;
8258 return lhs_vptr;
8262 /* Assign tokens for pointer components. */
8264 static void
8265 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8266 gfc_expr *expr2)
8268 symbol_attribute lhs_attr, rhs_attr;
8269 tree tmp, lhs_tok, rhs_tok;
8270 /* Flag to indicated component refs on the rhs. */
8271 bool rhs_cr;
8273 lhs_attr = gfc_caf_attr (expr1);
8274 if (expr2->expr_type != EXPR_NULL)
8276 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8277 if (lhs_attr.codimension && rhs_attr.codimension)
8279 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8280 lhs_tok = build_fold_indirect_ref (lhs_tok);
8282 if (rhs_cr)
8283 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8284 else
8286 tree caf_decl;
8287 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8288 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8289 NULL_TREE, NULL);
8291 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8292 lhs_tok,
8293 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8294 gfc_prepend_expr_to_block (&lse->post, tmp);
8297 else if (lhs_attr.codimension)
8299 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8300 lhs_tok = build_fold_indirect_ref (lhs_tok);
8301 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8302 lhs_tok, null_pointer_node);
8303 gfc_prepend_expr_to_block (&lse->post, tmp);
8307 /* Indentify class valued proc_pointer assignments. */
8309 static bool
8310 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8312 gfc_ref * ref;
8314 ref = expr1->ref;
8315 while (ref && ref->next)
8316 ref = ref->next;
8318 return ref && ref->type == REF_COMPONENT
8319 && ref->u.c.component->attr.proc_pointer
8320 && expr2->expr_type == EXPR_VARIABLE
8321 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8325 /* Do everything that is needed for a CLASS function expr2. */
8327 static tree
8328 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8329 gfc_expr *expr1, gfc_expr *expr2)
8331 tree expr1_vptr = NULL_TREE;
8332 tree tmp;
8334 gfc_conv_function_expr (rse, expr2);
8335 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8337 if (expr1->ts.type != BT_CLASS)
8338 rse->expr = gfc_class_data_get (rse->expr);
8339 else
8341 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8342 expr2, rse,
8343 NULL, NULL);
8344 gfc_add_block_to_block (block, &rse->pre);
8345 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8346 gfc_add_modify (&lse->pre, tmp, rse->expr);
8348 gfc_add_modify (&lse->pre, expr1_vptr,
8349 fold_convert (TREE_TYPE (expr1_vptr),
8350 gfc_class_vptr_get (tmp)));
8351 rse->expr = gfc_class_data_get (tmp);
8354 return expr1_vptr;
8358 tree
8359 gfc_trans_pointer_assign (gfc_code * code)
8361 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8365 /* Generate code for a pointer assignment. */
8367 tree
8368 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8370 gfc_se lse;
8371 gfc_se rse;
8372 stmtblock_t block;
8373 tree desc;
8374 tree tmp;
8375 tree expr1_vptr = NULL_TREE;
8376 bool scalar, non_proc_pointer_assign;
8377 gfc_ss *ss;
8379 gfc_start_block (&block);
8381 gfc_init_se (&lse, NULL);
8383 /* Usually testing whether this is not a proc pointer assignment. */
8384 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8386 /* Check whether the expression is a scalar or not; we cannot use
8387 expr1->rank as it can be nonzero for proc pointers. */
8388 ss = gfc_walk_expr (expr1);
8389 scalar = ss == gfc_ss_terminator;
8390 if (!scalar)
8391 gfc_free_ss_chain (ss);
8393 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8394 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8396 gfc_add_data_component (expr2);
8397 /* The following is required as gfc_add_data_component doesn't
8398 update ts.type if there is a tailing REF_ARRAY. */
8399 expr2->ts.type = BT_DERIVED;
8402 if (scalar)
8404 /* Scalar pointers. */
8405 lse.want_pointer = 1;
8406 gfc_conv_expr (&lse, expr1);
8407 gfc_init_se (&rse, NULL);
8408 rse.want_pointer = 1;
8409 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8410 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8411 else
8412 gfc_conv_expr (&rse, expr2);
8414 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8416 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8417 NULL);
8418 lse.expr = gfc_class_data_get (lse.expr);
8421 if (expr1->symtree->n.sym->attr.proc_pointer
8422 && expr1->symtree->n.sym->attr.dummy)
8423 lse.expr = build_fold_indirect_ref_loc (input_location,
8424 lse.expr);
8426 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8427 && expr2->symtree->n.sym->attr.dummy)
8428 rse.expr = build_fold_indirect_ref_loc (input_location,
8429 rse.expr);
8431 gfc_add_block_to_block (&block, &lse.pre);
8432 gfc_add_block_to_block (&block, &rse.pre);
8434 /* Check character lengths if character expression. The test is only
8435 really added if -fbounds-check is enabled. Exclude deferred
8436 character length lefthand sides. */
8437 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8438 && !expr1->ts.deferred
8439 && !expr1->symtree->n.sym->attr.proc_pointer
8440 && !gfc_is_proc_ptr_comp (expr1))
8442 gcc_assert (expr2->ts.type == BT_CHARACTER);
8443 gcc_assert (lse.string_length && rse.string_length);
8444 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8445 lse.string_length, rse.string_length,
8446 &block);
8449 /* The assignment to an deferred character length sets the string
8450 length to that of the rhs. */
8451 if (expr1->ts.deferred)
8453 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8454 gfc_add_modify (&block, lse.string_length,
8455 fold_convert (TREE_TYPE (lse.string_length),
8456 rse.string_length));
8457 else if (lse.string_length != NULL)
8458 gfc_add_modify (&block, lse.string_length,
8459 build_zero_cst (TREE_TYPE (lse.string_length)));
8462 gfc_add_modify (&block, lse.expr,
8463 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8465 /* Also set the tokens for pointer components in derived typed
8466 coarrays. */
8467 if (flag_coarray == GFC_FCOARRAY_LIB)
8468 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8470 gfc_add_block_to_block (&block, &rse.post);
8471 gfc_add_block_to_block (&block, &lse.post);
8473 else
8475 gfc_ref* remap;
8476 bool rank_remap;
8477 tree strlen_lhs;
8478 tree strlen_rhs = NULL_TREE;
8480 /* Array pointer. Find the last reference on the LHS and if it is an
8481 array section ref, we're dealing with bounds remapping. In this case,
8482 set it to AR_FULL so that gfc_conv_expr_descriptor does
8483 not see it and process the bounds remapping afterwards explicitly. */
8484 for (remap = expr1->ref; remap; remap = remap->next)
8485 if (!remap->next && remap->type == REF_ARRAY
8486 && remap->u.ar.type == AR_SECTION)
8487 break;
8488 rank_remap = (remap && remap->u.ar.end[0]);
8490 gfc_init_se (&lse, NULL);
8491 if (remap)
8492 lse.descriptor_only = 1;
8493 gfc_conv_expr_descriptor (&lse, expr1);
8494 strlen_lhs = lse.string_length;
8495 desc = lse.expr;
8497 if (expr2->expr_type == EXPR_NULL)
8499 /* Just set the data pointer to null. */
8500 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8502 else if (rank_remap)
8504 /* If we are rank-remapping, just get the RHS's descriptor and
8505 process this later on. */
8506 gfc_init_se (&rse, NULL);
8507 rse.direct_byref = 1;
8508 rse.byref_noassign = 1;
8510 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8511 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8512 expr1, expr2);
8513 else if (expr2->expr_type == EXPR_FUNCTION)
8515 tree bound[GFC_MAX_DIMENSIONS];
8516 int i;
8518 for (i = 0; i < expr2->rank; i++)
8519 bound[i] = NULL_TREE;
8520 tmp = gfc_typenode_for_spec (&expr2->ts);
8521 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8522 bound, bound, 0,
8523 GFC_ARRAY_POINTER_CONT, false);
8524 tmp = gfc_create_var (tmp, "ptrtemp");
8525 rse.descriptor_only = 0;
8526 rse.expr = tmp;
8527 rse.direct_byref = 1;
8528 gfc_conv_expr_descriptor (&rse, expr2);
8529 strlen_rhs = rse.string_length;
8530 rse.expr = tmp;
8532 else
8534 gfc_conv_expr_descriptor (&rse, expr2);
8535 strlen_rhs = rse.string_length;
8536 if (expr1->ts.type == BT_CLASS)
8537 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8538 expr2, &rse,
8539 NULL, NULL);
8542 else if (expr2->expr_type == EXPR_VARIABLE)
8544 /* Assign directly to the LHS's descriptor. */
8545 lse.descriptor_only = 0;
8546 lse.direct_byref = 1;
8547 gfc_conv_expr_descriptor (&lse, expr2);
8548 strlen_rhs = lse.string_length;
8550 if (expr1->ts.type == BT_CLASS)
8552 rse.expr = NULL_TREE;
8553 rse.string_length = NULL_TREE;
8554 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8555 NULL, NULL);
8558 if (remap == NULL)
8560 /* If the target is not a whole array, use the target array
8561 reference for remap. */
8562 for (remap = expr2->ref; remap; remap = remap->next)
8563 if (remap->type == REF_ARRAY
8564 && remap->u.ar.type == AR_FULL
8565 && remap->next)
8566 break;
8569 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8571 gfc_init_se (&rse, NULL);
8572 rse.want_pointer = 1;
8573 gfc_conv_function_expr (&rse, expr2);
8574 if (expr1->ts.type != BT_CLASS)
8576 rse.expr = gfc_class_data_get (rse.expr);
8577 gfc_add_modify (&lse.pre, desc, rse.expr);
8578 /* Set the lhs span. */
8579 tmp = TREE_TYPE (rse.expr);
8580 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8581 tmp = fold_convert (gfc_array_index_type, tmp);
8582 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8584 else
8586 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8587 expr2, &rse, NULL,
8588 NULL);
8589 gfc_add_block_to_block (&block, &rse.pre);
8590 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8591 gfc_add_modify (&lse.pre, tmp, rse.expr);
8593 gfc_add_modify (&lse.pre, expr1_vptr,
8594 fold_convert (TREE_TYPE (expr1_vptr),
8595 gfc_class_vptr_get (tmp)));
8596 rse.expr = gfc_class_data_get (tmp);
8597 gfc_add_modify (&lse.pre, desc, rse.expr);
8600 else
8602 /* Assign to a temporary descriptor and then copy that
8603 temporary to the pointer. */
8604 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8605 lse.descriptor_only = 0;
8606 lse.expr = tmp;
8607 lse.direct_byref = 1;
8608 gfc_conv_expr_descriptor (&lse, expr2);
8609 strlen_rhs = lse.string_length;
8610 gfc_add_modify (&lse.pre, desc, tmp);
8613 gfc_add_block_to_block (&block, &lse.pre);
8614 if (rank_remap)
8615 gfc_add_block_to_block (&block, &rse.pre);
8617 /* If we do bounds remapping, update LHS descriptor accordingly. */
8618 if (remap)
8620 int dim;
8621 gcc_assert (remap->u.ar.dimen == expr1->rank);
8623 if (rank_remap)
8625 /* Do rank remapping. We already have the RHS's descriptor
8626 converted in rse and now have to build the correct LHS
8627 descriptor for it. */
8629 tree dtype, data, span;
8630 tree offs, stride;
8631 tree lbound, ubound;
8633 /* Set dtype. */
8634 dtype = gfc_conv_descriptor_dtype (desc);
8635 tmp = gfc_get_dtype (TREE_TYPE (desc));
8636 gfc_add_modify (&block, dtype, tmp);
8638 /* Copy data pointer. */
8639 data = gfc_conv_descriptor_data_get (rse.expr);
8640 gfc_conv_descriptor_data_set (&block, desc, data);
8642 /* Copy the span. */
8643 if (TREE_CODE (rse.expr) == VAR_DECL
8644 && GFC_DECL_PTR_ARRAY_P (rse.expr))
8645 span = gfc_conv_descriptor_span_get (rse.expr);
8646 else
8648 tmp = TREE_TYPE (rse.expr);
8649 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8650 span = fold_convert (gfc_array_index_type, tmp);
8652 gfc_conv_descriptor_span_set (&block, desc, span);
8654 /* Copy offset but adjust it such that it would correspond
8655 to a lbound of zero. */
8656 offs = gfc_conv_descriptor_offset_get (rse.expr);
8657 for (dim = 0; dim < expr2->rank; ++dim)
8659 stride = gfc_conv_descriptor_stride_get (rse.expr,
8660 gfc_rank_cst[dim]);
8661 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8662 gfc_rank_cst[dim]);
8663 tmp = fold_build2_loc (input_location, MULT_EXPR,
8664 gfc_array_index_type, stride, lbound);
8665 offs = fold_build2_loc (input_location, PLUS_EXPR,
8666 gfc_array_index_type, offs, tmp);
8668 gfc_conv_descriptor_offset_set (&block, desc, offs);
8670 /* Set the bounds as declared for the LHS and calculate strides as
8671 well as another offset update accordingly. */
8672 stride = gfc_conv_descriptor_stride_get (rse.expr,
8673 gfc_rank_cst[0]);
8674 for (dim = 0; dim < expr1->rank; ++dim)
8676 gfc_se lower_se;
8677 gfc_se upper_se;
8679 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8681 /* Convert declared bounds. */
8682 gfc_init_se (&lower_se, NULL);
8683 gfc_init_se (&upper_se, NULL);
8684 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8685 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8687 gfc_add_block_to_block (&block, &lower_se.pre);
8688 gfc_add_block_to_block (&block, &upper_se.pre);
8690 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8691 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8693 lbound = gfc_evaluate_now (lbound, &block);
8694 ubound = gfc_evaluate_now (ubound, &block);
8696 gfc_add_block_to_block (&block, &lower_se.post);
8697 gfc_add_block_to_block (&block, &upper_se.post);
8699 /* Set bounds in descriptor. */
8700 gfc_conv_descriptor_lbound_set (&block, desc,
8701 gfc_rank_cst[dim], lbound);
8702 gfc_conv_descriptor_ubound_set (&block, desc,
8703 gfc_rank_cst[dim], ubound);
8705 /* Set stride. */
8706 stride = gfc_evaluate_now (stride, &block);
8707 gfc_conv_descriptor_stride_set (&block, desc,
8708 gfc_rank_cst[dim], stride);
8710 /* Update offset. */
8711 offs = gfc_conv_descriptor_offset_get (desc);
8712 tmp = fold_build2_loc (input_location, MULT_EXPR,
8713 gfc_array_index_type, lbound, stride);
8714 offs = fold_build2_loc (input_location, MINUS_EXPR,
8715 gfc_array_index_type, offs, tmp);
8716 offs = gfc_evaluate_now (offs, &block);
8717 gfc_conv_descriptor_offset_set (&block, desc, offs);
8719 /* Update stride. */
8720 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8721 stride = fold_build2_loc (input_location, MULT_EXPR,
8722 gfc_array_index_type, stride, tmp);
8725 else
8727 /* Bounds remapping. Just shift the lower bounds. */
8729 gcc_assert (expr1->rank == expr2->rank);
8731 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8733 gfc_se lbound_se;
8735 gcc_assert (!remap->u.ar.end[dim]);
8736 gfc_init_se (&lbound_se, NULL);
8737 if (remap->u.ar.start[dim])
8739 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8740 gfc_add_block_to_block (&block, &lbound_se.pre);
8742 else
8743 /* This remap arises from a target that is not a whole
8744 array. The start expressions will be NULL but we need
8745 the lbounds to be one. */
8746 lbound_se.expr = gfc_index_one_node;
8747 gfc_conv_shift_descriptor_lbound (&block, desc,
8748 dim, lbound_se.expr);
8749 gfc_add_block_to_block (&block, &lbound_se.post);
8754 /* Check string lengths if applicable. The check is only really added
8755 to the output code if -fbounds-check is enabled. */
8756 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8758 gcc_assert (expr2->ts.type == BT_CHARACTER);
8759 gcc_assert (strlen_lhs && strlen_rhs);
8760 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8761 strlen_lhs, strlen_rhs, &block);
8764 /* If rank remapping was done, check with -fcheck=bounds that
8765 the target is at least as large as the pointer. */
8766 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8768 tree lsize, rsize;
8769 tree fault;
8770 const char* msg;
8772 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8773 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8775 lsize = gfc_evaluate_now (lsize, &block);
8776 rsize = gfc_evaluate_now (rsize, &block);
8777 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
8778 rsize, lsize);
8780 msg = _("Target of rank remapping is too small (%ld < %ld)");
8781 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8782 msg, rsize, lsize);
8785 gfc_add_block_to_block (&block, &lse.post);
8786 if (rank_remap)
8787 gfc_add_block_to_block (&block, &rse.post);
8790 return gfc_finish_block (&block);
8794 /* Makes sure se is suitable for passing as a function string parameter. */
8795 /* TODO: Need to check all callers of this function. It may be abused. */
8797 void
8798 gfc_conv_string_parameter (gfc_se * se)
8800 tree type;
8802 if (TREE_CODE (se->expr) == STRING_CST)
8804 type = TREE_TYPE (TREE_TYPE (se->expr));
8805 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8806 return;
8809 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
8811 if (TREE_CODE (se->expr) != INDIRECT_REF)
8813 type = TREE_TYPE (se->expr);
8814 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8816 else
8818 type = gfc_get_character_type_len (gfc_default_character_kind,
8819 se->string_length);
8820 type = build_pointer_type (type);
8821 se->expr = gfc_build_addr_expr (type, se->expr);
8825 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
8829 /* Generate code for assignment of scalar variables. Includes character
8830 strings and derived types with allocatable components.
8831 If you know that the LHS has no allocations, set dealloc to false.
8833 DEEP_COPY has no effect if the typespec TS is not a derived type with
8834 allocatable components. Otherwise, if it is set, an explicit copy of each
8835 allocatable component is made. This is necessary as a simple copy of the
8836 whole object would copy array descriptors as is, so that the lhs's
8837 allocatable components would point to the rhs's after the assignment.
8838 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8839 necessary if the rhs is a non-pointer function, as the allocatable components
8840 are not accessible by other means than the function's result after the
8841 function has returned. It is even more subtle when temporaries are involved,
8842 as the two following examples show:
8843 1. When we evaluate an array constructor, a temporary is created. Thus
8844 there is theoretically no alias possible. However, no deep copy is
8845 made for this temporary, so that if the constructor is made of one or
8846 more variable with allocatable components, those components still point
8847 to the variable's: DEEP_COPY should be set for the assignment from the
8848 temporary to the lhs in that case.
8849 2. When assigning a scalar to an array, we evaluate the scalar value out
8850 of the loop, store it into a temporary variable, and assign from that.
8851 In that case, deep copying when assigning to the temporary would be a
8852 waste of resources; however deep copies should happen when assigning from
8853 the temporary to each array element: again DEEP_COPY should be set for
8854 the assignment from the temporary to the lhs. */
8856 tree
8857 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
8858 bool deep_copy, bool dealloc, bool in_coarray)
8860 stmtblock_t block;
8861 tree tmp;
8862 tree cond;
8864 gfc_init_block (&block);
8866 if (ts.type == BT_CHARACTER)
8868 tree rlen = NULL;
8869 tree llen = NULL;
8871 if (lse->string_length != NULL_TREE)
8873 gfc_conv_string_parameter (lse);
8874 gfc_add_block_to_block (&block, &lse->pre);
8875 llen = lse->string_length;
8878 if (rse->string_length != NULL_TREE)
8880 gfc_conv_string_parameter (rse);
8881 gfc_add_block_to_block (&block, &rse->pre);
8882 rlen = rse->string_length;
8885 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
8886 rse->expr, ts.kind);
8888 else if (gfc_bt_struct (ts.type)
8889 && (ts.u.derived->attr.alloc_comp
8890 || (deep_copy && ts.u.derived->attr.pdt_type)))
8892 tree tmp_var = NULL_TREE;
8893 cond = NULL_TREE;
8895 /* Are the rhs and the lhs the same? */
8896 if (deep_copy)
8898 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8899 gfc_build_addr_expr (NULL_TREE, lse->expr),
8900 gfc_build_addr_expr (NULL_TREE, rse->expr));
8901 cond = gfc_evaluate_now (cond, &lse->pre);
8904 /* Deallocate the lhs allocated components as long as it is not
8905 the same as the rhs. This must be done following the assignment
8906 to prevent deallocating data that could be used in the rhs
8907 expression. */
8908 if (dealloc)
8910 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
8911 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
8912 if (deep_copy)
8913 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8914 tmp);
8915 gfc_add_expr_to_block (&lse->post, tmp);
8918 gfc_add_block_to_block (&block, &rse->pre);
8919 gfc_add_block_to_block (&block, &lse->pre);
8921 gfc_add_modify (&block, lse->expr,
8922 fold_convert (TREE_TYPE (lse->expr), rse->expr));
8924 /* Restore pointer address of coarray components. */
8925 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
8927 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
8928 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8929 tmp);
8930 gfc_add_expr_to_block (&block, tmp);
8933 /* Do a deep copy if the rhs is a variable, if it is not the
8934 same as the lhs. */
8935 if (deep_copy)
8937 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8938 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
8939 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
8940 caf_mode);
8941 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8942 tmp);
8943 gfc_add_expr_to_block (&block, tmp);
8946 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
8948 gfc_add_block_to_block (&block, &lse->pre);
8949 gfc_add_block_to_block (&block, &rse->pre);
8950 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
8951 TREE_TYPE (lse->expr), rse->expr);
8952 gfc_add_modify (&block, lse->expr, tmp);
8954 else
8956 gfc_add_block_to_block (&block, &lse->pre);
8957 gfc_add_block_to_block (&block, &rse->pre);
8959 gfc_add_modify (&block, lse->expr,
8960 fold_convert (TREE_TYPE (lse->expr), rse->expr));
8963 gfc_add_block_to_block (&block, &lse->post);
8964 gfc_add_block_to_block (&block, &rse->post);
8966 return gfc_finish_block (&block);
8970 /* There are quite a lot of restrictions on the optimisation in using an
8971 array function assign without a temporary. */
8973 static bool
8974 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
8976 gfc_ref * ref;
8977 bool seen_array_ref;
8978 bool c = false;
8979 gfc_symbol *sym = expr1->symtree->n.sym;
8981 /* Play it safe with class functions assigned to a derived type. */
8982 if (gfc_is_class_array_function (expr2)
8983 && expr1->ts.type == BT_DERIVED)
8984 return true;
8986 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8987 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
8988 return true;
8990 /* Elemental functions are scalarized so that they don't need a
8991 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8992 they would need special treatment in gfc_trans_arrayfunc_assign. */
8993 if (expr2->value.function.esym != NULL
8994 && expr2->value.function.esym->attr.elemental)
8995 return true;
8997 /* Need a temporary if rhs is not FULL or a contiguous section. */
8998 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
8999 return true;
9001 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9002 if (gfc_ref_needs_temporary_p (expr1->ref))
9003 return true;
9005 /* Functions returning pointers or allocatables need temporaries. */
9006 c = expr2->value.function.esym
9007 ? (expr2->value.function.esym->attr.pointer
9008 || expr2->value.function.esym->attr.allocatable)
9009 : (expr2->symtree->n.sym->attr.pointer
9010 || expr2->symtree->n.sym->attr.allocatable);
9011 if (c)
9012 return true;
9014 /* Character array functions need temporaries unless the
9015 character lengths are the same. */
9016 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9018 if (expr1->ts.u.cl->length == NULL
9019 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9020 return true;
9022 if (expr2->ts.u.cl->length == NULL
9023 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9024 return true;
9026 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9027 expr2->ts.u.cl->length->value.integer) != 0)
9028 return true;
9031 /* Check that no LHS component references appear during an array
9032 reference. This is needed because we do not have the means to
9033 span any arbitrary stride with an array descriptor. This check
9034 is not needed for the rhs because the function result has to be
9035 a complete type. */
9036 seen_array_ref = false;
9037 for (ref = expr1->ref; ref; ref = ref->next)
9039 if (ref->type == REF_ARRAY)
9040 seen_array_ref= true;
9041 else if (ref->type == REF_COMPONENT && seen_array_ref)
9042 return true;
9045 /* Check for a dependency. */
9046 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9047 expr2->value.function.esym,
9048 expr2->value.function.actual,
9049 NOT_ELEMENTAL))
9050 return true;
9052 /* If we have reached here with an intrinsic function, we do not
9053 need a temporary except in the particular case that reallocation
9054 on assignment is active and the lhs is allocatable and a target. */
9055 if (expr2->value.function.isym)
9056 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9058 /* If the LHS is a dummy, we need a temporary if it is not
9059 INTENT(OUT). */
9060 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9061 return true;
9063 /* If the lhs has been host_associated, is in common, a pointer or is
9064 a target and the function is not using a RESULT variable, aliasing
9065 can occur and a temporary is needed. */
9066 if ((sym->attr.host_assoc
9067 || sym->attr.in_common
9068 || sym->attr.pointer
9069 || sym->attr.cray_pointee
9070 || sym->attr.target)
9071 && expr2->symtree != NULL
9072 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9073 return true;
9075 /* A PURE function can unconditionally be called without a temporary. */
9076 if (expr2->value.function.esym != NULL
9077 && expr2->value.function.esym->attr.pure)
9078 return false;
9080 /* Implicit_pure functions are those which could legally be declared
9081 to be PURE. */
9082 if (expr2->value.function.esym != NULL
9083 && expr2->value.function.esym->attr.implicit_pure)
9084 return false;
9086 if (!sym->attr.use_assoc
9087 && !sym->attr.in_common
9088 && !sym->attr.pointer
9089 && !sym->attr.target
9090 && !sym->attr.cray_pointee
9091 && expr2->value.function.esym)
9093 /* A temporary is not needed if the function is not contained and
9094 the variable is local or host associated and not a pointer or
9095 a target. */
9096 if (!expr2->value.function.esym->attr.contained)
9097 return false;
9099 /* A temporary is not needed if the lhs has never been host
9100 associated and the procedure is contained. */
9101 else if (!sym->attr.host_assoc)
9102 return false;
9104 /* A temporary is not needed if the variable is local and not
9105 a pointer, a target or a result. */
9106 if (sym->ns->parent
9107 && expr2->value.function.esym->ns == sym->ns->parent)
9108 return false;
9111 /* Default to temporary use. */
9112 return true;
9116 /* Provide the loop info so that the lhs descriptor can be built for
9117 reallocatable assignments from extrinsic function calls. */
9119 static void
9120 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9121 gfc_loopinfo *loop)
9123 /* Signal that the function call should not be made by
9124 gfc_conv_loop_setup. */
9125 se->ss->is_alloc_lhs = 1;
9126 gfc_init_loopinfo (loop);
9127 gfc_add_ss_to_loop (loop, *ss);
9128 gfc_add_ss_to_loop (loop, se->ss);
9129 gfc_conv_ss_startstride (loop);
9130 gfc_conv_loop_setup (loop, where);
9131 gfc_copy_loopinfo_to_se (se, loop);
9132 gfc_add_block_to_block (&se->pre, &loop->pre);
9133 gfc_add_block_to_block (&se->pre, &loop->post);
9134 se->ss->is_alloc_lhs = 0;
9138 /* For assignment to a reallocatable lhs from intrinsic functions,
9139 replace the se.expr (ie. the result) with a temporary descriptor.
9140 Null the data field so that the library allocates space for the
9141 result. Free the data of the original descriptor after the function,
9142 in case it appears in an argument expression and transfer the
9143 result to the original descriptor. */
9145 static void
9146 fcncall_realloc_result (gfc_se *se, int rank)
9148 tree desc;
9149 tree res_desc;
9150 tree tmp;
9151 tree offset;
9152 tree zero_cond;
9153 int n;
9155 /* Use the allocation done by the library. Substitute the lhs
9156 descriptor with a copy, whose data field is nulled.*/
9157 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9158 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9159 desc = build_fold_indirect_ref_loc (input_location, desc);
9161 /* Unallocated, the descriptor does not have a dtype. */
9162 tmp = gfc_conv_descriptor_dtype (desc);
9163 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9165 res_desc = gfc_evaluate_now (desc, &se->pre);
9166 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9167 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9169 /* Free the lhs after the function call and copy the result data to
9170 the lhs descriptor. */
9171 tmp = gfc_conv_descriptor_data_get (desc);
9172 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9173 logical_type_node, tmp,
9174 build_int_cst (TREE_TYPE (tmp), 0));
9175 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9176 tmp = gfc_call_free (tmp);
9177 gfc_add_expr_to_block (&se->post, tmp);
9179 tmp = gfc_conv_descriptor_data_get (res_desc);
9180 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9182 /* Check that the shapes are the same between lhs and expression. */
9183 for (n = 0 ; n < rank; n++)
9185 tree tmp1;
9186 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9187 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9188 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9189 gfc_array_index_type, tmp, tmp1);
9190 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9191 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9192 gfc_array_index_type, tmp, tmp1);
9193 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9194 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9195 gfc_array_index_type, tmp, tmp1);
9196 tmp = fold_build2_loc (input_location, NE_EXPR,
9197 logical_type_node, tmp,
9198 gfc_index_zero_node);
9199 tmp = gfc_evaluate_now (tmp, &se->post);
9200 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9201 logical_type_node, tmp,
9202 zero_cond);
9205 /* 'zero_cond' being true is equal to lhs not being allocated or the
9206 shapes being different. */
9207 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9209 /* Now reset the bounds returned from the function call to bounds based
9210 on the lhs lbounds, except where the lhs is not allocated or the shapes
9211 of 'variable and 'expr' are different. Set the offset accordingly. */
9212 offset = gfc_index_zero_node;
9213 for (n = 0 ; n < rank; n++)
9215 tree lbound;
9217 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9218 lbound = fold_build3_loc (input_location, COND_EXPR,
9219 gfc_array_index_type, zero_cond,
9220 gfc_index_one_node, lbound);
9221 lbound = gfc_evaluate_now (lbound, &se->post);
9223 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9224 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9225 gfc_array_index_type, tmp, lbound);
9226 gfc_conv_descriptor_lbound_set (&se->post, desc,
9227 gfc_rank_cst[n], lbound);
9228 gfc_conv_descriptor_ubound_set (&se->post, desc,
9229 gfc_rank_cst[n], tmp);
9231 /* Set stride and accumulate the offset. */
9232 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9233 gfc_conv_descriptor_stride_set (&se->post, desc,
9234 gfc_rank_cst[n], tmp);
9235 tmp = fold_build2_loc (input_location, MULT_EXPR,
9236 gfc_array_index_type, lbound, tmp);
9237 offset = fold_build2_loc (input_location, MINUS_EXPR,
9238 gfc_array_index_type, offset, tmp);
9239 offset = gfc_evaluate_now (offset, &se->post);
9242 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9247 /* Try to translate array(:) = func (...), where func is a transformational
9248 array function, without using a temporary. Returns NULL if this isn't the
9249 case. */
9251 static tree
9252 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9254 gfc_se se;
9255 gfc_ss *ss = NULL;
9256 gfc_component *comp = NULL;
9257 gfc_loopinfo loop;
9259 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9260 return NULL;
9262 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9263 functions. */
9264 comp = gfc_get_proc_ptr_comp (expr2);
9265 gcc_assert (expr2->value.function.isym
9266 || (comp && comp->attr.dimension)
9267 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9268 && expr2->value.function.esym->result->attr.dimension));
9270 gfc_init_se (&se, NULL);
9271 gfc_start_block (&se.pre);
9272 se.want_pointer = 1;
9274 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9276 if (expr1->ts.type == BT_DERIVED
9277 && expr1->ts.u.derived->attr.alloc_comp)
9279 tree tmp;
9280 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9281 expr1->rank);
9282 gfc_add_expr_to_block (&se.pre, tmp);
9285 se.direct_byref = 1;
9286 se.ss = gfc_walk_expr (expr2);
9287 gcc_assert (se.ss != gfc_ss_terminator);
9289 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9290 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9291 Clearly, this cannot be done for an allocatable function result, since
9292 the shape of the result is unknown and, in any case, the function must
9293 correctly take care of the reallocation internally. For intrinsic
9294 calls, the array data is freed and the library takes care of allocation.
9295 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9296 to the library. */
9297 if (flag_realloc_lhs
9298 && gfc_is_reallocatable_lhs (expr1)
9299 && !gfc_expr_attr (expr1).codimension
9300 && !gfc_is_coindexed (expr1)
9301 && !(expr2->value.function.esym
9302 && expr2->value.function.esym->result->attr.allocatable))
9304 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9306 if (!expr2->value.function.isym)
9308 ss = gfc_walk_expr (expr1);
9309 gcc_assert (ss != gfc_ss_terminator);
9311 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9312 ss->is_alloc_lhs = 1;
9314 else
9315 fcncall_realloc_result (&se, expr1->rank);
9318 gfc_conv_function_expr (&se, expr2);
9319 gfc_add_block_to_block (&se.pre, &se.post);
9321 if (ss)
9322 gfc_cleanup_loop (&loop);
9323 else
9324 gfc_free_ss_chain (se.ss);
9326 return gfc_finish_block (&se.pre);
9330 /* Try to efficiently translate array(:) = 0. Return NULL if this
9331 can't be done. */
9333 static tree
9334 gfc_trans_zero_assign (gfc_expr * expr)
9336 tree dest, len, type;
9337 tree tmp;
9338 gfc_symbol *sym;
9340 sym = expr->symtree->n.sym;
9341 dest = gfc_get_symbol_decl (sym);
9343 type = TREE_TYPE (dest);
9344 if (POINTER_TYPE_P (type))
9345 type = TREE_TYPE (type);
9346 if (!GFC_ARRAY_TYPE_P (type))
9347 return NULL_TREE;
9349 /* Determine the length of the array. */
9350 len = GFC_TYPE_ARRAY_SIZE (type);
9351 if (!len || TREE_CODE (len) != INTEGER_CST)
9352 return NULL_TREE;
9354 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9355 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9356 fold_convert (gfc_array_index_type, tmp));
9358 /* If we are zeroing a local array avoid taking its address by emitting
9359 a = {} instead. */
9360 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9361 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9362 dest, build_constructor (TREE_TYPE (dest),
9363 NULL));
9365 /* Convert arguments to the correct types. */
9366 dest = fold_convert (pvoid_type_node, dest);
9367 len = fold_convert (size_type_node, len);
9369 /* Construct call to __builtin_memset. */
9370 tmp = build_call_expr_loc (input_location,
9371 builtin_decl_explicit (BUILT_IN_MEMSET),
9372 3, dest, integer_zero_node, len);
9373 return fold_convert (void_type_node, tmp);
9377 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9378 that constructs the call to __builtin_memcpy. */
9380 tree
9381 gfc_build_memcpy_call (tree dst, tree src, tree len)
9383 tree tmp;
9385 /* Convert arguments to the correct types. */
9386 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9387 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9388 else
9389 dst = fold_convert (pvoid_type_node, dst);
9391 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9392 src = gfc_build_addr_expr (pvoid_type_node, src);
9393 else
9394 src = fold_convert (pvoid_type_node, src);
9396 len = fold_convert (size_type_node, len);
9398 /* Construct call to __builtin_memcpy. */
9399 tmp = build_call_expr_loc (input_location,
9400 builtin_decl_explicit (BUILT_IN_MEMCPY),
9401 3, dst, src, len);
9402 return fold_convert (void_type_node, tmp);
9406 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9407 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9408 source/rhs, both are gfc_full_array_ref_p which have been checked for
9409 dependencies. */
9411 static tree
9412 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9414 tree dst, dlen, dtype;
9415 tree src, slen, stype;
9416 tree tmp;
9418 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9419 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9421 dtype = TREE_TYPE (dst);
9422 if (POINTER_TYPE_P (dtype))
9423 dtype = TREE_TYPE (dtype);
9424 stype = TREE_TYPE (src);
9425 if (POINTER_TYPE_P (stype))
9426 stype = TREE_TYPE (stype);
9428 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9429 return NULL_TREE;
9431 /* Determine the lengths of the arrays. */
9432 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9433 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9434 return NULL_TREE;
9435 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9436 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9437 dlen, fold_convert (gfc_array_index_type, tmp));
9439 slen = GFC_TYPE_ARRAY_SIZE (stype);
9440 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9441 return NULL_TREE;
9442 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9443 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9444 slen, fold_convert (gfc_array_index_type, tmp));
9446 /* Sanity check that they are the same. This should always be
9447 the case, as we should already have checked for conformance. */
9448 if (!tree_int_cst_equal (slen, dlen))
9449 return NULL_TREE;
9451 return gfc_build_memcpy_call (dst, src, dlen);
9455 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9456 this can't be done. EXPR1 is the destination/lhs for which
9457 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9459 static tree
9460 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9462 unsigned HOST_WIDE_INT nelem;
9463 tree dst, dtype;
9464 tree src, stype;
9465 tree len;
9466 tree tmp;
9468 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9469 if (nelem == 0)
9470 return NULL_TREE;
9472 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9473 dtype = TREE_TYPE (dst);
9474 if (POINTER_TYPE_P (dtype))
9475 dtype = TREE_TYPE (dtype);
9476 if (!GFC_ARRAY_TYPE_P (dtype))
9477 return NULL_TREE;
9479 /* Determine the lengths of the array. */
9480 len = GFC_TYPE_ARRAY_SIZE (dtype);
9481 if (!len || TREE_CODE (len) != INTEGER_CST)
9482 return NULL_TREE;
9484 /* Confirm that the constructor is the same size. */
9485 if (compare_tree_int (len, nelem) != 0)
9486 return NULL_TREE;
9488 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9489 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9490 fold_convert (gfc_array_index_type, tmp));
9492 stype = gfc_typenode_for_spec (&expr2->ts);
9493 src = gfc_build_constant_array_constructor (expr2, stype);
9495 stype = TREE_TYPE (src);
9496 if (POINTER_TYPE_P (stype))
9497 stype = TREE_TYPE (stype);
9499 return gfc_build_memcpy_call (dst, src, len);
9503 /* Tells whether the expression is to be treated as a variable reference. */
9505 bool
9506 gfc_expr_is_variable (gfc_expr *expr)
9508 gfc_expr *arg;
9509 gfc_component *comp;
9510 gfc_symbol *func_ifc;
9512 if (expr->expr_type == EXPR_VARIABLE)
9513 return true;
9515 arg = gfc_get_noncopying_intrinsic_argument (expr);
9516 if (arg)
9518 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9519 return gfc_expr_is_variable (arg);
9522 /* A data-pointer-returning function should be considered as a variable
9523 too. */
9524 if (expr->expr_type == EXPR_FUNCTION
9525 && expr->ref == NULL)
9527 if (expr->value.function.isym != NULL)
9528 return false;
9530 if (expr->value.function.esym != NULL)
9532 func_ifc = expr->value.function.esym;
9533 goto found_ifc;
9535 else
9537 gcc_assert (expr->symtree);
9538 func_ifc = expr->symtree->n.sym;
9539 goto found_ifc;
9542 gcc_unreachable ();
9545 comp = gfc_get_proc_ptr_comp (expr);
9546 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9547 && comp)
9549 func_ifc = comp->ts.interface;
9550 goto found_ifc;
9553 if (expr->expr_type == EXPR_COMPCALL)
9555 gcc_assert (!expr->value.compcall.tbp->is_generic);
9556 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9557 goto found_ifc;
9560 return false;
9562 found_ifc:
9563 gcc_assert (func_ifc->attr.function
9564 && func_ifc->result != NULL);
9565 return func_ifc->result->attr.pointer;
9569 /* Is the lhs OK for automatic reallocation? */
9571 static bool
9572 is_scalar_reallocatable_lhs (gfc_expr *expr)
9574 gfc_ref * ref;
9576 /* An allocatable variable with no reference. */
9577 if (expr->symtree->n.sym->attr.allocatable
9578 && !expr->ref)
9579 return true;
9581 /* All that can be left are allocatable components. However, we do
9582 not check for allocatable components here because the expression
9583 could be an allocatable component of a pointer component. */
9584 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9585 && expr->symtree->n.sym->ts.type != BT_CLASS)
9586 return false;
9588 /* Find an allocatable component ref last. */
9589 for (ref = expr->ref; ref; ref = ref->next)
9590 if (ref->type == REF_COMPONENT
9591 && !ref->next
9592 && ref->u.c.component->attr.allocatable)
9593 return true;
9595 return false;
9599 /* Allocate or reallocate scalar lhs, as necessary. */
9601 static void
9602 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9603 tree string_length,
9604 gfc_expr *expr1,
9605 gfc_expr *expr2)
9608 tree cond;
9609 tree tmp;
9610 tree size;
9611 tree size_in_bytes;
9612 tree jump_label1;
9613 tree jump_label2;
9614 gfc_se lse;
9615 gfc_ref *ref;
9617 if (!expr1 || expr1->rank)
9618 return;
9620 if (!expr2 || expr2->rank)
9621 return;
9623 for (ref = expr1->ref; ref; ref = ref->next)
9624 if (ref->type == REF_SUBSTRING)
9625 return;
9627 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9629 /* Since this is a scalar lhs, we can afford to do this. That is,
9630 there is no risk of side effects being repeated. */
9631 gfc_init_se (&lse, NULL);
9632 lse.want_pointer = 1;
9633 gfc_conv_expr (&lse, expr1);
9635 jump_label1 = gfc_build_label_decl (NULL_TREE);
9636 jump_label2 = gfc_build_label_decl (NULL_TREE);
9638 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9639 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9640 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9641 lse.expr, tmp);
9642 tmp = build3_v (COND_EXPR, cond,
9643 build1_v (GOTO_EXPR, jump_label1),
9644 build_empty_stmt (input_location));
9645 gfc_add_expr_to_block (block, tmp);
9647 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9649 /* Use the rhs string length and the lhs element size. */
9650 size = string_length;
9651 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9652 tmp = TYPE_SIZE_UNIT (tmp);
9653 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9654 TREE_TYPE (tmp), tmp,
9655 fold_convert (TREE_TYPE (tmp), size));
9657 else
9659 /* Otherwise use the length in bytes of the rhs. */
9660 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9661 size_in_bytes = size;
9664 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9665 size_in_bytes, size_one_node);
9667 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9669 tree caf_decl, token;
9670 gfc_se caf_se;
9671 symbol_attribute attr;
9673 gfc_clear_attr (&attr);
9674 gfc_init_se (&caf_se, NULL);
9676 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9677 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9678 NULL);
9679 gfc_add_block_to_block (block, &caf_se.pre);
9680 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9681 gfc_build_addr_expr (NULL_TREE, token),
9682 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9683 expr1, 1);
9685 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9687 tmp = build_call_expr_loc (input_location,
9688 builtin_decl_explicit (BUILT_IN_CALLOC),
9689 2, build_one_cst (size_type_node),
9690 size_in_bytes);
9691 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9692 gfc_add_modify (block, lse.expr, tmp);
9694 else
9696 tmp = build_call_expr_loc (input_location,
9697 builtin_decl_explicit (BUILT_IN_MALLOC),
9698 1, size_in_bytes);
9699 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9700 gfc_add_modify (block, lse.expr, tmp);
9703 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9705 /* Deferred characters need checking for lhs and rhs string
9706 length. Other deferred parameter variables will have to
9707 come here too. */
9708 tmp = build1_v (GOTO_EXPR, jump_label2);
9709 gfc_add_expr_to_block (block, tmp);
9711 tmp = build1_v (LABEL_EXPR, jump_label1);
9712 gfc_add_expr_to_block (block, tmp);
9714 /* For a deferred length character, reallocate if lengths of lhs and
9715 rhs are different. */
9716 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9718 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9719 lse.string_length,
9720 fold_convert (TREE_TYPE (lse.string_length),
9721 size));
9722 /* Jump past the realloc if the lengths are the same. */
9723 tmp = build3_v (COND_EXPR, cond,
9724 build1_v (GOTO_EXPR, jump_label2),
9725 build_empty_stmt (input_location));
9726 gfc_add_expr_to_block (block, tmp);
9727 tmp = build_call_expr_loc (input_location,
9728 builtin_decl_explicit (BUILT_IN_REALLOC),
9729 2, fold_convert (pvoid_type_node, lse.expr),
9730 size_in_bytes);
9731 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9732 gfc_add_modify (block, lse.expr, tmp);
9733 tmp = build1_v (LABEL_EXPR, jump_label2);
9734 gfc_add_expr_to_block (block, tmp);
9736 /* Update the lhs character length. */
9737 size = string_length;
9738 gfc_add_modify (block, lse.string_length,
9739 fold_convert (TREE_TYPE (lse.string_length), size));
9743 /* Check for assignments of the type
9745 a = a + 4
9747 to make sure we do not check for reallocation unneccessarily. */
9750 static bool
9751 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9753 gfc_actual_arglist *a;
9754 gfc_expr *e1, *e2;
9756 switch (expr2->expr_type)
9758 case EXPR_VARIABLE:
9759 return gfc_dep_compare_expr (expr1, expr2) == 0;
9761 case EXPR_FUNCTION:
9762 if (expr2->value.function.esym
9763 && expr2->value.function.esym->attr.elemental)
9765 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9767 e1 = a->expr;
9768 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9769 return false;
9771 return true;
9773 else if (expr2->value.function.isym
9774 && expr2->value.function.isym->elemental)
9776 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9778 e1 = a->expr;
9779 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9780 return false;
9782 return true;
9785 break;
9787 case EXPR_OP:
9788 switch (expr2->value.op.op)
9790 case INTRINSIC_NOT:
9791 case INTRINSIC_UPLUS:
9792 case INTRINSIC_UMINUS:
9793 case INTRINSIC_PARENTHESES:
9794 return is_runtime_conformable (expr1, expr2->value.op.op1);
9796 case INTRINSIC_PLUS:
9797 case INTRINSIC_MINUS:
9798 case INTRINSIC_TIMES:
9799 case INTRINSIC_DIVIDE:
9800 case INTRINSIC_POWER:
9801 case INTRINSIC_AND:
9802 case INTRINSIC_OR:
9803 case INTRINSIC_EQV:
9804 case INTRINSIC_NEQV:
9805 case INTRINSIC_EQ:
9806 case INTRINSIC_NE:
9807 case INTRINSIC_GT:
9808 case INTRINSIC_GE:
9809 case INTRINSIC_LT:
9810 case INTRINSIC_LE:
9811 case INTRINSIC_EQ_OS:
9812 case INTRINSIC_NE_OS:
9813 case INTRINSIC_GT_OS:
9814 case INTRINSIC_GE_OS:
9815 case INTRINSIC_LT_OS:
9816 case INTRINSIC_LE_OS:
9818 e1 = expr2->value.op.op1;
9819 e2 = expr2->value.op.op2;
9821 if (e1->rank == 0 && e2->rank > 0)
9822 return is_runtime_conformable (expr1, e2);
9823 else if (e1->rank > 0 && e2->rank == 0)
9824 return is_runtime_conformable (expr1, e1);
9825 else if (e1->rank > 0 && e2->rank > 0)
9826 return is_runtime_conformable (expr1, e1)
9827 && is_runtime_conformable (expr1, e2);
9828 break;
9830 default:
9831 break;
9835 break;
9837 default:
9838 break;
9840 return false;
9844 static tree
9845 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
9846 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
9847 bool class_realloc)
9849 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
9850 vec<tree, va_gc> *args = NULL;
9852 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
9853 &from_len);
9855 /* Generate allocation of the lhs. */
9856 if (class_realloc)
9858 stmtblock_t alloc;
9859 tree class_han;
9861 tmp = gfc_vptr_size_get (vptr);
9862 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9863 ? gfc_class_data_get (lse->expr) : lse->expr;
9864 gfc_init_block (&alloc);
9865 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
9866 tmp = fold_build2_loc (input_location, EQ_EXPR,
9867 logical_type_node, class_han,
9868 build_int_cst (prvoid_type_node, 0));
9869 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
9870 gfc_unlikely (tmp,
9871 PRED_FORTRAN_FAIL_ALLOC),
9872 gfc_finish_block (&alloc),
9873 build_empty_stmt (input_location));
9874 gfc_add_expr_to_block (&lse->pre, tmp);
9877 fcn = gfc_vptr_copy_get (vptr);
9879 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
9880 ? gfc_class_data_get (rse->expr) : rse->expr;
9881 if (use_vptr_copy)
9883 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9884 || INDIRECT_REF_P (tmp)
9885 || (rhs->ts.type == BT_DERIVED
9886 && rhs->ts.u.derived->attr.unlimited_polymorphic
9887 && !rhs->ts.u.derived->attr.pointer
9888 && !rhs->ts.u.derived->attr.allocatable)
9889 || (UNLIMITED_POLY (rhs)
9890 && !CLASS_DATA (rhs)->attr.pointer
9891 && !CLASS_DATA (rhs)->attr.allocatable))
9892 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9893 else
9894 vec_safe_push (args, tmp);
9895 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9896 ? gfc_class_data_get (lse->expr) : lse->expr;
9897 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9898 || INDIRECT_REF_P (tmp)
9899 || (lhs->ts.type == BT_DERIVED
9900 && lhs->ts.u.derived->attr.unlimited_polymorphic
9901 && !lhs->ts.u.derived->attr.pointer
9902 && !lhs->ts.u.derived->attr.allocatable)
9903 || (UNLIMITED_POLY (lhs)
9904 && !CLASS_DATA (lhs)->attr.pointer
9905 && !CLASS_DATA (lhs)->attr.allocatable))
9906 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9907 else
9908 vec_safe_push (args, tmp);
9910 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
9912 if (to_len != NULL_TREE && !integer_zerop (from_len))
9914 tree extcopy;
9915 vec_safe_push (args, from_len);
9916 vec_safe_push (args, to_len);
9917 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
9919 tmp = fold_build2_loc (input_location, GT_EXPR,
9920 logical_type_node, from_len,
9921 build_zero_cst (TREE_TYPE (from_len)));
9922 return fold_build3_loc (input_location, COND_EXPR,
9923 void_type_node, tmp,
9924 extcopy, stdcopy);
9926 else
9927 return stdcopy;
9929 else
9931 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9932 ? gfc_class_data_get (lse->expr) : lse->expr;
9933 stmtblock_t tblock;
9934 gfc_init_block (&tblock);
9935 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
9936 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
9937 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
9938 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
9939 /* When coming from a ptr_copy lhs and rhs are swapped. */
9940 gfc_add_modify_loc (input_location, &tblock, rhst,
9941 fold_convert (TREE_TYPE (rhst), tmp));
9942 return gfc_finish_block (&tblock);
9946 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9947 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9948 init_flag indicates initialization expressions and dealloc that no
9949 deallocate prior assignment is needed (if in doubt, set true).
9950 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9951 routine instead of a pointer assignment. Alias resolution is only done,
9952 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9953 where it is known, that newly allocated memory on the lhs can never be
9954 an alias of the rhs. */
9956 static tree
9957 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
9958 bool dealloc, bool use_vptr_copy, bool may_alias)
9960 gfc_se lse;
9961 gfc_se rse;
9962 gfc_ss *lss;
9963 gfc_ss *lss_section;
9964 gfc_ss *rss;
9965 gfc_loopinfo loop;
9966 tree tmp;
9967 stmtblock_t block;
9968 stmtblock_t body;
9969 bool l_is_temp;
9970 bool scalar_to_array;
9971 tree string_length;
9972 int n;
9973 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
9974 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
9975 bool is_poly_assign;
9977 /* Assignment of the form lhs = rhs. */
9978 gfc_start_block (&block);
9980 gfc_init_se (&lse, NULL);
9981 gfc_init_se (&rse, NULL);
9983 /* Walk the lhs. */
9984 lss = gfc_walk_expr (expr1);
9985 if (gfc_is_reallocatable_lhs (expr1)
9986 && !(expr2->expr_type == EXPR_FUNCTION
9987 && expr2->value.function.isym != NULL
9988 && !(expr2->value.function.isym->elemental
9989 || expr2->value.function.isym->conversion)))
9990 lss->is_alloc_lhs = 1;
9992 rss = NULL;
9994 if ((expr1->ts.type == BT_DERIVED)
9995 && (gfc_is_class_array_function (expr2)
9996 || gfc_is_alloc_class_scalar_function (expr2)))
9997 expr2->must_finalize = 1;
9999 /* Checking whether a class assignment is desired is quite complicated and
10000 needed at two locations, so do it once only before the information is
10001 needed. */
10002 lhs_attr = gfc_expr_attr (expr1);
10003 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10004 || (lhs_attr.allocatable && !lhs_attr.dimension))
10005 && (expr1->ts.type == BT_CLASS
10006 || gfc_is_class_array_ref (expr1, NULL)
10007 || gfc_is_class_scalar_expr (expr1)
10008 || gfc_is_class_array_ref (expr2, NULL)
10009 || gfc_is_class_scalar_expr (expr2));
10012 /* Only analyze the expressions for coarray properties, when in coarray-lib
10013 mode. */
10014 if (flag_coarray == GFC_FCOARRAY_LIB)
10016 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10017 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10020 if (lss != gfc_ss_terminator)
10022 /* The assignment needs scalarization. */
10023 lss_section = lss;
10025 /* Find a non-scalar SS from the lhs. */
10026 while (lss_section != gfc_ss_terminator
10027 && lss_section->info->type != GFC_SS_SECTION)
10028 lss_section = lss_section->next;
10030 gcc_assert (lss_section != gfc_ss_terminator);
10032 /* Initialize the scalarizer. */
10033 gfc_init_loopinfo (&loop);
10035 /* Walk the rhs. */
10036 rss = gfc_walk_expr (expr2);
10037 if (rss == gfc_ss_terminator)
10038 /* The rhs is scalar. Add a ss for the expression. */
10039 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10040 /* When doing a class assign, then the handle to the rhs needs to be a
10041 pointer to allow for polymorphism. */
10042 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10043 rss->info->type = GFC_SS_REFERENCE;
10045 /* Associate the SS with the loop. */
10046 gfc_add_ss_to_loop (&loop, lss);
10047 gfc_add_ss_to_loop (&loop, rss);
10049 /* Calculate the bounds of the scalarization. */
10050 gfc_conv_ss_startstride (&loop);
10051 /* Enable loop reversal. */
10052 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10053 loop.reverse[n] = GFC_ENABLE_REVERSE;
10054 /* Resolve any data dependencies in the statement. */
10055 if (may_alias)
10056 gfc_conv_resolve_dependencies (&loop, lss, rss);
10057 /* Setup the scalarizing loops. */
10058 gfc_conv_loop_setup (&loop, &expr2->where);
10060 /* Setup the gfc_se structures. */
10061 gfc_copy_loopinfo_to_se (&lse, &loop);
10062 gfc_copy_loopinfo_to_se (&rse, &loop);
10064 rse.ss = rss;
10065 gfc_mark_ss_chain_used (rss, 1);
10066 if (loop.temp_ss == NULL)
10068 lse.ss = lss;
10069 gfc_mark_ss_chain_used (lss, 1);
10071 else
10073 lse.ss = loop.temp_ss;
10074 gfc_mark_ss_chain_used (lss, 3);
10075 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10078 /* Allow the scalarizer to workshare array assignments. */
10079 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10080 == OMPWS_WORKSHARE_FLAG
10081 && loop.temp_ss == NULL)
10083 maybe_workshare = true;
10084 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10087 /* Start the scalarized loop body. */
10088 gfc_start_scalarized_body (&loop, &body);
10090 else
10091 gfc_init_block (&body);
10093 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10095 /* Translate the expression. */
10096 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10097 && lhs_caf_attr.codimension;
10098 gfc_conv_expr (&rse, expr2);
10100 /* Deal with the case of a scalar class function assigned to a derived type. */
10101 if (gfc_is_alloc_class_scalar_function (expr2)
10102 && expr1->ts.type == BT_DERIVED)
10104 rse.expr = gfc_class_data_get (rse.expr);
10105 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10108 /* Stabilize a string length for temporaries. */
10109 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10110 && !(VAR_P (rse.string_length)
10111 || TREE_CODE (rse.string_length) == PARM_DECL
10112 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10113 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10114 else if (expr2->ts.type == BT_CHARACTER)
10115 string_length = rse.string_length;
10116 else
10117 string_length = NULL_TREE;
10119 if (l_is_temp)
10121 gfc_conv_tmp_array_ref (&lse);
10122 if (expr2->ts.type == BT_CHARACTER)
10123 lse.string_length = string_length;
10125 else
10127 gfc_conv_expr (&lse, expr1);
10128 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10129 && !init_flag
10130 && gfc_expr_attr (expr1).allocatable
10131 && expr1->rank
10132 && !expr2->rank)
10134 tree cond;
10135 const char* msg;
10137 tmp = INDIRECT_REF_P (lse.expr)
10138 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10140 /* We should only get array references here. */
10141 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10142 || TREE_CODE (tmp) == ARRAY_REF);
10144 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10145 or the array itself(ARRAY_REF). */
10146 tmp = TREE_OPERAND (tmp, 0);
10148 /* Provide the address of the array. */
10149 if (TREE_CODE (lse.expr) == ARRAY_REF)
10150 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10152 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10153 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10154 msg = _("Assignment of scalar to unallocated array");
10155 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10156 &expr1->where, msg);
10159 /* Deallocate the lhs parameterized components if required. */
10160 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10161 && !expr1->symtree->n.sym->attr.associate_var)
10163 if (expr1->ts.type == BT_DERIVED
10164 && expr1->ts.u.derived
10165 && expr1->ts.u.derived->attr.pdt_type)
10167 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10168 expr1->rank);
10169 gfc_add_expr_to_block (&lse.pre, tmp);
10171 else if (expr1->ts.type == BT_CLASS
10172 && CLASS_DATA (expr1)->ts.u.derived
10173 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10175 tmp = gfc_class_data_get (lse.expr);
10176 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10177 tmp, expr1->rank);
10178 gfc_add_expr_to_block (&lse.pre, tmp);
10183 /* Assignments of scalar derived types with allocatable components
10184 to arrays must be done with a deep copy and the rhs temporary
10185 must have its components deallocated afterwards. */
10186 scalar_to_array = (expr2->ts.type == BT_DERIVED
10187 && expr2->ts.u.derived->attr.alloc_comp
10188 && !gfc_expr_is_variable (expr2)
10189 && expr1->rank && !expr2->rank);
10190 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10191 && expr1->rank
10192 && expr1->ts.u.derived->attr.alloc_comp
10193 && gfc_is_alloc_class_scalar_function (expr2));
10194 if (scalar_to_array && dealloc)
10196 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10197 gfc_prepend_expr_to_block (&loop.post, tmp);
10200 /* When assigning a character function result to a deferred-length variable,
10201 the function call must happen before the (re)allocation of the lhs -
10202 otherwise the character length of the result is not known.
10203 NOTE: This relies on having the exact dependence of the length type
10204 parameter available to the caller; gfortran saves it in the .mod files.
10205 NOTE ALSO: The concatenation operation generates a temporary pointer,
10206 whose allocation must go to the innermost loop.
10207 NOTE ALSO (2): A character conversion may generate a temporary, too. */
10208 if (flag_realloc_lhs
10209 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10210 && !(lss != gfc_ss_terminator
10211 && ((expr2->expr_type == EXPR_OP
10212 && expr2->value.op.op == INTRINSIC_CONCAT)
10213 || (expr2->expr_type == EXPR_FUNCTION
10214 && expr2->value.function.isym != NULL
10215 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION))))
10216 gfc_add_block_to_block (&block, &rse.pre);
10218 /* Nullify the allocatable components corresponding to those of the lhs
10219 derived type, so that the finalization of the function result does not
10220 affect the lhs of the assignment. Prepend is used to ensure that the
10221 nullification occurs before the call to the finalizer. In the case of
10222 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10223 as part of the deep copy. */
10224 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10225 && (gfc_is_class_array_function (expr2)
10226 || gfc_is_alloc_class_scalar_function (expr2)))
10228 tmp = rse.expr;
10229 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10230 gfc_prepend_expr_to_block (&rse.post, tmp);
10231 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10232 gfc_add_block_to_block (&loop.post, &rse.post);
10235 if (is_poly_assign)
10236 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10237 use_vptr_copy || (lhs_attr.allocatable
10238 && !lhs_attr.dimension),
10239 flag_realloc_lhs && !lhs_attr.pointer);
10240 else if (flag_coarray == GFC_FCOARRAY_LIB
10241 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10242 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10243 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10245 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10246 allocatable component, because those need to be accessed via the
10247 caf-runtime. No need to check for coindexes here, because resolve
10248 has rewritten those already. */
10249 gfc_code code;
10250 gfc_actual_arglist a1, a2;
10251 /* Clear the structures to prevent accessing garbage. */
10252 memset (&code, '\0', sizeof (gfc_code));
10253 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10254 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10255 a1.expr = expr1;
10256 a1.next = &a2;
10257 a2.expr = expr2;
10258 a2.next = NULL;
10259 code.ext.actual = &a1;
10260 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10261 tmp = gfc_conv_intrinsic_subroutine (&code);
10263 else
10264 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10265 gfc_expr_is_variable (expr2)
10266 || scalar_to_array
10267 || expr2->expr_type == EXPR_ARRAY,
10268 !(l_is_temp || init_flag) && dealloc,
10269 expr1->symtree->n.sym->attr.codimension);
10270 /* Add the pre blocks to the body. */
10271 gfc_add_block_to_block (&body, &rse.pre);
10272 gfc_add_block_to_block (&body, &lse.pre);
10273 gfc_add_expr_to_block (&body, tmp);
10274 /* Add the post blocks to the body. */
10275 gfc_add_block_to_block (&body, &rse.post);
10276 gfc_add_block_to_block (&body, &lse.post);
10278 if (lss == gfc_ss_terminator)
10280 /* F2003: Add the code for reallocation on assignment. */
10281 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10282 && !is_poly_assign)
10283 alloc_scalar_allocatable_for_assignment (&block, string_length,
10284 expr1, expr2);
10286 /* Use the scalar assignment as is. */
10287 gfc_add_block_to_block (&block, &body);
10289 else
10291 gcc_assert (lse.ss == gfc_ss_terminator
10292 && rse.ss == gfc_ss_terminator);
10294 if (l_is_temp)
10296 gfc_trans_scalarized_loop_boundary (&loop, &body);
10298 /* We need to copy the temporary to the actual lhs. */
10299 gfc_init_se (&lse, NULL);
10300 gfc_init_se (&rse, NULL);
10301 gfc_copy_loopinfo_to_se (&lse, &loop);
10302 gfc_copy_loopinfo_to_se (&rse, &loop);
10304 rse.ss = loop.temp_ss;
10305 lse.ss = lss;
10307 gfc_conv_tmp_array_ref (&rse);
10308 gfc_conv_expr (&lse, expr1);
10310 gcc_assert (lse.ss == gfc_ss_terminator
10311 && rse.ss == gfc_ss_terminator);
10313 if (expr2->ts.type == BT_CHARACTER)
10314 rse.string_length = string_length;
10316 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10317 false, dealloc);
10318 gfc_add_expr_to_block (&body, tmp);
10321 /* F2003: Allocate or reallocate lhs of allocatable array. */
10322 if (flag_realloc_lhs
10323 && gfc_is_reallocatable_lhs (expr1)
10324 && expr2->rank
10325 && !is_runtime_conformable (expr1, expr2))
10327 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10328 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10329 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10330 if (tmp != NULL_TREE)
10331 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10334 if (maybe_workshare)
10335 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10337 /* Generate the copying loops. */
10338 gfc_trans_scalarizing_loops (&loop, &body);
10340 /* Wrap the whole thing up. */
10341 gfc_add_block_to_block (&block, &loop.pre);
10342 gfc_add_block_to_block (&block, &loop.post);
10344 gfc_cleanup_loop (&loop);
10347 return gfc_finish_block (&block);
10351 /* Check whether EXPR is a copyable array. */
10353 static bool
10354 copyable_array_p (gfc_expr * expr)
10356 if (expr->expr_type != EXPR_VARIABLE)
10357 return false;
10359 /* First check it's an array. */
10360 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10361 return false;
10363 if (!gfc_full_array_ref_p (expr->ref, NULL))
10364 return false;
10366 /* Next check that it's of a simple enough type. */
10367 switch (expr->ts.type)
10369 case BT_INTEGER:
10370 case BT_REAL:
10371 case BT_COMPLEX:
10372 case BT_LOGICAL:
10373 return true;
10375 case BT_CHARACTER:
10376 return false;
10378 case_bt_struct:
10379 return !expr->ts.u.derived->attr.alloc_comp;
10381 default:
10382 break;
10385 return false;
10388 /* Translate an assignment. */
10390 tree
10391 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10392 bool dealloc, bool use_vptr_copy, bool may_alias)
10394 tree tmp;
10396 /* Special case a single function returning an array. */
10397 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10399 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10400 if (tmp)
10401 return tmp;
10404 /* Special case assigning an array to zero. */
10405 if (copyable_array_p (expr1)
10406 && is_zero_initializer_p (expr2))
10408 tmp = gfc_trans_zero_assign (expr1);
10409 if (tmp)
10410 return tmp;
10413 /* Special case copying one array to another. */
10414 if (copyable_array_p (expr1)
10415 && copyable_array_p (expr2)
10416 && gfc_compare_types (&expr1->ts, &expr2->ts)
10417 && !gfc_check_dependency (expr1, expr2, 0))
10419 tmp = gfc_trans_array_copy (expr1, expr2);
10420 if (tmp)
10421 return tmp;
10424 /* Special case initializing an array from a constant array constructor. */
10425 if (copyable_array_p (expr1)
10426 && expr2->expr_type == EXPR_ARRAY
10427 && gfc_compare_types (&expr1->ts, &expr2->ts))
10429 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10430 if (tmp)
10431 return tmp;
10434 /* Fallback to the scalarizer to generate explicit loops. */
10435 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10436 use_vptr_copy, may_alias);
10439 tree
10440 gfc_trans_init_assign (gfc_code * code)
10442 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10445 tree
10446 gfc_trans_assign (gfc_code * code)
10448 return gfc_trans_assignment (code->expr1, code->expr2, false, true);