1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #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"
45 /* This is the seed for an eventual trans-class.c
47 The following parameters should not be used directly since they might
48 in future implementations. Use the corresponding APIs. */
49 #define CLASS_DATA_FIELD 0
50 #define CLASS_VPTR_FIELD 1
51 #define VTABLE_HASH_FIELD 0
52 #define VTABLE_SIZE_FIELD 1
53 #define VTABLE_EXTENDS_FIELD 2
54 #define VTABLE_DEF_INIT_FIELD 3
55 #define VTABLE_COPY_FIELD 4
59 gfc_class_data_get (tree decl)
62 if (POINTER_TYPE_P (TREE_TYPE (decl)))
63 decl = build_fold_indirect_ref_loc (input_location, decl);
64 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
66 return fold_build3_loc (input_location, COMPONENT_REF,
67 TREE_TYPE (data), decl, data,
73 gfc_class_vptr_get (tree decl)
76 if (POINTER_TYPE_P (TREE_TYPE (decl)))
77 decl = build_fold_indirect_ref_loc (input_location, decl);
78 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
80 return fold_build3_loc (input_location, COMPONENT_REF,
81 TREE_TYPE (vptr), decl, vptr,
87 gfc_vtable_field_get (tree decl, int field)
91 vptr = gfc_class_vptr_get (decl);
92 vptr = build_fold_indirect_ref_loc (input_location, vptr);
93 size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
95 size = fold_build3_loc (input_location, COMPONENT_REF,
96 TREE_TYPE (size), vptr, size,
98 /* Always return size as an array index type. */
99 if (field == VTABLE_SIZE_FIELD)
100 size = fold_convert (gfc_array_index_type, size);
107 gfc_vtable_hash_get (tree decl)
109 return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
114 gfc_vtable_size_get (tree decl)
116 return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
121 gfc_vtable_extends_get (tree decl)
123 return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
128 gfc_vtable_def_init_get (tree decl)
130 return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
135 gfc_vtable_copy_get (tree decl)
137 return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
141 #undef CLASS_DATA_FIELD
142 #undef CLASS_VPTR_FIELD
143 #undef VTABLE_HASH_FIELD
144 #undef VTABLE_SIZE_FIELD
145 #undef VTABLE_EXTENDS_FIELD
146 #undef VTABLE_DEF_INIT_FIELD
147 #undef VTABLE_COPY_FIELD
150 /* Takes a derived type expression and returns the address of a temporary
151 class object of the 'declared' type. */
153 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
154 gfc_typespec class_ts)
162 /* The derived type needs to be converted to a temporary
164 tmp = gfc_typenode_for_spec (&class_ts);
165 var = gfc_create_var (tmp, "class");
168 ctree = gfc_class_vptr_get (var);
170 /* Remember the vtab corresponds to the derived type
171 not to the class declared type. */
172 vtab = gfc_find_derived_vtab (e->ts.u.derived);
174 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
175 gfc_add_modify (&parmse->pre, ctree,
176 fold_convert (TREE_TYPE (ctree), tmp));
178 /* Now set the data field. */
179 ctree = gfc_class_data_get (var);
181 if (parmse->ss && parmse->ss->info->useflags)
183 /* For an array reference in an elemental procedure call we need
184 to retain the ss to provide the scalarized array reference. */
185 gfc_conv_expr_reference (parmse, e);
186 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
187 gfc_add_modify (&parmse->pre, ctree, tmp);
191 ss = gfc_walk_expr (e);
192 if (ss == gfc_ss_terminator)
195 gfc_conv_expr_reference (parmse, e);
196 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
197 gfc_add_modify (&parmse->pre, ctree, tmp);
202 gfc_conv_expr_descriptor (parmse, e, ss);
203 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
207 /* Pass the address of the class object. */
208 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
212 /* Takes a scalarized class array expression and returns the
213 address of a temporary scalar class object of the 'declared'
215 OOP-TODO: This could be improved by adding code that branched on
216 the dynamic type being the same as the declared type. In this case
217 the original class expression can be passed directly. */
219 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
220 gfc_typespec class_ts, bool elemental)
228 bool full_array = false;
231 for (ref = e->ref; ref; ref = ref->next)
233 if (ref->type == REF_COMPONENT
234 && ref->u.c.component->ts.type == BT_CLASS)
237 if (ref->next == NULL)
241 if (ref == NULL || class_ref == ref)
244 /* Test for FULL_ARRAY. */
245 gfc_is_class_array_ref (e, &full_array);
247 /* The derived type needs to be converted to a temporary
249 tmp = gfc_typenode_for_spec (&class_ts);
250 var = gfc_create_var (tmp, "class");
253 ctree = gfc_class_data_get (var);
254 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
256 /* Return the data component, except in the case of scalarized array
257 references, where nullification of the cannot occur and so there
259 if (!elemental && full_array)
260 gfc_add_modify (&parmse->post, parmse->expr, ctree);
263 ctree = gfc_class_vptr_get (var);
265 /* The vptr is the second field of the actual argument.
266 First we have to find the corresponding class reference. */
269 if (class_ref == NULL
270 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
271 tmp = e->symtree->n.sym->backend_decl;
274 /* Remove everything after the last class reference, convert the
275 expression and then recover its tailend once more. */
277 ref = class_ref->next;
278 class_ref->next = NULL;
279 gfc_init_se (&tmpse, NULL);
280 gfc_conv_expr (&tmpse, e);
281 class_ref->next = ref;
285 gcc_assert (tmp != NULL_TREE);
287 /* Dereference if needs be. */
288 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
289 tmp = build_fold_indirect_ref_loc (input_location, tmp);
291 vptr = gfc_class_vptr_get (tmp);
292 gfc_add_modify (&parmse->pre, ctree,
293 fold_convert (TREE_TYPE (ctree), vptr));
295 /* Return the vptr component, except in the case of scalarized array
296 references, where the dynamic type cannot change. */
297 if (!elemental && full_array)
298 gfc_add_modify (&parmse->post, vptr,
299 fold_convert (TREE_TYPE (vptr), ctree));
301 /* Pass the address of the class object. */
302 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
307 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
309 gfc_actual_arglist *actual;
314 actual = gfc_get_actual_arglist ();
315 actual->expr = gfc_copy_expr (rhs);
316 actual->next = gfc_get_actual_arglist ();
317 actual->next->expr = gfc_copy_expr (lhs);
318 ppc = gfc_copy_expr (obj);
319 gfc_add_vptr_component (ppc);
320 gfc_add_component_ref (ppc, "_copy");
321 ppc_code = gfc_get_code ();
322 ppc_code->resolved_sym = ppc->symtree->n.sym;
323 /* Although '_copy' is set to be elemental in class.c, it is
324 not staying that way. Find out why, sometime.... */
325 ppc_code->resolved_sym->attr.elemental = 1;
326 ppc_code->ext.actual = actual;
327 ppc_code->expr1 = ppc;
328 ppc_code->op = EXEC_CALL;
329 /* Since '_copy' is elemental, the scalarizer will take care
330 of arrays in gfc_trans_call. */
331 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
332 gfc_free_statements (ppc_code);
336 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
337 A MEMCPY is needed to copy the full data from the default initializer
338 of the dynamic type. */
341 gfc_trans_class_init_assign (gfc_code *code)
345 gfc_se dst,src,memsz;
346 gfc_expr *lhs, *rhs, *sz;
348 gfc_start_block (&block);
350 lhs = gfc_copy_expr (code->expr1);
351 gfc_add_data_component (lhs);
353 rhs = gfc_copy_expr (code->expr1);
354 gfc_add_vptr_component (rhs);
356 /* Make sure that the component backend_decls have been built, which
357 will not have happened if the derived types concerned have not
359 gfc_get_derived_type (rhs->ts.u.derived);
360 gfc_add_def_init_component (rhs);
362 if (code->expr1->ts.type == BT_CLASS
363 && CLASS_DATA (code->expr1)->attr.dimension)
364 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
367 sz = gfc_copy_expr (code->expr1);
368 gfc_add_vptr_component (sz);
369 gfc_add_size_component (sz);
371 gfc_init_se (&dst, NULL);
372 gfc_init_se (&src, NULL);
373 gfc_init_se (&memsz, NULL);
374 gfc_conv_expr (&dst, lhs);
375 gfc_conv_expr (&src, rhs);
376 gfc_conv_expr (&memsz, sz);
377 gfc_add_block_to_block (&block, &src.pre);
378 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
380 gfc_add_expr_to_block (&block, tmp);
382 return gfc_finish_block (&block);
386 /* Translate an assignment to a CLASS object
387 (pointer or ordinary assignment). */
390 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
398 gfc_start_block (&block);
401 while (ref && ref->next)
404 /* Class valued proc_pointer assignments do not need any further
406 if (ref && ref->type == REF_COMPONENT
407 && ref->u.c.component->attr.proc_pointer
408 && expr2->expr_type == EXPR_VARIABLE
409 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
410 && op == EXEC_POINTER_ASSIGN)
413 if (expr2->ts.type != BT_CLASS)
415 /* Insert an additional assignment which sets the '_vptr' field. */
416 gfc_symbol *vtab = NULL;
419 lhs = gfc_copy_expr (expr1);
420 gfc_add_vptr_component (lhs);
422 if (expr2->ts.type == BT_DERIVED)
423 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
424 else if (expr2->expr_type == EXPR_NULL)
425 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
428 rhs = gfc_get_expr ();
429 rhs->expr_type = EXPR_VARIABLE;
430 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
434 tmp = gfc_trans_pointer_assignment (lhs, rhs);
435 gfc_add_expr_to_block (&block, tmp);
440 else if (CLASS_DATA (expr2)->attr.dimension)
442 /* Insert an additional assignment which sets the '_vptr' field. */
443 lhs = gfc_copy_expr (expr1);
444 gfc_add_vptr_component (lhs);
446 rhs = gfc_copy_expr (expr2);
447 gfc_add_vptr_component (rhs);
449 tmp = gfc_trans_pointer_assignment (lhs, rhs);
450 gfc_add_expr_to_block (&block, tmp);
456 /* Do the actual CLASS assignment. */
457 if (expr2->ts.type == BT_CLASS
458 && !CLASS_DATA (expr2)->attr.dimension)
461 gfc_add_data_component (expr1);
465 if (op == EXEC_ASSIGN)
466 tmp = gfc_trans_assignment (expr1, expr2, false, true);
467 else if (op == EXEC_POINTER_ASSIGN)
468 tmp = gfc_trans_pointer_assignment (expr1, expr2);
472 gfc_add_expr_to_block (&block, tmp);
474 return gfc_finish_block (&block);
478 /* End of prototype trans-class.c */
481 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
482 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
485 /* Copy the scalarization loop variables. */
488 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
491 dest->loop = src->loop;
495 /* Initialize a simple expression holder.
497 Care must be taken when multiple se are created with the same parent.
498 The child se must be kept in sync. The easiest way is to delay creation
499 of a child se until after after the previous se has been translated. */
502 gfc_init_se (gfc_se * se, gfc_se * parent)
504 memset (se, 0, sizeof (gfc_se));
505 gfc_init_block (&se->pre);
506 gfc_init_block (&se->post);
511 gfc_copy_se_loopvars (se, parent);
515 /* Advances to the next SS in the chain. Use this rather than setting
516 se->ss = se->ss->next because all the parents needs to be kept in sync.
520 gfc_advance_se_ss_chain (gfc_se * se)
525 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
528 /* Walk down the parent chain. */
531 /* Simple consistency check. */
532 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
533 || p->parent->ss->nested_ss == p->ss);
535 /* If we were in a nested loop, the next scalarized expression can be
536 on the parent ss' next pointer. Thus we should not take the next
537 pointer blindly, but rather go up one nest level as long as next
538 is the end of chain. */
540 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
550 /* Ensures the result of the expression as either a temporary variable
551 or a constant so that it can be used repeatedly. */
554 gfc_make_safe_expr (gfc_se * se)
558 if (CONSTANT_CLASS_P (se->expr))
561 /* We need a temporary for this result. */
562 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
563 gfc_add_modify (&se->pre, var, se->expr);
568 /* Return an expression which determines if a dummy parameter is present.
569 Also used for arguments to procedures with multiple entry points. */
572 gfc_conv_expr_present (gfc_symbol * sym)
576 gcc_assert (sym->attr.dummy);
578 decl = gfc_get_symbol_decl (sym);
579 if (TREE_CODE (decl) != PARM_DECL)
581 /* Array parameters use a temporary descriptor, we want the real
583 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
584 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
585 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
588 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
589 fold_convert (TREE_TYPE (decl), null_pointer_node));
591 /* Fortran 2008 allows to pass null pointers and non-associated pointers
592 as actual argument to denote absent dummies. For array descriptors,
593 we thus also need to check the array descriptor. */
594 if (!sym->attr.pointer && !sym->attr.allocatable
595 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
596 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
599 tmp = build_fold_indirect_ref_loc (input_location, decl);
600 tmp = gfc_conv_array_data (tmp);
601 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
602 fold_convert (TREE_TYPE (tmp), null_pointer_node));
603 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
604 boolean_type_node, cond, tmp);
611 /* Converts a missing, dummy argument into a null or zero. */
614 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
619 present = gfc_conv_expr_present (arg->symtree->n.sym);
623 /* Create a temporary and convert it to the correct type. */
624 tmp = gfc_get_int_type (kind);
625 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
628 /* Test for a NULL value. */
629 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
630 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
631 tmp = gfc_evaluate_now (tmp, &se->pre);
632 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
636 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
638 build_zero_cst (TREE_TYPE (se->expr)));
639 tmp = gfc_evaluate_now (tmp, &se->pre);
643 if (ts.type == BT_CHARACTER)
645 tmp = build_int_cst (gfc_charlen_type_node, 0);
646 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
647 present, se->string_length, tmp);
648 tmp = gfc_evaluate_now (tmp, &se->pre);
649 se->string_length = tmp;
655 /* Get the character length of an expression, looking through gfc_refs
659 gfc_get_expr_charlen (gfc_expr *e)
664 gcc_assert (e->expr_type == EXPR_VARIABLE
665 && e->ts.type == BT_CHARACTER);
667 length = NULL; /* To silence compiler warning. */
669 if (is_subref_array (e) && e->ts.u.cl->length)
672 gfc_init_se (&tmpse, NULL);
673 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
674 e->ts.u.cl->backend_decl = tmpse.expr;
678 /* First candidate: if the variable is of type CHARACTER, the
679 expression's length could be the length of the character
681 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
682 length = e->symtree->n.sym->ts.u.cl->backend_decl;
684 /* Look through the reference chain for component references. */
685 for (r = e->ref; r; r = r->next)
690 if (r->u.c.component->ts.type == BT_CHARACTER)
691 length = r->u.c.component->ts.u.cl->backend_decl;
699 /* We should never got substring references here. These will be
700 broken down by the scalarizer. */
706 gcc_assert (length != NULL);
711 /* Return for an expression the backend decl of the coarray. */
714 get_tree_for_caf_expr (gfc_expr *expr)
716 tree caf_decl = NULL_TREE;
719 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
720 if (expr->symtree->n.sym->attr.codimension)
721 caf_decl = expr->symtree->n.sym->backend_decl;
723 for (ref = expr->ref; ref; ref = ref->next)
724 if (ref->type == REF_COMPONENT)
726 gfc_component *comp = ref->u.c.component;
727 if (comp->attr.pointer || comp->attr.allocatable)
728 caf_decl = NULL_TREE;
729 if (comp->attr.codimension)
730 caf_decl = comp->backend_decl;
733 gcc_assert (caf_decl != NULL_TREE);
738 /* For each character array constructor subexpression without a ts.u.cl->length,
739 replace it by its first element (if there aren't any elements, the length
740 should already be set to zero). */
743 flatten_array_ctors_without_strlen (gfc_expr* e)
745 gfc_actual_arglist* arg;
751 switch (e->expr_type)
755 flatten_array_ctors_without_strlen (e->value.op.op1);
756 flatten_array_ctors_without_strlen (e->value.op.op2);
760 /* TODO: Implement as with EXPR_FUNCTION when needed. */
764 for (arg = e->value.function.actual; arg; arg = arg->next)
765 flatten_array_ctors_without_strlen (arg->expr);
770 /* We've found what we're looking for. */
771 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
776 gcc_assert (e->value.constructor);
778 c = gfc_constructor_first (e->value.constructor);
782 flatten_array_ctors_without_strlen (new_expr);
783 gfc_replace_expr (e, new_expr);
787 /* Otherwise, fall through to handle constructor elements. */
789 for (c = gfc_constructor_first (e->value.constructor);
790 c; c = gfc_constructor_next (c))
791 flatten_array_ctors_without_strlen (c->expr);
801 /* Generate code to initialize a string length variable. Returns the
802 value. For array constructors, cl->length might be NULL and in this case,
803 the first element of the constructor is needed. expr is the original
804 expression so we can access it but can be NULL if this is not needed. */
807 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
811 gfc_init_se (&se, NULL);
815 && TREE_CODE (cl->backend_decl) == VAR_DECL)
818 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
819 "flatten" array constructors by taking their first element; all elements
820 should be the same length or a cl->length should be present. */
825 expr_flat = gfc_copy_expr (expr);
826 flatten_array_ctors_without_strlen (expr_flat);
827 gfc_resolve_expr (expr_flat);
829 gfc_conv_expr (&se, expr_flat);
830 gfc_add_block_to_block (pblock, &se.pre);
831 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
833 gfc_free_expr (expr_flat);
837 /* Convert cl->length. */
839 gcc_assert (cl->length);
841 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
842 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
843 se.expr, build_int_cst (gfc_charlen_type_node, 0));
844 gfc_add_block_to_block (pblock, &se.pre);
846 if (cl->backend_decl)
847 gfc_add_modify (pblock, cl->backend_decl, se.expr);
849 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
854 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
855 const char *name, locus *where)
864 type = gfc_get_character_type (kind, ref->u.ss.length);
865 type = build_pointer_type (type);
867 gfc_init_se (&start, se);
868 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
869 gfc_add_block_to_block (&se->pre, &start.pre);
871 if (integer_onep (start.expr))
872 gfc_conv_string_parameter (se);
877 /* Avoid multiple evaluation of substring start. */
878 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
879 start.expr = gfc_evaluate_now (start.expr, &se->pre);
881 /* Change the start of the string. */
882 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
885 tmp = build_fold_indirect_ref_loc (input_location,
887 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
888 se->expr = gfc_build_addr_expr (type, tmp);
891 /* Length = end + 1 - start. */
892 gfc_init_se (&end, se);
893 if (ref->u.ss.end == NULL)
894 end.expr = se->string_length;
897 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
898 gfc_add_block_to_block (&se->pre, &end.pre);
902 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
903 end.expr = gfc_evaluate_now (end.expr, &se->pre);
905 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
907 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
908 boolean_type_node, start.expr,
911 /* Check lower bound. */
912 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
914 build_int_cst (gfc_charlen_type_node, 1));
915 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
916 boolean_type_node, nonempty, fault);
918 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
919 "is less than one", name);
921 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
923 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
924 fold_convert (long_integer_type_node,
928 /* Check upper bound. */
929 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
930 end.expr, se->string_length);
931 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
932 boolean_type_node, nonempty, fault);
934 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
935 "exceeds string length (%%ld)", name);
937 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
938 "exceeds string length (%%ld)");
939 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
940 fold_convert (long_integer_type_node, end.expr),
941 fold_convert (long_integer_type_node,
946 /* If the start and end expressions are equal, the length is one. */
948 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
949 tmp = build_int_cst (gfc_charlen_type_node, 1);
952 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
953 end.expr, start.expr);
954 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
955 build_int_cst (gfc_charlen_type_node, 1), tmp);
956 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
957 tmp, build_int_cst (gfc_charlen_type_node, 0));
960 se->string_length = tmp;
964 /* Convert a derived type component reference. */
967 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
974 c = ref->u.c.component;
976 gcc_assert (c->backend_decl);
978 field = c->backend_decl;
979 gcc_assert (TREE_CODE (field) == FIELD_DECL);
982 /* Components can correspond to fields of different containing
983 types, as components are created without context, whereas
984 a concrete use of a component has the type of decl as context.
985 So, if the type doesn't match, we search the corresponding
986 FIELD_DECL in the parent type. To not waste too much time
987 we cache this result in norestrict_decl. */
989 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
991 tree f2 = c->norestrict_decl;
992 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
993 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
994 if (TREE_CODE (f2) == FIELD_DECL
995 && DECL_NAME (f2) == DECL_NAME (field))
998 c->norestrict_decl = f2;
1001 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1002 decl, field, NULL_TREE);
1006 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
1008 tmp = c->ts.u.cl->backend_decl;
1009 /* Components must always be constant length. */
1010 gcc_assert (tmp && INTEGER_CST_P (tmp));
1011 se->string_length = tmp;
1014 if (((c->attr.pointer || c->attr.allocatable)
1015 && (!c->attr.dimension && !c->attr.codimension)
1016 && c->ts.type != BT_CHARACTER)
1017 || c->attr.proc_pointer)
1018 se->expr = build_fold_indirect_ref_loc (input_location,
1023 /* This function deals with component references to components of the
1024 parent type for derived type extensons. */
1026 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
1034 c = ref->u.c.component;
1036 /* Return if the component is not in the parent type. */
1037 for (cmp = dt->components; cmp; cmp = cmp->next)
1038 if (strcmp (c->name, cmp->name) == 0)
1041 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1042 parent.type = REF_COMPONENT;
1044 parent.u.c.sym = dt;
1045 parent.u.c.component = dt->components;
1047 if (dt->backend_decl == NULL)
1048 gfc_get_derived_type (dt);
1050 /* Build the reference and call self. */
1051 gfc_conv_component_ref (se, &parent);
1052 parent.u.c.sym = dt->components->ts.u.derived;
1053 parent.u.c.component = c;
1054 conv_parent_component_references (se, &parent);
1057 /* Return the contents of a variable. Also handles reference/pointer
1058 variables (all Fortran pointer references are implicit). */
1061 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
1066 tree parent_decl = NULL_TREE;
1069 bool alternate_entry;
1072 sym = expr->symtree->n.sym;
1076 gfc_ss_info *ss_info = ss->info;
1078 /* Check that something hasn't gone horribly wrong. */
1079 gcc_assert (ss != gfc_ss_terminator);
1080 gcc_assert (ss_info->expr == expr);
1082 /* A scalarized term. We already know the descriptor. */
1083 se->expr = ss_info->data.array.descriptor;
1084 se->string_length = ss_info->string_length;
1085 for (ref = ss_info->data.array.ref; ref; ref = ref->next)
1086 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
1091 tree se_expr = NULL_TREE;
1093 se->expr = gfc_get_symbol_decl (sym);
1095 /* Deal with references to a parent results or entries by storing
1096 the current_function_decl and moving to the parent_decl. */
1097 return_value = sym->attr.function && sym->result == sym;
1098 alternate_entry = sym->attr.function && sym->attr.entry
1099 && sym->result == sym;
1100 entry_master = sym->attr.result
1101 && sym->ns->proc_name->attr.entry_master
1102 && !gfc_return_by_reference (sym->ns->proc_name);
1103 if (current_function_decl)
1104 parent_decl = DECL_CONTEXT (current_function_decl);
1106 if ((se->expr == parent_decl && return_value)
1107 || (sym->ns && sym->ns->proc_name
1109 && sym->ns->proc_name->backend_decl == parent_decl
1110 && (alternate_entry || entry_master)))
1115 /* Special case for assigning the return value of a function.
1116 Self recursive functions must have an explicit return value. */
1117 if (return_value && (se->expr == current_function_decl || parent_flag))
1118 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1120 /* Similarly for alternate entry points. */
1121 else if (alternate_entry
1122 && (sym->ns->proc_name->backend_decl == current_function_decl
1125 gfc_entry_list *el = NULL;
1127 for (el = sym->ns->entries; el; el = el->next)
1130 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1135 else if (entry_master
1136 && (sym->ns->proc_name->backend_decl == current_function_decl
1138 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1143 /* Procedure actual arguments. */
1144 else if (sym->attr.flavor == FL_PROCEDURE
1145 && se->expr != current_function_decl)
1147 if (!sym->attr.dummy && !sym->attr.proc_pointer)
1149 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
1150 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1156 /* Dereference the expression, where needed. Since characters
1157 are entirely different from other types, they are treated
1159 if (sym->ts.type == BT_CHARACTER)
1161 /* Dereference character pointer dummy arguments
1163 if ((sym->attr.pointer || sym->attr.allocatable)
1165 || sym->attr.function
1166 || sym->attr.result))
1167 se->expr = build_fold_indirect_ref_loc (input_location,
1171 else if (!sym->attr.value)
1173 /* Dereference non-character scalar dummy arguments. */
1174 if (sym->attr.dummy && !sym->attr.dimension
1175 && !(sym->attr.codimension && sym->attr.allocatable))
1176 se->expr = build_fold_indirect_ref_loc (input_location,
1179 /* Dereference scalar hidden result. */
1180 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
1181 && (sym->attr.function || sym->attr.result)
1182 && !sym->attr.dimension && !sym->attr.pointer
1183 && !sym->attr.always_explicit)
1184 se->expr = build_fold_indirect_ref_loc (input_location,
1187 /* Dereference non-character pointer variables.
1188 These must be dummies, results, or scalars. */
1189 if ((sym->attr.pointer || sym->attr.allocatable
1190 || gfc_is_associate_pointer (sym))
1192 || sym->attr.function
1194 || (!sym->attr.dimension
1195 && (!sym->attr.codimension || !sym->attr.allocatable))))
1196 se->expr = build_fold_indirect_ref_loc (input_location,
1203 /* For character variables, also get the length. */
1204 if (sym->ts.type == BT_CHARACTER)
1206 /* If the character length of an entry isn't set, get the length from
1207 the master function instead. */
1208 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
1209 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
1211 se->string_length = sym->ts.u.cl->backend_decl;
1212 gcc_assert (se->string_length);
1220 /* Return the descriptor if that's what we want and this is an array
1221 section reference. */
1222 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
1224 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1225 /* Return the descriptor for array pointers and allocations. */
1226 if (se->want_pointer
1227 && ref->next == NULL && (se->descriptor_only))
1230 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
1231 /* Return a pointer to an element. */
1235 if (ref->u.c.sym->attr.extension)
1236 conv_parent_component_references (se, ref);
1238 gfc_conv_component_ref (se, ref);
1243 gfc_conv_substring (se, ref, expr->ts.kind,
1244 expr->symtree->name, &expr->where);
1253 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1255 if (se->want_pointer)
1257 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
1258 gfc_conv_string_parameter (se);
1260 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1265 /* Unary ops are easy... Or they would be if ! was a valid op. */
1268 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
1273 gcc_assert (expr->ts.type != BT_CHARACTER);
1274 /* Initialize the operand. */
1275 gfc_init_se (&operand, se);
1276 gfc_conv_expr_val (&operand, expr->value.op.op1);
1277 gfc_add_block_to_block (&se->pre, &operand.pre);
1279 type = gfc_typenode_for_spec (&expr->ts);
1281 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1282 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1283 All other unary operators have an equivalent GIMPLE unary operator. */
1284 if (code == TRUTH_NOT_EXPR)
1285 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
1286 build_int_cst (type, 0));
1288 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
1292 /* Expand power operator to optimal multiplications when a value is raised
1293 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1294 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1295 Programming", 3rd Edition, 1998. */
1297 /* This code is mostly duplicated from expand_powi in the backend.
1298 We establish the "optimal power tree" lookup table with the defined size.
1299 The items in the table are the exponents used to calculate the index
1300 exponents. Any integer n less than the value can get an "addition chain",
1301 with the first node being one. */
1302 #define POWI_TABLE_SIZE 256
1304 /* The table is from builtins.c. */
1305 static const unsigned char powi_table[POWI_TABLE_SIZE] =
1307 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1308 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1309 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1310 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1311 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1312 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1313 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1314 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1315 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1316 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1317 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1318 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1319 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1320 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1321 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1322 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1323 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1324 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1325 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1326 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1327 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1328 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1329 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1330 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1331 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1332 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1333 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1334 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1335 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1336 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1337 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1338 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1341 /* If n is larger than lookup table's max index, we use the "window
1343 #define POWI_WINDOW_SIZE 3
1345 /* Recursive function to expand the power operator. The temporary
1346 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1348 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
1355 if (n < POWI_TABLE_SIZE)
1360 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
1361 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
1365 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
1366 op0 = gfc_conv_powi (se, n - digit, tmpvar);
1367 op1 = gfc_conv_powi (se, digit, tmpvar);
1371 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
1375 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
1376 tmp = gfc_evaluate_now (tmp, &se->pre);
1378 if (n < POWI_TABLE_SIZE)
1385 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1386 return 1. Else return 0 and a call to runtime library functions
1387 will have to be built. */
1389 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
1394 tree vartmp[POWI_TABLE_SIZE];
1396 unsigned HOST_WIDE_INT n;
1399 /* If exponent is too large, we won't expand it anyway, so don't bother
1400 with large integer values. */
1401 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
1404 m = double_int_to_shwi (TREE_INT_CST (rhs));
1405 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1406 of the asymmetric range of the integer type. */
1407 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
1409 type = TREE_TYPE (lhs);
1410 sgn = tree_int_cst_sgn (rhs);
1412 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
1413 || optimize_size) && (m > 2 || m < -1))
1419 se->expr = gfc_build_const (type, integer_one_node);
1423 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1424 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
1426 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1427 lhs, build_int_cst (TREE_TYPE (lhs), -1));
1428 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1429 lhs, build_int_cst (TREE_TYPE (lhs), 1));
1432 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1435 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1436 boolean_type_node, tmp, cond);
1437 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1438 tmp, build_int_cst (type, 1),
1439 build_int_cst (type, 0));
1443 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1444 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
1445 build_int_cst (type, -1),
1446 build_int_cst (type, 0));
1447 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1448 cond, build_int_cst (type, 1), tmp);
1452 memset (vartmp, 0, sizeof (vartmp));
1456 tmp = gfc_build_const (type, integer_one_node);
1457 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1461 se->expr = gfc_conv_powi (se, n, vartmp);
1467 /* Power op (**). Constant integer exponent has special handling. */
1470 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1472 tree gfc_int4_type_node;
1475 int res_ikind_1, res_ikind_2;
1480 gfc_init_se (&lse, se);
1481 gfc_conv_expr_val (&lse, expr->value.op.op1);
1482 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1483 gfc_add_block_to_block (&se->pre, &lse.pre);
1485 gfc_init_se (&rse, se);
1486 gfc_conv_expr_val (&rse, expr->value.op.op2);
1487 gfc_add_block_to_block (&se->pre, &rse.pre);
1489 if (expr->value.op.op2->ts.type == BT_INTEGER
1490 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1491 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1494 gfc_int4_type_node = gfc_get_int_type (4);
1496 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1497 library routine. But in the end, we have to convert the result back
1498 if this case applies -- with res_ikind_K, we keep track whether operand K
1499 falls into this case. */
1503 kind = expr->value.op.op1->ts.kind;
1504 switch (expr->value.op.op2->ts.type)
1507 ikind = expr->value.op.op2->ts.kind;
1512 rse.expr = convert (gfc_int4_type_node, rse.expr);
1513 res_ikind_2 = ikind;
1535 if (expr->value.op.op1->ts.type == BT_INTEGER)
1537 lse.expr = convert (gfc_int4_type_node, lse.expr);
1564 switch (expr->value.op.op1->ts.type)
1567 if (kind == 3) /* Case 16 was not handled properly above. */
1569 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1573 /* Use builtins for real ** int4. */
1579 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
1583 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
1587 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1591 /* Use the __builtin_powil() only if real(kind=16) is
1592 actually the C long double type. */
1593 if (!gfc_real16_is_float128)
1594 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1602 /* If we don't have a good builtin for this, go for the
1603 library function. */
1605 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1609 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1618 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1622 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1630 se->expr = build_call_expr_loc (input_location,
1631 fndecl, 2, lse.expr, rse.expr);
1633 /* Convert the result back if it is of wrong integer kind. */
1634 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1636 /* We want the maximum of both operand kinds as result. */
1637 if (res_ikind_1 < res_ikind_2)
1638 res_ikind_1 = res_ikind_2;
1639 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1644 /* Generate code to allocate a string temporary. */
1647 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1652 if (gfc_can_put_var_on_stack (len))
1654 /* Create a temporary variable to hold the result. */
1655 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1656 gfc_charlen_type_node, len,
1657 build_int_cst (gfc_charlen_type_node, 1));
1658 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1660 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1661 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1663 tmp = build_array_type (TREE_TYPE (type), tmp);
1665 var = gfc_create_var (tmp, "str");
1666 var = gfc_build_addr_expr (type, var);
1670 /* Allocate a temporary to hold the result. */
1671 var = gfc_create_var (type, "pstr");
1672 tmp = gfc_call_malloc (&se->pre, type,
1673 fold_build2_loc (input_location, MULT_EXPR,
1674 TREE_TYPE (len), len,
1675 fold_convert (TREE_TYPE (len),
1676 TYPE_SIZE (type))));
1677 gfc_add_modify (&se->pre, var, tmp);
1679 /* Free the temporary afterwards. */
1680 tmp = gfc_call_free (convert (pvoid_type_node, var));
1681 gfc_add_expr_to_block (&se->post, tmp);
1688 /* Handle a string concatenation operation. A temporary will be allocated to
1692 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1695 tree len, type, var, tmp, fndecl;
1697 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1698 && expr->value.op.op2->ts.type == BT_CHARACTER);
1699 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1701 gfc_init_se (&lse, se);
1702 gfc_conv_expr (&lse, expr->value.op.op1);
1703 gfc_conv_string_parameter (&lse);
1704 gfc_init_se (&rse, se);
1705 gfc_conv_expr (&rse, expr->value.op.op2);
1706 gfc_conv_string_parameter (&rse);
1708 gfc_add_block_to_block (&se->pre, &lse.pre);
1709 gfc_add_block_to_block (&se->pre, &rse.pre);
1711 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1712 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1713 if (len == NULL_TREE)
1715 len = fold_build2_loc (input_location, PLUS_EXPR,
1716 TREE_TYPE (lse.string_length),
1717 lse.string_length, rse.string_length);
1720 type = build_pointer_type (type);
1722 var = gfc_conv_string_tmp (se, type, len);
1724 /* Do the actual concatenation. */
1725 if (expr->ts.kind == 1)
1726 fndecl = gfor_fndecl_concat_string;
1727 else if (expr->ts.kind == 4)
1728 fndecl = gfor_fndecl_concat_string_char4;
1732 tmp = build_call_expr_loc (input_location,
1733 fndecl, 6, len, var, lse.string_length, lse.expr,
1734 rse.string_length, rse.expr);
1735 gfc_add_expr_to_block (&se->pre, tmp);
1737 /* Add the cleanup for the operands. */
1738 gfc_add_block_to_block (&se->pre, &rse.post);
1739 gfc_add_block_to_block (&se->pre, &lse.post);
1742 se->string_length = len;
1745 /* Translates an op expression. Common (binary) cases are handled by this
1746 function, others are passed on. Recursion is used in either case.
1747 We use the fact that (op1.ts == op2.ts) (except for the power
1749 Operators need no special handling for scalarized expressions as long as
1750 they call gfc_conv_simple_val to get their operands.
1751 Character strings get special handling. */
1754 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1756 enum tree_code code;
1765 switch (expr->value.op.op)
1767 case INTRINSIC_PARENTHESES:
1768 if ((expr->ts.type == BT_REAL
1769 || expr->ts.type == BT_COMPLEX)
1770 && gfc_option.flag_protect_parens)
1772 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1773 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1778 case INTRINSIC_UPLUS:
1779 gfc_conv_expr (se, expr->value.op.op1);
1782 case INTRINSIC_UMINUS:
1783 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1787 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1790 case INTRINSIC_PLUS:
1794 case INTRINSIC_MINUS:
1798 case INTRINSIC_TIMES:
1802 case INTRINSIC_DIVIDE:
1803 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1804 an integer, we must round towards zero, so we use a
1806 if (expr->ts.type == BT_INTEGER)
1807 code = TRUNC_DIV_EXPR;
1812 case INTRINSIC_POWER:
1813 gfc_conv_power_op (se, expr);
1816 case INTRINSIC_CONCAT:
1817 gfc_conv_concat_op (se, expr);
1821 code = TRUTH_ANDIF_EXPR;
1826 code = TRUTH_ORIF_EXPR;
1830 /* EQV and NEQV only work on logicals, but since we represent them
1831 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1833 case INTRINSIC_EQ_OS:
1841 case INTRINSIC_NE_OS:
1842 case INTRINSIC_NEQV:
1849 case INTRINSIC_GT_OS:
1856 case INTRINSIC_GE_OS:
1863 case INTRINSIC_LT_OS:
1870 case INTRINSIC_LE_OS:
1876 case INTRINSIC_USER:
1877 case INTRINSIC_ASSIGN:
1878 /* These should be converted into function calls by the frontend. */
1882 fatal_error ("Unknown intrinsic op");
1886 /* The only exception to this is **, which is handled separately anyway. */
1887 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1889 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1893 gfc_init_se (&lse, se);
1894 gfc_conv_expr (&lse, expr->value.op.op1);
1895 gfc_add_block_to_block (&se->pre, &lse.pre);
1898 gfc_init_se (&rse, se);
1899 gfc_conv_expr (&rse, expr->value.op.op2);
1900 gfc_add_block_to_block (&se->pre, &rse.pre);
1904 gfc_conv_string_parameter (&lse);
1905 gfc_conv_string_parameter (&rse);
1907 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1908 rse.string_length, rse.expr,
1909 expr->value.op.op1->ts.kind,
1911 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1912 gfc_add_block_to_block (&lse.post, &rse.post);
1915 type = gfc_typenode_for_spec (&expr->ts);
1919 /* The result of logical ops is always boolean_type_node. */
1920 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1921 lse.expr, rse.expr);
1922 se->expr = convert (type, tmp);
1925 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1927 /* Add the post blocks. */
1928 gfc_add_block_to_block (&se->post, &rse.post);
1929 gfc_add_block_to_block (&se->post, &lse.post);
1932 /* If a string's length is one, we convert it to a single character. */
1935 gfc_string_to_single_character (tree len, tree str, int kind)
1938 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1939 || !POINTER_TYPE_P (TREE_TYPE (str)))
1942 if (TREE_INT_CST_LOW (len) == 1)
1944 str = fold_convert (gfc_get_pchar_type (kind), str);
1945 return build_fold_indirect_ref_loc (input_location, str);
1949 && TREE_CODE (str) == ADDR_EXPR
1950 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1951 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1952 && array_ref_low_bound (TREE_OPERAND (str, 0))
1953 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1954 && TREE_INT_CST_LOW (len) > 1
1955 && TREE_INT_CST_LOW (len)
1956 == (unsigned HOST_WIDE_INT)
1957 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1959 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1960 ret = build_fold_indirect_ref_loc (input_location, ret);
1961 if (TREE_CODE (ret) == INTEGER_CST)
1963 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1964 int i, length = TREE_STRING_LENGTH (string_cst);
1965 const char *ptr = TREE_STRING_POINTER (string_cst);
1967 for (i = 1; i < length; i++)
1980 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1983 if (sym->backend_decl)
1985 /* This becomes the nominal_type in
1986 function.c:assign_parm_find_data_types. */
1987 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1988 /* This becomes the passed_type in
1989 function.c:assign_parm_find_data_types. C promotes char to
1990 integer for argument passing. */
1991 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1993 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1998 /* If we have a constant character expression, make it into an
2000 if ((*expr)->expr_type == EXPR_CONSTANT)
2005 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
2006 (int)(*expr)->value.character.string[0]);
2007 if ((*expr)->ts.kind != gfc_c_int_kind)
2009 /* The expr needs to be compatible with a C int. If the
2010 conversion fails, then the 2 causes an ICE. */
2011 ts.type = BT_INTEGER;
2012 ts.kind = gfc_c_int_kind;
2013 gfc_convert_type (*expr, &ts, 2);
2016 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
2018 if ((*expr)->ref == NULL)
2020 se->expr = gfc_string_to_single_character
2021 (build_int_cst (integer_type_node, 1),
2022 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2024 ((*expr)->symtree->n.sym)),
2029 gfc_conv_variable (se, *expr);
2030 se->expr = gfc_string_to_single_character
2031 (build_int_cst (integer_type_node, 1),
2032 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2040 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2041 if STR is a string literal, otherwise return -1. */
2044 gfc_optimize_len_trim (tree len, tree str, int kind)
2047 && TREE_CODE (str) == ADDR_EXPR
2048 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2049 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2050 && array_ref_low_bound (TREE_OPERAND (str, 0))
2051 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2052 && TREE_INT_CST_LOW (len) >= 1
2053 && TREE_INT_CST_LOW (len)
2054 == (unsigned HOST_WIDE_INT)
2055 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2057 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
2058 folded = build_fold_indirect_ref_loc (input_location, folded);
2059 if (TREE_CODE (folded) == INTEGER_CST)
2061 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2062 int length = TREE_STRING_LENGTH (string_cst);
2063 const char *ptr = TREE_STRING_POINTER (string_cst);
2065 for (; length > 0; length--)
2066 if (ptr[length - 1] != ' ')
2075 /* Compare two strings. If they are all single characters, the result is the
2076 subtraction of them. Otherwise, we build a library call. */
2079 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
2080 enum tree_code code)
2086 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
2087 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
2089 sc1 = gfc_string_to_single_character (len1, str1, kind);
2090 sc2 = gfc_string_to_single_character (len2, str2, kind);
2092 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
2094 /* Deal with single character specially. */
2095 sc1 = fold_convert (integer_type_node, sc1);
2096 sc2 = fold_convert (integer_type_node, sc2);
2097 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
2101 if ((code == EQ_EXPR || code == NE_EXPR)
2103 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
2105 /* If one string is a string literal with LEN_TRIM longer
2106 than the length of the second string, the strings
2108 int len = gfc_optimize_len_trim (len1, str1, kind);
2109 if (len > 0 && compare_tree_int (len2, len) < 0)
2110 return integer_one_node;
2111 len = gfc_optimize_len_trim (len2, str2, kind);
2112 if (len > 0 && compare_tree_int (len1, len) < 0)
2113 return integer_one_node;
2116 /* Build a call for the comparison. */
2118 fndecl = gfor_fndecl_compare_string;
2120 fndecl = gfor_fndecl_compare_string_char4;
2124 return build_call_expr_loc (input_location, fndecl, 4,
2125 len1, str1, len2, str2);
2129 /* Return the backend_decl for a procedure pointer component. */
2132 get_proc_ptr_comp (gfc_expr *e)
2138 gfc_init_se (&comp_se, NULL);
2139 e2 = gfc_copy_expr (e);
2140 /* We have to restore the expr type later so that gfc_free_expr frees
2141 the exact same thing that was allocated.
2142 TODO: This is ugly. */
2143 old_type = e2->expr_type;
2144 e2->expr_type = EXPR_VARIABLE;
2145 gfc_conv_expr (&comp_se, e2);
2146 e2->expr_type = old_type;
2148 return build_fold_addr_expr_loc (input_location, comp_se.expr);
2152 /* Convert a typebound function reference from a class object. */
2154 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
2159 if (TREE_CODE (base_object) != VAR_DECL)
2161 var = gfc_create_var (TREE_TYPE (base_object), NULL);
2162 gfc_add_modify (&se->pre, var, base_object);
2164 se->expr = gfc_class_vptr_get (base_object);
2165 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2167 while (ref && ref->next)
2169 gcc_assert (ref && ref->type == REF_COMPONENT);
2170 if (ref->u.c.sym->attr.extension)
2171 conv_parent_component_references (se, ref);
2172 gfc_conv_component_ref (se, ref);
2173 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
2178 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
2182 if (gfc_is_proc_ptr_comp (expr, NULL))
2183 tmp = get_proc_ptr_comp (expr);
2184 else if (sym->attr.dummy)
2186 tmp = gfc_get_symbol_decl (sym);
2187 if (sym->attr.proc_pointer)
2188 tmp = build_fold_indirect_ref_loc (input_location,
2190 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
2191 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
2195 if (!sym->backend_decl)
2196 sym->backend_decl = gfc_get_extern_function_decl (sym);
2198 tmp = sym->backend_decl;
2200 if (sym->attr.cray_pointee)
2202 /* TODO - make the cray pointee a pointer to a procedure,
2203 assign the pointer to it and use it for the call. This
2205 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
2206 gfc_get_symbol_decl (sym->cp_pointer));
2207 tmp = gfc_evaluate_now (tmp, &se->pre);
2210 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
2212 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
2213 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2220 /* Initialize MAPPING. */
2223 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
2225 mapping->syms = NULL;
2226 mapping->charlens = NULL;
2230 /* Free all memory held by MAPPING (but not MAPPING itself). */
2233 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
2235 gfc_interface_sym_mapping *sym;
2236 gfc_interface_sym_mapping *nextsym;
2238 gfc_charlen *nextcl;
2240 for (sym = mapping->syms; sym; sym = nextsym)
2242 nextsym = sym->next;
2243 sym->new_sym->n.sym->formal = NULL;
2244 gfc_free_symbol (sym->new_sym->n.sym);
2245 gfc_free_expr (sym->expr);
2246 free (sym->new_sym);
2249 for (cl = mapping->charlens; cl; cl = nextcl)
2252 gfc_free_expr (cl->length);
2258 /* Return a copy of gfc_charlen CL. Add the returned structure to
2259 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2261 static gfc_charlen *
2262 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
2265 gfc_charlen *new_charlen;
2267 new_charlen = gfc_get_charlen ();
2268 new_charlen->next = mapping->charlens;
2269 new_charlen->length = gfc_copy_expr (cl->length);
2271 mapping->charlens = new_charlen;
2276 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2277 array variable that can be used as the actual argument for dummy
2278 argument SYM. Add any initialization code to BLOCK. PACKED is as
2279 for gfc_get_nodesc_array_type and DATA points to the first element
2280 in the passed array. */
2283 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
2284 gfc_packed packed, tree data)
2289 type = gfc_typenode_for_spec (&sym->ts);
2290 type = gfc_get_nodesc_array_type (type, sym->as, packed,
2291 !sym->attr.target && !sym->attr.pointer
2292 && !sym->attr.proc_pointer);
2294 var = gfc_create_var (type, "ifm");
2295 gfc_add_modify (block, var, fold_convert (type, data));
2301 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2302 and offset of descriptorless array type TYPE given that it has the same
2303 size as DESC. Add any set-up code to BLOCK. */
2306 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
2313 offset = gfc_index_zero_node;
2314 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
2316 dim = gfc_rank_cst[n];
2317 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
2318 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
2320 GFC_TYPE_ARRAY_LBOUND (type, n)
2321 = gfc_conv_descriptor_lbound_get (desc, dim);
2322 GFC_TYPE_ARRAY_UBOUND (type, n)
2323 = gfc_conv_descriptor_ubound_get (desc, dim);
2325 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
2327 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2328 gfc_array_index_type,
2329 gfc_conv_descriptor_ubound_get (desc, dim),
2330 gfc_conv_descriptor_lbound_get (desc, dim));
2331 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2332 gfc_array_index_type,
2333 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
2334 tmp = gfc_evaluate_now (tmp, block);
2335 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
2337 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2338 GFC_TYPE_ARRAY_LBOUND (type, n),
2339 GFC_TYPE_ARRAY_STRIDE (type, n));
2340 offset = fold_build2_loc (input_location, MINUS_EXPR,
2341 gfc_array_index_type, offset, tmp);
2343 offset = gfc_evaluate_now (offset, block);
2344 GFC_TYPE_ARRAY_OFFSET (type) = offset;
2348 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2349 in SE. The caller may still use se->expr and se->string_length after
2350 calling this function. */
2353 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
2354 gfc_symbol * sym, gfc_se * se,
2357 gfc_interface_sym_mapping *sm;
2361 gfc_symbol *new_sym;
2363 gfc_symtree *new_symtree;
2365 /* Create a new symbol to represent the actual argument. */
2366 new_sym = gfc_new_symbol (sym->name, NULL);
2367 new_sym->ts = sym->ts;
2368 new_sym->as = gfc_copy_array_spec (sym->as);
2369 new_sym->attr.referenced = 1;
2370 new_sym->attr.dimension = sym->attr.dimension;
2371 new_sym->attr.contiguous = sym->attr.contiguous;
2372 new_sym->attr.codimension = sym->attr.codimension;
2373 new_sym->attr.pointer = sym->attr.pointer;
2374 new_sym->attr.allocatable = sym->attr.allocatable;
2375 new_sym->attr.flavor = sym->attr.flavor;
2376 new_sym->attr.function = sym->attr.function;
2378 /* Ensure that the interface is available and that
2379 descriptors are passed for array actual arguments. */
2380 if (sym->attr.flavor == FL_PROCEDURE)
2382 new_sym->formal = expr->symtree->n.sym->formal;
2383 new_sym->attr.always_explicit
2384 = expr->symtree->n.sym->attr.always_explicit;
2387 /* Create a fake symtree for it. */
2389 new_symtree = gfc_new_symtree (&root, sym->name);
2390 new_symtree->n.sym = new_sym;
2391 gcc_assert (new_symtree == root);
2393 /* Create a dummy->actual mapping. */
2394 sm = XCNEW (gfc_interface_sym_mapping);
2395 sm->next = mapping->syms;
2397 sm->new_sym = new_symtree;
2398 sm->expr = gfc_copy_expr (expr);
2401 /* Stabilize the argument's value. */
2402 if (!sym->attr.function && se)
2403 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2405 if (sym->ts.type == BT_CHARACTER)
2407 /* Create a copy of the dummy argument's length. */
2408 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
2409 sm->expr->ts.u.cl = new_sym->ts.u.cl;
2411 /* If the length is specified as "*", record the length that
2412 the caller is passing. We should use the callee's length
2413 in all other cases. */
2414 if (!new_sym->ts.u.cl->length && se)
2416 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
2417 new_sym->ts.u.cl->backend_decl = se->string_length;
2424 /* Use the passed value as-is if the argument is a function. */
2425 if (sym->attr.flavor == FL_PROCEDURE)
2428 /* If the argument is either a string or a pointer to a string,
2429 convert it to a boundless character type. */
2430 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
2432 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
2433 tmp = build_pointer_type (tmp);
2434 if (sym->attr.pointer)
2435 value = build_fold_indirect_ref_loc (input_location,
2439 value = fold_convert (tmp, value);
2442 /* If the argument is a scalar, a pointer to an array or an allocatable,
2444 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
2445 value = build_fold_indirect_ref_loc (input_location,
2448 /* For character(*), use the actual argument's descriptor. */
2449 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
2450 value = build_fold_indirect_ref_loc (input_location,
2453 /* If the argument is an array descriptor, use it to determine
2454 information about the actual argument's shape. */
2455 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
2456 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
2458 /* Get the actual argument's descriptor. */
2459 desc = build_fold_indirect_ref_loc (input_location,
2462 /* Create the replacement variable. */
2463 tmp = gfc_conv_descriptor_data_get (desc);
2464 value = gfc_get_interface_mapping_array (&se->pre, sym,
2467 /* Use DESC to work out the upper bounds, strides and offset. */
2468 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
2471 /* Otherwise we have a packed array. */
2472 value = gfc_get_interface_mapping_array (&se->pre, sym,
2473 PACKED_FULL, se->expr);
2475 new_sym->backend_decl = value;
2479 /* Called once all dummy argument mappings have been added to MAPPING,
2480 but before the mapping is used to evaluate expressions. Pre-evaluate
2481 the length of each argument, adding any initialization code to PRE and
2482 any finalization code to POST. */
2485 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2486 stmtblock_t * pre, stmtblock_t * post)
2488 gfc_interface_sym_mapping *sym;
2492 for (sym = mapping->syms; sym; sym = sym->next)
2493 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2494 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2496 expr = sym->new_sym->n.sym->ts.u.cl->length;
2497 gfc_apply_interface_mapping_to_expr (mapping, expr);
2498 gfc_init_se (&se, NULL);
2499 gfc_conv_expr (&se, expr);
2500 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2501 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2502 gfc_add_block_to_block (pre, &se.pre);
2503 gfc_add_block_to_block (post, &se.post);
2505 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2510 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2514 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2515 gfc_constructor_base base)
2518 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2520 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2523 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2524 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2525 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2531 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2535 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2540 for (; ref; ref = ref->next)
2544 for (n = 0; n < ref->u.ar.dimen; n++)
2546 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2547 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2548 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2550 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2557 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2558 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2564 /* Convert intrinsic function calls into result expressions. */
2567 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2575 arg1 = expr->value.function.actual->expr;
2576 if (expr->value.function.actual->next)
2577 arg2 = expr->value.function.actual->next->expr;
2581 sym = arg1->symtree->n.sym;
2583 if (sym->attr.dummy)
2588 switch (expr->value.function.isym->id)
2591 /* TODO figure out why this condition is necessary. */
2592 if (sym->attr.function
2593 && (arg1->ts.u.cl->length == NULL
2594 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2595 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2598 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2602 if (!sym->as || sym->as->rank == 0)
2605 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2607 dup = mpz_get_si (arg2->value.integer);
2612 dup = sym->as->rank;
2616 for (; d < dup; d++)
2620 if (!sym->as->upper[d] || !sym->as->lower[d])
2622 gfc_free_expr (new_expr);
2626 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2627 gfc_get_int_expr (gfc_default_integer_kind,
2629 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2631 new_expr = gfc_multiply (new_expr, tmp);
2637 case GFC_ISYM_LBOUND:
2638 case GFC_ISYM_UBOUND:
2639 /* TODO These implementations of lbound and ubound do not limit if
2640 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2642 if (!sym->as || sym->as->rank == 0)
2645 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2646 d = mpz_get_si (arg2->value.integer) - 1;
2648 /* TODO: If the need arises, this could produce an array of
2652 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2654 if (sym->as->lower[d])
2655 new_expr = gfc_copy_expr (sym->as->lower[d]);
2659 if (sym->as->upper[d])
2660 new_expr = gfc_copy_expr (sym->as->upper[d]);
2668 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2672 gfc_replace_expr (expr, new_expr);
2678 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2679 gfc_interface_mapping * mapping)
2681 gfc_formal_arglist *f;
2682 gfc_actual_arglist *actual;
2684 actual = expr->value.function.actual;
2685 f = map_expr->symtree->n.sym->formal;
2687 for (; f && actual; f = f->next, actual = actual->next)
2692 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2695 if (map_expr->symtree->n.sym->attr.dimension)
2700 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2702 for (d = 0; d < as->rank; d++)
2704 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2705 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2708 expr->value.function.esym->as = as;
2711 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2713 expr->value.function.esym->ts.u.cl->length
2714 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2716 gfc_apply_interface_mapping_to_expr (mapping,
2717 expr->value.function.esym->ts.u.cl->length);
2722 /* EXPR is a copy of an expression that appeared in the interface
2723 associated with MAPPING. Walk it recursively looking for references to
2724 dummy arguments that MAPPING maps to actual arguments. Replace each such
2725 reference with a reference to the associated actual argument. */
2728 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2731 gfc_interface_sym_mapping *sym;
2732 gfc_actual_arglist *actual;
2737 /* Copying an expression does not copy its length, so do that here. */
2738 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2740 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2741 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2744 /* Apply the mapping to any references. */
2745 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2747 /* ...and to the expression's symbol, if it has one. */
2748 /* TODO Find out why the condition on expr->symtree had to be moved into
2749 the loop rather than being outside it, as originally. */
2750 for (sym = mapping->syms; sym; sym = sym->next)
2751 if (expr->symtree && sym->old == expr->symtree->n.sym)
2753 if (sym->new_sym->n.sym->backend_decl)
2754 expr->symtree = sym->new_sym;
2756 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2757 /* Replace base type for polymorphic arguments. */
2758 if (expr->ref && expr->ref->type == REF_COMPONENT
2759 && sym->expr && sym->expr->ts.type == BT_CLASS)
2760 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2763 /* ...and to subexpressions in expr->value. */
2764 switch (expr->expr_type)
2769 case EXPR_SUBSTRING:
2773 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2774 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2778 for (actual = expr->value.function.actual; actual; actual = actual->next)
2779 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2781 if (expr->value.function.esym == NULL
2782 && expr->value.function.isym != NULL
2783 && expr->value.function.actual->expr->symtree
2784 && gfc_map_intrinsic_function (expr, mapping))
2787 for (sym = mapping->syms; sym; sym = sym->next)
2788 if (sym->old == expr->value.function.esym)
2790 expr->value.function.esym = sym->new_sym->n.sym;
2791 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2792 expr->value.function.esym->result = sym->new_sym->n.sym;
2797 case EXPR_STRUCTURE:
2798 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2811 /* Evaluate interface expression EXPR using MAPPING. Store the result
2815 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2816 gfc_se * se, gfc_expr * expr)
2818 expr = gfc_copy_expr (expr);
2819 gfc_apply_interface_mapping_to_expr (mapping, expr);
2820 gfc_conv_expr (se, expr);
2821 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2822 gfc_free_expr (expr);
2826 /* Returns a reference to a temporary array into which a component of
2827 an actual argument derived type array is copied and then returned
2828 after the function call. */
2830 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2831 sym_intent intent, bool formal_ptr)
2839 gfc_array_info *info;
2849 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2851 gfc_init_se (&lse, NULL);
2852 gfc_init_se (&rse, NULL);
2854 /* Walk the argument expression. */
2855 rss = gfc_walk_expr (expr);
2857 gcc_assert (rss != gfc_ss_terminator);
2859 /* Initialize the scalarizer. */
2860 gfc_init_loopinfo (&loop);
2861 gfc_add_ss_to_loop (&loop, rss);
2863 /* Calculate the bounds of the scalarization. */
2864 gfc_conv_ss_startstride (&loop);
2866 /* Build an ss for the temporary. */
2867 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2868 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2870 base_type = gfc_typenode_for_spec (&expr->ts);
2871 if (GFC_ARRAY_TYPE_P (base_type)
2872 || GFC_DESCRIPTOR_TYPE_P (base_type))
2873 base_type = gfc_get_element_type (base_type);
2875 if (expr->ts.type == BT_CLASS)
2876 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
2878 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
2879 ? expr->ts.u.cl->backend_decl
2883 parmse->string_length = loop.temp_ss->info->string_length;
2885 /* Associate the SS with the loop. */
2886 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2888 /* Setup the scalarizing loops. */
2889 gfc_conv_loop_setup (&loop, &expr->where);
2891 /* Pass the temporary descriptor back to the caller. */
2892 info = &loop.temp_ss->info->data.array;
2893 parmse->expr = info->descriptor;
2895 /* Setup the gfc_se structures. */
2896 gfc_copy_loopinfo_to_se (&lse, &loop);
2897 gfc_copy_loopinfo_to_se (&rse, &loop);
2900 lse.ss = loop.temp_ss;
2901 gfc_mark_ss_chain_used (rss, 1);
2902 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2904 /* Start the scalarized loop body. */
2905 gfc_start_scalarized_body (&loop, &body);
2907 /* Translate the expression. */
2908 gfc_conv_expr (&rse, expr);
2910 gfc_conv_tmp_array_ref (&lse);
2912 if (intent != INTENT_OUT)
2914 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2915 gfc_add_expr_to_block (&body, tmp);
2916 gcc_assert (rse.ss == gfc_ss_terminator);
2917 gfc_trans_scalarizing_loops (&loop, &body);
2921 /* Make sure that the temporary declaration survives by merging
2922 all the loop declarations into the current context. */
2923 for (n = 0; n < loop.dimen; n++)
2925 gfc_merge_block_scope (&body);
2926 body = loop.code[loop.order[n]];
2928 gfc_merge_block_scope (&body);
2931 /* Add the post block after the second loop, so that any
2932 freeing of allocated memory is done at the right time. */
2933 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2935 /**********Copy the temporary back again.*********/
2937 gfc_init_se (&lse, NULL);
2938 gfc_init_se (&rse, NULL);
2940 /* Walk the argument expression. */
2941 lss = gfc_walk_expr (expr);
2942 rse.ss = loop.temp_ss;
2945 /* Initialize the scalarizer. */
2946 gfc_init_loopinfo (&loop2);
2947 gfc_add_ss_to_loop (&loop2, lss);
2949 /* Calculate the bounds of the scalarization. */
2950 gfc_conv_ss_startstride (&loop2);
2952 /* Setup the scalarizing loops. */
2953 gfc_conv_loop_setup (&loop2, &expr->where);
2955 gfc_copy_loopinfo_to_se (&lse, &loop2);
2956 gfc_copy_loopinfo_to_se (&rse, &loop2);
2958 gfc_mark_ss_chain_used (lss, 1);
2959 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2961 /* Declare the variable to hold the temporary offset and start the
2962 scalarized loop body. */
2963 offset = gfc_create_var (gfc_array_index_type, NULL);
2964 gfc_start_scalarized_body (&loop2, &body);
2966 /* Build the offsets for the temporary from the loop variables. The
2967 temporary array has lbounds of zero and strides of one in all
2968 dimensions, so this is very simple. The offset is only computed
2969 outside the innermost loop, so the overall transfer could be
2970 optimized further. */
2971 info = &rse.ss->info->data.array;
2972 dimen = rse.ss->dimen;
2974 tmp_index = gfc_index_zero_node;
2975 for (n = dimen - 1; n > 0; n--)
2978 tmp = rse.loop->loopvar[n];
2979 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2980 tmp, rse.loop->from[n]);
2981 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2984 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2985 gfc_array_index_type,
2986 rse.loop->to[n-1], rse.loop->from[n-1]);
2987 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2988 gfc_array_index_type,
2989 tmp_str, gfc_index_one_node);
2991 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2992 gfc_array_index_type, tmp, tmp_str);
2995 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2996 gfc_array_index_type,
2997 tmp_index, rse.loop->from[0]);
2998 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
3000 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
3001 gfc_array_index_type,
3002 rse.loop->loopvar[0], offset);
3004 /* Now use the offset for the reference. */
3005 tmp = build_fold_indirect_ref_loc (input_location,
3007 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
3009 if (expr->ts.type == BT_CHARACTER)
3010 rse.string_length = expr->ts.u.cl->backend_decl;
3012 gfc_conv_expr (&lse, expr);
3014 gcc_assert (lse.ss == gfc_ss_terminator);
3016 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
3017 gfc_add_expr_to_block (&body, tmp);
3019 /* Generate the copying loops. */
3020 gfc_trans_scalarizing_loops (&loop2, &body);
3022 /* Wrap the whole thing up by adding the second loop to the post-block
3023 and following it by the post-block of the first loop. In this way,
3024 if the temporary needs freeing, it is done after use! */
3025 if (intent != INTENT_IN)
3027 gfc_add_block_to_block (&parmse->post, &loop2.pre);
3028 gfc_add_block_to_block (&parmse->post, &loop2.post);
3031 gfc_add_block_to_block (&parmse->post, &loop.post);
3033 gfc_cleanup_loop (&loop);
3034 gfc_cleanup_loop (&loop2);
3036 /* Pass the string length to the argument expression. */
3037 if (expr->ts.type == BT_CHARACTER)
3038 parmse->string_length = expr->ts.u.cl->backend_decl;
3040 /* Determine the offset for pointer formal arguments and set the
3044 size = gfc_index_one_node;
3045 offset = gfc_index_zero_node;
3046 for (n = 0; n < dimen; n++)
3048 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
3050 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3051 gfc_array_index_type, tmp,
3052 gfc_index_one_node);
3053 gfc_conv_descriptor_ubound_set (&parmse->pre,
3057 gfc_conv_descriptor_lbound_set (&parmse->pre,
3060 gfc_index_one_node);
3061 size = gfc_evaluate_now (size, &parmse->pre);
3062 offset = fold_build2_loc (input_location, MINUS_EXPR,
3063 gfc_array_index_type,
3065 offset = gfc_evaluate_now (offset, &parmse->pre);
3066 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3067 gfc_array_index_type,
3068 rse.loop->to[n], rse.loop->from[n]);
3069 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3070 gfc_array_index_type,
3071 tmp, gfc_index_one_node);
3072 size = fold_build2_loc (input_location, MULT_EXPR,
3073 gfc_array_index_type, size, tmp);
3076 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
3080 /* We want either the address for the data or the address of the descriptor,
3081 depending on the mode of passing array arguments. */
3083 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
3085 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
3091 /* Generate the code for argument list functions. */
3094 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
3096 /* Pass by value for g77 %VAL(arg), pass the address
3097 indirectly for %LOC, else by reference. Thus %REF
3098 is a "do-nothing" and %LOC is the same as an F95
3100 if (strncmp (name, "%VAL", 4) == 0)
3101 gfc_conv_expr (se, expr);
3102 else if (strncmp (name, "%LOC", 4) == 0)
3104 gfc_conv_expr_reference (se, expr);
3105 se->expr = gfc_build_addr_expr (NULL, se->expr);
3107 else if (strncmp (name, "%REF", 4) == 0)
3108 gfc_conv_expr_reference (se, expr);
3110 gfc_error ("Unknown argument list function at %L", &expr->where);
3114 /* The following routine generates code for the intrinsic
3115 procedures from the ISO_C_BINDING module:
3117 * C_FUNLOC (function)
3118 * C_F_POINTER (subroutine)
3119 * C_F_PROCPOINTER (subroutine)
3120 * C_ASSOCIATED (function)
3121 One exception which is not handled here is C_F_POINTER with non-scalar
3122 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3125 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
3126 gfc_actual_arglist * arg)
3131 if (sym->intmod_sym_id == ISOCBINDING_LOC)
3133 if (arg->expr->rank == 0)
3134 gfc_conv_expr_reference (se, arg->expr);
3138 /* This is really the actual arg because no formal arglist is
3139 created for C_LOC. */
3140 fsym = arg->expr->symtree->n.sym;
3142 /* We should want it to do g77 calling convention. */
3144 && !(fsym->attr.pointer || fsym->attr.allocatable)
3145 && fsym->as->type != AS_ASSUMED_SHAPE;
3146 f = f || !sym->attr.always_explicit;
3148 argss = gfc_walk_expr (arg->expr);
3149 gfc_conv_array_parameter (se, arg->expr, argss, f,
3153 /* TODO -- the following two lines shouldn't be necessary, but if
3154 they're removed, a bug is exposed later in the code path.
3155 This workaround was thus introduced, but will have to be
3156 removed; please see PR 35150 for details about the issue. */
3157 se->expr = convert (pvoid_type_node, se->expr);
3158 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3162 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
3164 arg->expr->ts.type = sym->ts.u.derived->ts.type;
3165 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
3166 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
3167 gfc_conv_expr_reference (se, arg->expr);
3171 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
3172 && arg->next->expr->rank == 0)
3173 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3175 /* Convert c_f_pointer if fptr is a scalar
3176 and convert c_f_procpointer. */
3180 gfc_init_se (&cptrse, NULL);
3181 gfc_conv_expr (&cptrse, arg->expr);
3182 gfc_add_block_to_block (&se->pre, &cptrse.pre);
3183 gfc_add_block_to_block (&se->post, &cptrse.post);
3185 gfc_init_se (&fptrse, NULL);
3186 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
3187 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
3188 fptrse.want_pointer = 1;
3190 gfc_conv_expr (&fptrse, arg->next->expr);
3191 gfc_add_block_to_block (&se->pre, &fptrse.pre);
3192 gfc_add_block_to_block (&se->post, &fptrse.post);
3194 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
3195 && arg->next->expr->symtree->n.sym->attr.dummy)
3196 fptrse.expr = build_fold_indirect_ref_loc (input_location,
3199 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
3200 TREE_TYPE (fptrse.expr),
3202 fold_convert (TREE_TYPE (fptrse.expr),
3207 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3212 /* Build the addr_expr for the first argument. The argument is
3213 already an *address* so we don't need to set want_pointer in
3215 gfc_init_se (&arg1se, NULL);
3216 gfc_conv_expr (&arg1se, arg->expr);
3217 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3218 gfc_add_block_to_block (&se->post, &arg1se.post);
3220 /* See if we were given two arguments. */
3221 if (arg->next == NULL)
3222 /* Only given one arg so generate a null and do a
3223 not-equal comparison against the first arg. */
3224 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3226 fold_convert (TREE_TYPE (arg1se.expr),
3227 null_pointer_node));
3233 /* Given two arguments so build the arg2se from second arg. */
3234 gfc_init_se (&arg2se, NULL);
3235 gfc_conv_expr (&arg2se, arg->next->expr);
3236 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3237 gfc_add_block_to_block (&se->post, &arg2se.post);
3239 /* Generate test to compare that the two args are equal. */
3240 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3241 arg1se.expr, arg2se.expr);
3242 /* Generate test to ensure that the first arg is not null. */
3243 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
3245 arg1se.expr, null_pointer_node);
3247 /* Finally, the generated test must check that both arg1 is not
3248 NULL and that it is equal to the second arg. */
3249 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3251 not_null_expr, eq_expr);
3257 /* Nothing was done. */
3262 /* Generate code for a procedure call. Note can return se->post != NULL.
3263 If se->direct_byref is set then se->expr contains the return parameter.
3264 Return nonzero, if the call has alternate specifiers.
3265 'expr' is only needed for procedure pointer components. */
3268 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
3269 gfc_actual_arglist * args, gfc_expr * expr,
3270 VEC(tree,gc) *append_args)
3272 gfc_interface_mapping mapping;
3273 VEC(tree,gc) *arglist;
3274 VEC(tree,gc) *retargs;
3279 gfc_array_info *info;
3286 VEC(tree,gc) *stringargs;
3288 gfc_formal_arglist *formal;
3289 gfc_actual_arglist *arg;
3290 int has_alternate_specifier = 0;
3291 bool need_interface_mapping;
3298 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
3299 gfc_component *comp = NULL;
3309 if (sym->from_intmod == INTMOD_ISO_C_BINDING
3310 && conv_isocbinding_procedure (se, sym, args))
3313 gfc_is_proc_ptr_comp (expr, &comp);
3317 if (!sym->attr.elemental && !(comp && comp->attr.elemental))
3319 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
3320 if (se->ss->info->useflags)
3322 gcc_assert ((!comp && gfc_return_by_reference (sym)
3323 && sym->result->attr.dimension)
3324 || (comp && comp->attr.dimension));
3325 gcc_assert (se->loop != NULL);
3327 /* Access the previously obtained result. */
3328 gfc_conv_tmp_array_ref (se);
3332 info = &se->ss->info->data.array;
3337 gfc_init_block (&post);
3338 gfc_init_interface_mapping (&mapping);
3341 formal = sym->formal;
3342 need_interface_mapping = sym->attr.dimension ||
3343 (sym->ts.type == BT_CHARACTER
3344 && sym->ts.u.cl->length
3345 && sym->ts.u.cl->length->expr_type
3350 formal = comp->formal;
3351 need_interface_mapping = comp->attr.dimension ||
3352 (comp->ts.type == BT_CHARACTER
3353 && comp->ts.u.cl->length
3354 && comp->ts.u.cl->length->expr_type
3358 base_object = NULL_TREE;
3360 /* Evaluate the arguments. */
3361 for (arg = args; arg != NULL;
3362 arg = arg->next, formal = formal ? formal->next : NULL)
3365 fsym = formal ? formal->sym : NULL;
3366 parm_kind = MISSING;
3368 /* Class array expressions are sometimes coming completely unadorned
3369 with either arrayspec or _data component. Correct that here.
3370 OOP-TODO: Move this to the frontend. */
3371 if (e && e->expr_type == EXPR_VARIABLE
3373 && e->ts.type == BT_CLASS
3374 && CLASS_DATA (e)->attr.dimension)
3376 gfc_typespec temp_ts = e->ts;
3377 gfc_add_class_array_ref (e);
3383 if (se->ignore_optional)
3385 /* Some intrinsics have already been resolved to the correct
3389 else if (arg->label)
3391 has_alternate_specifier = 1;
3396 /* Pass a NULL pointer for an absent arg. */
3397 gfc_init_se (&parmse, NULL);
3398 parmse.expr = null_pointer_node;
3399 if (arg->missing_arg_type == BT_CHARACTER)
3400 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
3403 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
3405 /* Pass a NULL pointer to denote an absent arg. */
3406 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
3407 gfc_init_se (&parmse, NULL);
3408 parmse.expr = null_pointer_node;
3409 if (arg->missing_arg_type == BT_CHARACTER)
3410 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
3412 else if (fsym && fsym->ts.type == BT_CLASS
3413 && e->ts.type == BT_DERIVED)
3415 /* The derived type needs to be converted to a temporary
3417 gfc_init_se (&parmse, se);
3418 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
3420 else if (se->ss && se->ss->info->useflags)
3422 /* An elemental function inside a scalarized loop. */
3423 gfc_init_se (&parmse, se);
3424 parm_kind = ELEMENTAL;
3426 if (se->ss->dimen > 0
3427 && se->ss->info->data.array.ref == NULL)
3429 gfc_conv_tmp_array_ref (&parmse);
3430 if (e->ts.type == BT_CHARACTER)
3431 gfc_conv_string_parameter (&parmse);
3433 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3436 gfc_conv_expr_reference (&parmse, e);
3438 /* The scalarizer does not repackage the reference to a class
3439 array - instead it returns a pointer to the data element. */
3440 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
3441 gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
3445 /* A scalar or transformational function. */
3446 gfc_init_se (&parmse, NULL);
3447 argss = gfc_walk_expr (e);
3449 if (argss == gfc_ss_terminator)
3451 if (e->expr_type == EXPR_VARIABLE
3452 && e->symtree->n.sym->attr.cray_pointee
3453 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3455 /* The Cray pointer needs to be converted to a pointer to
3456 a type given by the expression. */
3457 gfc_conv_expr (&parmse, e);
3458 type = build_pointer_type (TREE_TYPE (parmse.expr));
3459 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3460 parmse.expr = convert (type, tmp);
3462 else if (fsym && fsym->attr.value)
3464 if (fsym->ts.type == BT_CHARACTER
3465 && fsym->ts.is_c_interop
3466 && fsym->ns->proc_name != NULL
3467 && fsym->ns->proc_name->attr.is_bind_c)
3470 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3471 if (parmse.expr == NULL)
3472 gfc_conv_expr (&parmse, e);
3475 gfc_conv_expr (&parmse, e);
3477 else if (arg->name && arg->name[0] == '%')
3478 /* Argument list functions %VAL, %LOC and %REF are signalled
3479 through arg->name. */
3480 conv_arglist_function (&parmse, arg->expr, arg->name);
3481 else if ((e->expr_type == EXPR_FUNCTION)
3482 && ((e->value.function.esym
3483 && e->value.function.esym->result->attr.pointer)
3484 || (!e->value.function.esym
3485 && e->symtree->n.sym->attr.pointer))
3486 && fsym && fsym->attr.target)
3488 gfc_conv_expr (&parmse, e);
3489 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3491 else if (e->expr_type == EXPR_FUNCTION
3492 && e->symtree->n.sym->result
3493 && e->symtree->n.sym->result != e->symtree->n.sym
3494 && e->symtree->n.sym->result->attr.proc_pointer)
3496 /* Functions returning procedure pointers. */
3497 gfc_conv_expr (&parmse, e);
3498 if (fsym && fsym->attr.proc_pointer)
3499 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3503 gfc_conv_expr_reference (&parmse, e);
3505 /* Catch base objects that are not variables. */
3506 if (e->ts.type == BT_CLASS
3507 && e->expr_type != EXPR_VARIABLE
3508 && expr && e == expr->base_expr)
3509 base_object = build_fold_indirect_ref_loc (input_location,
3512 /* A class array element needs converting back to be a
3513 class object, if the formal argument is a class object. */
3514 if (fsym && fsym->ts.type == BT_CLASS
3515 && e->ts.type == BT_CLASS
3516 && CLASS_DATA (e)->attr.dimension)
3517 gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
3519 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3520 allocated on entry, it must be deallocated. */
3521 if (fsym && fsym->attr.allocatable
3522 && fsym->attr.intent == INTENT_OUT)
3526 gfc_init_block (&block);
3527 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3529 gfc_add_expr_to_block (&block, tmp);
3530 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3531 void_type_node, parmse.expr,
3533 gfc_add_expr_to_block (&block, tmp);
3535 if (fsym->attr.optional
3536 && e->expr_type == EXPR_VARIABLE
3537 && e->symtree->n.sym->attr.optional)
3539 tmp = fold_build3_loc (input_location, COND_EXPR,
3541 gfc_conv_expr_present (e->symtree->n.sym),
3542 gfc_finish_block (&block),
3543 build_empty_stmt (input_location));
3546 tmp = gfc_finish_block (&block);
3548 gfc_add_expr_to_block (&se->pre, tmp);
3551 if (fsym && e->expr_type != EXPR_NULL
3552 && ((fsym->attr.pointer
3553 && fsym->attr.flavor != FL_PROCEDURE)
3554 || (fsym->attr.proc_pointer
3555 && !(e->expr_type == EXPR_VARIABLE
3556 && e->symtree->n.sym->attr.dummy))
3557 || (fsym->attr.proc_pointer
3558 && e->expr_type == EXPR_VARIABLE
3559 && gfc_is_proc_ptr_comp (e, NULL))
3560 || fsym->attr.allocatable))
3562 /* Scalar pointer dummy args require an extra level of
3563 indirection. The null pointer already contains
3564 this level of indirection. */
3565 parm_kind = SCALAR_POINTER;
3566 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3570 else if (e->ts.type == BT_CLASS
3571 && fsym && fsym->ts.type == BT_CLASS
3572 && CLASS_DATA (fsym)->attr.dimension)
3574 /* Pass a class array. */
3575 gfc_init_se (&parmse, se);
3576 gfc_conv_expr_descriptor (&parmse, e, argss);
3577 /* The conversion does not repackage the reference to a class
3578 array - _data descriptor. */
3579 gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
3583 /* If the procedure requires an explicit interface, the actual
3584 argument is passed according to the corresponding formal
3585 argument. If the corresponding formal argument is a POINTER,
3586 ALLOCATABLE or assumed shape, we do not use g77's calling
3587 convention, and pass the address of the array descriptor
3588 instead. Otherwise we use g77's calling convention. */
3591 && !(fsym->attr.pointer || fsym->attr.allocatable)
3592 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3594 f = f || !comp->attr.always_explicit;
3596 f = f || !sym->attr.always_explicit;
3598 /* If the argument is a function call that may not create
3599 a temporary for the result, we have to check that we
3600 can do it, i.e. that there is no alias between this
3601 argument and another one. */
3602 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3608 intent = fsym->attr.intent;
3610 intent = INTENT_UNKNOWN;
3612 if (gfc_check_fncall_dependency (e, intent, sym, args,
3614 parmse.force_tmp = 1;
3616 iarg = e->value.function.actual->expr;
3618 /* Temporary needed if aliasing due to host association. */
3619 if (sym->attr.contained
3621 && !sym->attr.implicit_pure
3622 && !sym->attr.use_assoc
3623 && iarg->expr_type == EXPR_VARIABLE
3624 && sym->ns == iarg->symtree->n.sym->ns)
3625 parmse.force_tmp = 1;
3627 /* Ditto within module. */
3628 if (sym->attr.use_assoc
3630 && !sym->attr.implicit_pure
3631 && iarg->expr_type == EXPR_VARIABLE
3632 && sym->module == iarg->symtree->n.sym->module)
3633 parmse.force_tmp = 1;
3636 if (e->expr_type == EXPR_VARIABLE
3637 && is_subref_array (e))
3638 /* The actual argument is a component reference to an
3639 array of derived types. In this case, the argument
3640 is converted to a temporary, which is passed and then
3641 written back after the procedure call. */
3642 gfc_conv_subref_array_arg (&parmse, e, f,
3643 fsym ? fsym->attr.intent : INTENT_INOUT,
3644 fsym && fsym->attr.pointer);
3645 else if (gfc_is_class_array_ref (e, NULL)
3646 && fsym && fsym->ts.type == BT_DERIVED)
3647 /* The actual argument is a component reference to an
3648 array of derived types. In this case, the argument
3649 is converted to a temporary, which is passed and then
3650 written back after the procedure call.
3651 OOP-TODO: Insert code so that if the dynamic type is
3652 the same as the declared type, copy-in/copy-out does
3654 gfc_conv_subref_array_arg (&parmse, e, f,
3655 fsym ? fsym->attr.intent : INTENT_INOUT,
3656 fsym && fsym->attr.pointer);
3658 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3661 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3662 allocated on entry, it must be deallocated. */
3663 if (fsym && fsym->attr.allocatable
3664 && fsym->attr.intent == INTENT_OUT)
3666 tmp = build_fold_indirect_ref_loc (input_location,
3668 tmp = gfc_trans_dealloc_allocated (tmp);
3669 if (fsym->attr.optional
3670 && e->expr_type == EXPR_VARIABLE
3671 && e->symtree->n.sym->attr.optional)
3672 tmp = fold_build3_loc (input_location, COND_EXPR,
3674 gfc_conv_expr_present (e->symtree->n.sym),
3675 tmp, build_empty_stmt (input_location));
3676 gfc_add_expr_to_block (&se->pre, tmp);
3681 /* The case with fsym->attr.optional is that of a user subroutine
3682 with an interface indicating an optional argument. When we call
3683 an intrinsic subroutine, however, fsym is NULL, but we might still
3684 have an optional argument, so we proceed to the substitution
3686 if (e && (fsym == NULL || fsym->attr.optional))
3688 /* If an optional argument is itself an optional dummy argument,
3689 check its presence and substitute a null if absent. This is
3690 only needed when passing an array to an elemental procedure
3691 as then array elements are accessed - or no NULL pointer is
3692 allowed and a "1" or "0" should be passed if not present.
3693 When passing a non-array-descriptor full array to a
3694 non-array-descriptor dummy, no check is needed. For
3695 array-descriptor actual to array-descriptor dummy, see
3696 PR 41911 for why a check has to be inserted.
3697 fsym == NULL is checked as intrinsics required the descriptor
3698 but do not always set fsym. */
3699 if (e->expr_type == EXPR_VARIABLE
3700 && e->symtree->n.sym->attr.optional
3701 && ((e->rank > 0 && sym->attr.elemental)
3702 || e->representation.length || e->ts.type == BT_CHARACTER
3706 && (fsym->as->type == AS_ASSUMED_SHAPE
3707 || fsym->as->type == AS_DEFERRED))))))
3708 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3709 e->representation.length);
3714 /* Obtain the character length of an assumed character length
3715 length procedure from the typespec. */
3716 if (fsym->ts.type == BT_CHARACTER
3717 && parmse.string_length == NULL_TREE
3718 && e->ts.type == BT_PROCEDURE
3719 && e->symtree->n.sym->ts.type == BT_CHARACTER
3720 && e->symtree->n.sym->ts.u.cl->length != NULL
3721 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3723 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3724 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3728 if (fsym && need_interface_mapping && e)
3729 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3731 gfc_add_block_to_block (&se->pre, &parmse.pre);
3732 gfc_add_block_to_block (&post, &parmse.post);
3734 /* Allocated allocatable components of derived types must be
3735 deallocated for non-variable scalars. Non-variable arrays are
3736 dealt with in trans-array.c(gfc_conv_array_parameter). */
3737 if (e && e->ts.type == BT_DERIVED
3738 && e->ts.u.derived->attr.alloc_comp
3739 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3740 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3743 tmp = build_fold_indirect_ref_loc (input_location,
3745 parm_rank = e->rank;
3753 case (SCALAR_POINTER):
3754 tmp = build_fold_indirect_ref_loc (input_location,
3759 if (e->expr_type == EXPR_OP
3760 && e->value.op.op == INTRINSIC_PARENTHESES
3761 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3764 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3765 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3766 gfc_add_expr_to_block (&se->post, local_tmp);
3769 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3771 gfc_add_expr_to_block (&se->post, tmp);
3774 /* Add argument checking of passing an unallocated/NULL actual to
3775 a nonallocatable/nonpointer dummy. */
3777 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3779 symbol_attribute attr;
3783 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3784 attr = gfc_expr_attr (e);
3786 goto end_pointer_check;
3788 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3789 allocatable to an optional dummy, cf. 12.5.2.12. */
3790 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3791 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3792 goto end_pointer_check;
3796 /* If the actual argument is an optional pointer/allocatable and
3797 the formal argument takes an nonpointer optional value,
3798 it is invalid to pass a non-present argument on, even
3799 though there is no technical reason for this in gfortran.
3800 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3801 tree present, null_ptr, type;
3803 if (attr.allocatable
3804 && (fsym == NULL || !fsym->attr.allocatable))
3805 asprintf (&msg, "Allocatable actual argument '%s' is not "
3806 "allocated or not present", e->symtree->n.sym->name);
3807 else if (attr.pointer
3808 && (fsym == NULL || !fsym->attr.pointer))
3809 asprintf (&msg, "Pointer actual argument '%s' is not "
3810 "associated or not present",
3811 e->symtree->n.sym->name);
3812 else if (attr.proc_pointer
3813 && (fsym == NULL || !fsym->attr.proc_pointer))
3814 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3815 "associated or not present",
3816 e->symtree->n.sym->name);
3818 goto end_pointer_check;
3820 present = gfc_conv_expr_present (e->symtree->n.sym);
3821 type = TREE_TYPE (present);
3822 present = fold_build2_loc (input_location, EQ_EXPR,
3823 boolean_type_node, present,
3825 null_pointer_node));
3826 type = TREE_TYPE (parmse.expr);
3827 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3828 boolean_type_node, parmse.expr,
3830 null_pointer_node));
3831 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3832 boolean_type_node, present, null_ptr);
3836 if (attr.allocatable
3837 && (fsym == NULL || !fsym->attr.allocatable))
3838 asprintf (&msg, "Allocatable actual argument '%s' is not "
3839 "allocated", e->symtree->n.sym->name);
3840 else if (attr.pointer
3841 && (fsym == NULL || !fsym->attr.pointer))
3842 asprintf (&msg, "Pointer actual argument '%s' is not "
3843 "associated", e->symtree->n.sym->name);
3844 else if (attr.proc_pointer
3845 && (fsym == NULL || !fsym->attr.proc_pointer))
3846 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3847 "associated", e->symtree->n.sym->name);
3849 goto end_pointer_check;
3853 /* If the argument is passed by value, we need to strip the
3855 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
3856 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3858 cond = fold_build2_loc (input_location, EQ_EXPR,
3859 boolean_type_node, tmp,
3860 fold_convert (TREE_TYPE (tmp),
3861 null_pointer_node));
3864 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3870 /* Deferred length dummies pass the character length by reference
3871 so that the value can be returned. */
3872 if (parmse.string_length && fsym && fsym->ts.deferred)
3874 tmp = parmse.string_length;
3875 if (TREE_CODE (tmp) != VAR_DECL)
3876 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3877 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3880 /* Character strings are passed as two parameters, a length and a
3881 pointer - except for Bind(c) which only passes the pointer. */
3882 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3883 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3885 /* For descriptorless coarrays and assumed-shape coarray dummies, we
3886 pass the token and the offset as additional arguments. */
3887 if (fsym && fsym->attr.codimension
3888 && gfc_option.coarray == GFC_FCOARRAY_LIB
3889 && !fsym->attr.allocatable
3892 /* Token and offset. */
3893 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
3894 VEC_safe_push (tree, gc, stringargs,
3895 build_int_cst (gfc_array_index_type, 0));
3896 gcc_assert (fsym->attr.optional);
3898 else if (fsym && fsym->attr.codimension
3899 && !fsym->attr.allocatable
3900 && gfc_option.coarray == GFC_FCOARRAY_LIB)
3902 tree caf_decl, caf_type;
3905 caf_decl = get_tree_for_caf_expr (e);
3906 caf_type = TREE_TYPE (caf_decl);
3908 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3909 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3910 tmp = gfc_conv_descriptor_token (caf_decl);
3911 else if (DECL_LANG_SPECIFIC (caf_decl)
3912 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
3913 tmp = GFC_DECL_TOKEN (caf_decl);
3916 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
3917 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
3918 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
3921 VEC_safe_push (tree, gc, stringargs, tmp);
3923 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
3924 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
3925 offset = build_int_cst (gfc_array_index_type, 0);
3926 else if (DECL_LANG_SPECIFIC (caf_decl)
3927 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
3928 offset = GFC_DECL_CAF_OFFSET (caf_decl);
3929 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
3930 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
3932 offset = build_int_cst (gfc_array_index_type, 0);
3934 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
3935 tmp = gfc_conv_descriptor_data_get (caf_decl);
3938 gcc_assert (POINTER_TYPE_P (caf_type));
3942 if (fsym->as->type == AS_ASSUMED_SHAPE)
3944 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3945 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
3946 (TREE_TYPE (parmse.expr))));
3947 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
3948 tmp2 = gfc_conv_descriptor_data_get (tmp2);
3950 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
3951 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
3954 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
3958 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3959 gfc_array_index_type,
3960 fold_convert (gfc_array_index_type, tmp2),
3961 fold_convert (gfc_array_index_type, tmp));
3962 offset = fold_build2_loc (input_location, PLUS_EXPR,
3963 gfc_array_index_type, offset, tmp);
3965 VEC_safe_push (tree, gc, stringargs, offset);
3968 VEC_safe_push (tree, gc, arglist, parmse.expr);
3970 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3977 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3978 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3979 else if (ts.type == BT_CHARACTER)
3981 if (ts.u.cl->length == NULL)
3983 /* Assumed character length results are not allowed by 5.1.1.5 of the
3984 standard and are trapped in resolve.c; except in the case of SPREAD
3985 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3986 we take the character length of the first argument for the result.
3987 For dummies, we have to look through the formal argument list for
3988 this function and use the character length found there.*/
3989 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3990 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3991 else if (!sym->attr.dummy)
3992 cl.backend_decl = VEC_index (tree, stringargs, 0);
3995 formal = sym->ns->proc_name->formal;
3996 for (; formal; formal = formal->next)
3997 if (strcmp (formal->sym->name, sym->name) == 0)
3998 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
4005 /* Calculate the length of the returned string. */
4006 gfc_init_se (&parmse, NULL);
4007 if (need_interface_mapping)
4008 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
4010 gfc_conv_expr (&parmse, ts.u.cl->length);
4011 gfc_add_block_to_block (&se->pre, &parmse.pre);
4012 gfc_add_block_to_block (&se->post, &parmse.post);
4014 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
4015 tmp = fold_build2_loc (input_location, MAX_EXPR,
4016 gfc_charlen_type_node, tmp,
4017 build_int_cst (gfc_charlen_type_node, 0));
4018 cl.backend_decl = tmp;
4021 /* Set up a charlen structure for it. */
4026 len = cl.backend_decl;
4029 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
4030 || (!comp && gfc_return_by_reference (sym));
4033 if (se->direct_byref)
4035 /* Sometimes, too much indirection can be applied; e.g. for
4036 function_result = array_valued_recursive_function. */
4037 if (TREE_TYPE (TREE_TYPE (se->expr))
4038 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
4039 && GFC_DESCRIPTOR_TYPE_P
4040 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
4041 se->expr = build_fold_indirect_ref_loc (input_location,
4044 /* If the lhs of an assignment x = f(..) is allocatable and
4045 f2003 is allowed, we must do the automatic reallocation.
4046 TODO - deal with intrinsics, without using a temporary. */
4047 if (gfc_option.flag_realloc_lhs
4048 && se->ss && se->ss->loop_chain
4049 && se->ss->loop_chain->is_alloc_lhs
4050 && !expr->value.function.isym
4051 && sym->result->as != NULL)
4053 /* Evaluate the bounds of the result, if known. */
4054 gfc_set_loop_bounds_from_array_spec (&mapping, se,
4057 /* Perform the automatic reallocation. */
4058 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
4060 gfc_add_expr_to_block (&se->pre, tmp);
4062 /* Pass the temporary as the first argument. */
4063 result = info->descriptor;
4066 result = build_fold_indirect_ref_loc (input_location,
4068 VEC_safe_push (tree, gc, retargs, se->expr);
4070 else if (comp && comp->attr.dimension)
4072 gcc_assert (se->loop && info);
4074 /* Set the type of the array. */
4075 tmp = gfc_typenode_for_spec (&comp->ts);
4076 gcc_assert (se->ss->dimen == se->loop->dimen);
4078 /* Evaluate the bounds of the result, if known. */
4079 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
4081 /* If the lhs of an assignment x = f(..) is allocatable and
4082 f2003 is allowed, we must not generate the function call
4083 here but should just send back the results of the mapping.
4084 This is signalled by the function ss being flagged. */
4085 if (gfc_option.flag_realloc_lhs
4086 && se->ss && se->ss->is_alloc_lhs)
4088 gfc_free_interface_mapping (&mapping);
4089 return has_alternate_specifier;
4092 /* Create a temporary to store the result. In case the function
4093 returns a pointer, the temporary will be a shallow copy and
4094 mustn't be deallocated. */
4095 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
4096 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4097 tmp, NULL_TREE, false,
4098 !comp->attr.pointer, callee_alloc,
4099 &se->ss->info->expr->where);
4101 /* Pass the temporary as the first argument. */
4102 result = info->descriptor;
4103 tmp = gfc_build_addr_expr (NULL_TREE, result);
4104 VEC_safe_push (tree, gc, retargs, tmp);
4106 else if (!comp && sym->result->attr.dimension)
4108 gcc_assert (se->loop && info);
4110 /* Set the type of the array. */
4111 tmp = gfc_typenode_for_spec (&ts);
4112 gcc_assert (se->ss->dimen == se->loop->dimen);
4114 /* Evaluate the bounds of the result, if known. */
4115 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
4117 /* If the lhs of an assignment x = f(..) is allocatable and
4118 f2003 is allowed, we must not generate the function call
4119 here but should just send back the results of the mapping.
4120 This is signalled by the function ss being flagged. */
4121 if (gfc_option.flag_realloc_lhs
4122 && se->ss && se->ss->is_alloc_lhs)
4124 gfc_free_interface_mapping (&mapping);
4125 return has_alternate_specifier;
4128 /* Create a temporary to store the result. In case the function
4129 returns a pointer, the temporary will be a shallow copy and
4130 mustn't be deallocated. */
4131 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
4132 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4133 tmp, NULL_TREE, false,
4134 !sym->attr.pointer, callee_alloc,
4135 &se->ss->info->expr->where);
4137 /* Pass the temporary as the first argument. */
4138 result = info->descriptor;
4139 tmp = gfc_build_addr_expr (NULL_TREE, result);
4140 VEC_safe_push (tree, gc, retargs, tmp);
4142 else if (ts.type == BT_CHARACTER)
4144 /* Pass the string length. */
4145 type = gfc_get_character_type (ts.kind, ts.u.cl);
4146 type = build_pointer_type (type);
4148 /* Return an address to a char[0:len-1]* temporary for
4149 character pointers. */
4150 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4151 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
4153 var = gfc_create_var (type, "pstr");
4155 if ((!comp && sym->attr.allocatable)
4156 || (comp && comp->attr.allocatable))
4157 gfc_add_modify (&se->pre, var,
4158 fold_convert (TREE_TYPE (var),
4159 null_pointer_node));
4161 /* Provide an address expression for the function arguments. */
4162 var = gfc_build_addr_expr (NULL_TREE, var);
4165 var = gfc_conv_string_tmp (se, type, len);
4167 VEC_safe_push (tree, gc, retargs, var);
4171 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
4173 type = gfc_get_complex_type (ts.kind);
4174 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
4175 VEC_safe_push (tree, gc, retargs, var);
4178 if (ts.type == BT_CHARACTER && ts.deferred
4179 && (sym->attr.allocatable || sym->attr.pointer))
4182 if (TREE_CODE (tmp) != VAR_DECL)
4183 tmp = gfc_evaluate_now (len, &se->pre);
4184 len = gfc_build_addr_expr (NULL_TREE, tmp);
4187 /* Add the string length to the argument list. */
4188 if (ts.type == BT_CHARACTER)
4189 VEC_safe_push (tree, gc, retargs, len);
4191 gfc_free_interface_mapping (&mapping);
4193 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
4194 arglen = (VEC_length (tree, arglist)
4195 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
4196 VEC_reserve_exact (tree, gc, retargs, arglen);
4198 /* Add the return arguments. */
4199 VEC_splice (tree, retargs, arglist);
4201 /* Add the hidden string length parameters to the arguments. */
4202 VEC_splice (tree, retargs, stringargs);
4204 /* We may want to append extra arguments here. This is used e.g. for
4205 calls to libgfortran_matmul_??, which need extra information. */
4206 if (!VEC_empty (tree, append_args))
4207 VEC_splice (tree, retargs, append_args);
4210 /* Generate the actual call. */
4211 if (base_object == NULL_TREE)
4212 conv_function_val (se, sym, expr);
4214 conv_base_obj_fcn_val (se, base_object, expr);
4216 /* If there are alternate return labels, function type should be
4217 integer. Can't modify the type in place though, since it can be shared
4218 with other functions. For dummy arguments, the typing is done to
4219 this result, even if it has to be repeated for each call. */
4220 if (has_alternate_specifier
4221 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
4223 if (!sym->attr.dummy)
4225 TREE_TYPE (sym->backend_decl)
4226 = build_function_type (integer_type_node,
4227 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
4228 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
4231 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
4234 fntype = TREE_TYPE (TREE_TYPE (se->expr));
4235 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
4237 /* If we have a pointer function, but we don't want a pointer, e.g.
4240 where f is pointer valued, we have to dereference the result. */
4241 if (!se->want_pointer && !byref
4242 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4243 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
4244 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4246 /* f2c calling conventions require a scalar default real function to
4247 return a double precision result. Convert this back to default
4248 real. We only care about the cases that can happen in Fortran 77.
4250 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
4251 && sym->ts.kind == gfc_default_real_kind
4252 && !sym->attr.always_explicit)
4253 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
4255 /* A pure function may still have side-effects - it may modify its
4257 TREE_SIDE_EFFECTS (se->expr) = 1;
4259 if (!sym->attr.pure)
4260 TREE_SIDE_EFFECTS (se->expr) = 1;
4265 /* Add the function call to the pre chain. There is no expression. */
4266 gfc_add_expr_to_block (&se->pre, se->expr);
4267 se->expr = NULL_TREE;
4269 if (!se->direct_byref)
4271 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
4273 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4275 /* Check the data pointer hasn't been modified. This would
4276 happen in a function returning a pointer. */
4277 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4278 tmp = fold_build2_loc (input_location, NE_EXPR,
4281 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
4284 se->expr = info->descriptor;
4285 /* Bundle in the string length. */
4286 se->string_length = len;
4288 else if (ts.type == BT_CHARACTER)
4290 /* Dereference for character pointer results. */
4291 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4292 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
4293 se->expr = build_fold_indirect_ref_loc (input_location, var);
4298 se->string_length = len;
4299 else if (sym->attr.allocatable || sym->attr.pointer)
4300 se->string_length = cl.backend_decl;
4304 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
4305 se->expr = build_fold_indirect_ref_loc (input_location, var);
4310 /* Follow the function call with the argument post block. */
4313 gfc_add_block_to_block (&se->pre, &post);
4315 /* Transformational functions of derived types with allocatable
4316 components must have the result allocatable components copied. */
4317 arg = expr->value.function.actual;
4318 if (result && arg && expr->rank
4319 && expr->value.function.isym
4320 && expr->value.function.isym->transformational
4321 && arg->expr->ts.type == BT_DERIVED
4322 && arg->expr->ts.u.derived->attr.alloc_comp)
4325 /* Copy the allocatable components. We have to use a
4326 temporary here to prevent source allocatable components
4327 from being corrupted. */
4328 tmp2 = gfc_evaluate_now (result, &se->pre);
4329 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
4330 result, tmp2, expr->rank);
4331 gfc_add_expr_to_block (&se->pre, tmp);
4332 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
4334 gfc_add_expr_to_block (&se->pre, tmp);
4336 /* Finally free the temporary's data field. */
4337 tmp = gfc_conv_descriptor_data_get (tmp2);
4338 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
4339 gfc_add_expr_to_block (&se->pre, tmp);
4343 gfc_add_block_to_block (&se->post, &post);
4345 return has_alternate_specifier;
4349 /* Fill a character string with spaces. */
4352 fill_with_spaces (tree start, tree type, tree size)
4354 stmtblock_t block, loop;
4355 tree i, el, exit_label, cond, tmp;
4357 /* For a simple char type, we can call memset(). */
4358 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
4359 return build_call_expr_loc (input_location,
4360 builtin_decl_explicit (BUILT_IN_MEMSET),
4362 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
4363 lang_hooks.to_target_charset (' ')),
4366 /* Otherwise, we use a loop:
4367 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
4371 /* Initialize variables. */
4372 gfc_init_block (&block);
4373 i = gfc_create_var (sizetype, "i");
4374 gfc_add_modify (&block, i, fold_convert (sizetype, size));
4375 el = gfc_create_var (build_pointer_type (type), "el");
4376 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
4377 exit_label = gfc_build_label_decl (NULL_TREE);
4378 TREE_USED (exit_label) = 1;
4382 gfc_init_block (&loop);
4384 /* Exit condition. */
4385 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
4386 build_zero_cst (sizetype));
4387 tmp = build1_v (GOTO_EXPR, exit_label);
4388 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4389 build_empty_stmt (input_location));
4390 gfc_add_expr_to_block (&loop, tmp);
4393 gfc_add_modify (&loop,
4394 fold_build1_loc (input_location, INDIRECT_REF, type, el),
4395 build_int_cst (type, lang_hooks.to_target_charset (' ')));
4397 /* Increment loop variables. */
4398 gfc_add_modify (&loop, i,
4399 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
4400 TYPE_SIZE_UNIT (type)));
4401 gfc_add_modify (&loop, el,
4402 fold_build_pointer_plus_loc (input_location,
4403 el, TYPE_SIZE_UNIT (type)));
4405 /* Making the loop... actually loop! */
4406 tmp = gfc_finish_block (&loop);
4407 tmp = build1_v (LOOP_EXPR, tmp);
4408 gfc_add_expr_to_block (&block, tmp);
4410 /* The exit label. */
4411 tmp = build1_v (LABEL_EXPR, exit_label);
4412 gfc_add_expr_to_block (&block, tmp);
4415 return gfc_finish_block (&block);
4419 /* Generate code to copy a string. */
4422 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
4423 int dkind, tree slength, tree src, int skind)
4425 tree tmp, dlen, slen;
4434 stmtblock_t tempblock;
4436 gcc_assert (dkind == skind);
4438 if (slength != NULL_TREE)
4440 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
4441 ssc = gfc_string_to_single_character (slen, src, skind);
4445 slen = build_int_cst (size_type_node, 1);
4449 if (dlength != NULL_TREE)
4451 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
4452 dsc = gfc_string_to_single_character (dlen, dest, dkind);
4456 dlen = build_int_cst (size_type_node, 1);
4460 /* Assign directly if the types are compatible. */
4461 if (dsc != NULL_TREE && ssc != NULL_TREE
4462 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
4464 gfc_add_modify (block, dsc, ssc);
4468 /* Do nothing if the destination length is zero. */
4469 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
4470 build_int_cst (size_type_node, 0));
4472 /* The following code was previously in _gfortran_copy_string:
4474 // The two strings may overlap so we use memmove.
4476 copy_string (GFC_INTEGER_4 destlen, char * dest,
4477 GFC_INTEGER_4 srclen, const char * src)
4479 if (srclen >= destlen)
4481 // This will truncate if too long.
4482 memmove (dest, src, destlen);
4486 memmove (dest, src, srclen);
4488 memset (&dest[srclen], ' ', destlen - srclen);
4492 We're now doing it here for better optimization, but the logic
4495 /* For non-default character kinds, we have to multiply the string
4496 length by the base type size. */
4497 chartype = gfc_get_char_type (dkind);
4498 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4499 fold_convert (size_type_node, slen),
4500 fold_convert (size_type_node,
4501 TYPE_SIZE_UNIT (chartype)));
4502 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4503 fold_convert (size_type_node, dlen),
4504 fold_convert (size_type_node,
4505 TYPE_SIZE_UNIT (chartype)));
4507 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4508 dest = fold_convert (pvoid_type_node, dest);
4510 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4512 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4513 src = fold_convert (pvoid_type_node, src);
4515 src = gfc_build_addr_expr (pvoid_type_node, src);
4517 /* Truncate string if source is too long. */
4518 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4520 tmp2 = build_call_expr_loc (input_location,
4521 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4522 3, dest, src, dlen);
4524 /* Else copy and pad with spaces. */
4525 tmp3 = build_call_expr_loc (input_location,
4526 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4527 3, dest, src, slen);
4529 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4530 tmp4 = fill_with_spaces (tmp4, chartype,
4531 fold_build2_loc (input_location, MINUS_EXPR,
4532 TREE_TYPE(dlen), dlen, slen));
4534 gfc_init_block (&tempblock);
4535 gfc_add_expr_to_block (&tempblock, tmp3);
4536 gfc_add_expr_to_block (&tempblock, tmp4);
4537 tmp3 = gfc_finish_block (&tempblock);
4539 /* The whole copy_string function is there. */
4540 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4542 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4543 build_empty_stmt (input_location));
4544 gfc_add_expr_to_block (block, tmp);
4548 /* Translate a statement function.
4549 The value of a statement function reference is obtained by evaluating the
4550 expression using the values of the actual arguments for the values of the
4551 corresponding dummy arguments. */
4554 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4558 gfc_formal_arglist *fargs;
4559 gfc_actual_arglist *args;
4562 gfc_saved_var *saved_vars;
4568 sym = expr->symtree->n.sym;
4569 args = expr->value.function.actual;
4570 gfc_init_se (&lse, NULL);
4571 gfc_init_se (&rse, NULL);
4574 for (fargs = sym->formal; fargs; fargs = fargs->next)
4576 saved_vars = XCNEWVEC (gfc_saved_var, n);
4577 temp_vars = XCNEWVEC (tree, n);
4579 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4581 /* Each dummy shall be specified, explicitly or implicitly, to be
4583 gcc_assert (fargs->sym->attr.dimension == 0);
4586 if (fsym->ts.type == BT_CHARACTER)
4588 /* Copy string arguments. */
4591 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4592 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4594 /* Create a temporary to hold the value. */
4595 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4596 fsym->ts.u.cl->backend_decl
4597 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4599 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4600 temp_vars[n] = gfc_create_var (type, fsym->name);
4602 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4604 gfc_conv_expr (&rse, args->expr);
4605 gfc_conv_string_parameter (&rse);
4606 gfc_add_block_to_block (&se->pre, &lse.pre);
4607 gfc_add_block_to_block (&se->pre, &rse.pre);
4609 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4610 rse.string_length, rse.expr, fsym->ts.kind);
4611 gfc_add_block_to_block (&se->pre, &lse.post);
4612 gfc_add_block_to_block (&se->pre, &rse.post);
4616 /* For everything else, just evaluate the expression. */
4618 /* Create a temporary to hold the value. */
4619 type = gfc_typenode_for_spec (&fsym->ts);
4620 temp_vars[n] = gfc_create_var (type, fsym->name);
4622 gfc_conv_expr (&lse, args->expr);
4624 gfc_add_block_to_block (&se->pre, &lse.pre);
4625 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4626 gfc_add_block_to_block (&se->pre, &lse.post);
4632 /* Use the temporary variables in place of the real ones. */
4633 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4634 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4636 gfc_conv_expr (se, sym->value);
4638 if (sym->ts.type == BT_CHARACTER)
4640 gfc_conv_const_charlen (sym->ts.u.cl);
4642 /* Force the expression to the correct length. */
4643 if (!INTEGER_CST_P (se->string_length)
4644 || tree_int_cst_lt (se->string_length,
4645 sym->ts.u.cl->backend_decl))
4647 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4648 tmp = gfc_create_var (type, sym->name);
4649 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4650 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4651 sym->ts.kind, se->string_length, se->expr,
4655 se->string_length = sym->ts.u.cl->backend_decl;
4658 /* Restore the original variables. */
4659 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4660 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4665 /* Translate a function expression. */
4668 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4672 if (expr->value.function.isym)
4674 gfc_conv_intrinsic_function (se, expr);
4678 /* We distinguish statement functions from general functions to improve
4679 runtime performance. */
4680 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4682 gfc_conv_statement_function (se, expr);
4686 /* expr.value.function.esym is the resolved (specific) function symbol for
4687 most functions. However this isn't set for dummy procedures. */
4688 sym = expr->value.function.esym;
4690 sym = expr->symtree->n.sym;
4692 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4696 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4699 is_zero_initializer_p (gfc_expr * expr)
4701 if (expr->expr_type != EXPR_CONSTANT)
4704 /* We ignore constants with prescribed memory representations for now. */
4705 if (expr->representation.string)
4708 switch (expr->ts.type)
4711 return mpz_cmp_si (expr->value.integer, 0) == 0;
4714 return mpfr_zero_p (expr->value.real)
4715 && MPFR_SIGN (expr->value.real) >= 0;
4718 return expr->value.logical == 0;
4721 return mpfr_zero_p (mpc_realref (expr->value.complex))
4722 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4723 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4724 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4734 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4739 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
4740 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
4742 gfc_conv_tmp_array_ref (se);
4746 /* Build a static initializer. EXPR is the expression for the initial value.
4747 The other parameters describe the variable of the component being
4748 initialized. EXPR may be null. */
4751 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4752 bool array, bool pointer, bool procptr)
4756 if (!(expr || pointer || procptr))
4759 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4760 (these are the only two iso_c_binding derived types that can be
4761 used as initialization expressions). If so, we need to modify
4762 the 'expr' to be that for a (void *). */
4763 if (expr != NULL && expr->ts.type == BT_DERIVED
4764 && expr->ts.is_iso_c && expr->ts.u.derived)
4766 gfc_symbol *derived = expr->ts.u.derived;
4768 /* The derived symbol has already been converted to a (void *). Use
4770 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4771 expr->ts.f90_type = derived->ts.f90_type;
4773 gfc_init_se (&se, NULL);
4774 gfc_conv_constant (&se, expr);
4775 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4779 if (array && !procptr)
4782 /* Arrays need special handling. */
4784 ctor = gfc_build_null_descriptor (type);
4785 /* Special case assigning an array to zero. */
4786 else if (is_zero_initializer_p (expr))
4787 ctor = build_constructor (type, NULL);
4789 ctor = gfc_conv_array_initializer (type, expr);
4790 TREE_STATIC (ctor) = 1;
4793 else if (pointer || procptr)
4795 if (!expr || expr->expr_type == EXPR_NULL)
4796 return fold_convert (type, null_pointer_node);
4799 gfc_init_se (&se, NULL);
4800 se.want_pointer = 1;
4801 gfc_conv_expr (&se, expr);
4802 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4812 gfc_init_se (&se, NULL);
4813 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4814 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4816 gfc_conv_structure (&se, expr, 1);
4817 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4818 TREE_STATIC (se.expr) = 1;
4823 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4824 TREE_STATIC (ctor) = 1;
4829 gfc_init_se (&se, NULL);
4830 gfc_conv_constant (&se, expr);
4831 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4838 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4844 gfc_array_info *lss_array;
4851 gfc_start_block (&block);
4853 /* Initialize the scalarizer. */
4854 gfc_init_loopinfo (&loop);
4856 gfc_init_se (&lse, NULL);
4857 gfc_init_se (&rse, NULL);
4860 rss = gfc_walk_expr (expr);
4861 if (rss == gfc_ss_terminator)
4862 /* The rhs is scalar. Add a ss for the expression. */
4863 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4865 /* Create a SS for the destination. */
4866 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4868 lss_array = &lss->info->data.array;
4869 lss_array->shape = gfc_get_shape (cm->as->rank);
4870 lss_array->descriptor = dest;
4871 lss_array->data = gfc_conv_array_data (dest);
4872 lss_array->offset = gfc_conv_array_offset (dest);
4873 for (n = 0; n < cm->as->rank; n++)
4875 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
4876 lss_array->stride[n] = gfc_index_one_node;
4878 mpz_init (lss_array->shape[n]);
4879 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
4880 cm->as->lower[n]->value.integer);
4881 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
4884 /* Associate the SS with the loop. */
4885 gfc_add_ss_to_loop (&loop, lss);
4886 gfc_add_ss_to_loop (&loop, rss);
4888 /* Calculate the bounds of the scalarization. */
4889 gfc_conv_ss_startstride (&loop);
4891 /* Setup the scalarizing loops. */
4892 gfc_conv_loop_setup (&loop, &expr->where);
4894 /* Setup the gfc_se structures. */
4895 gfc_copy_loopinfo_to_se (&lse, &loop);
4896 gfc_copy_loopinfo_to_se (&rse, &loop);
4899 gfc_mark_ss_chain_used (rss, 1);
4901 gfc_mark_ss_chain_used (lss, 1);
4903 /* Start the scalarized loop body. */
4904 gfc_start_scalarized_body (&loop, &body);
4906 gfc_conv_tmp_array_ref (&lse);
4907 if (cm->ts.type == BT_CHARACTER)
4908 lse.string_length = cm->ts.u.cl->backend_decl;
4910 gfc_conv_expr (&rse, expr);
4912 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4913 gfc_add_expr_to_block (&body, tmp);
4915 gcc_assert (rse.ss == gfc_ss_terminator);
4917 /* Generate the copying loops. */
4918 gfc_trans_scalarizing_loops (&loop, &body);
4920 /* Wrap the whole thing up. */
4921 gfc_add_block_to_block (&block, &loop.pre);
4922 gfc_add_block_to_block (&block, &loop.post);
4924 gcc_assert (lss_array->shape != NULL);
4925 gfc_free_shape (&lss_array->shape, cm->as->rank);
4926 gfc_cleanup_loop (&loop);
4928 return gfc_finish_block (&block);
4933 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4944 gfc_expr *arg = NULL;
4946 gfc_start_block (&block);
4947 gfc_init_se (&se, NULL);
4949 /* Get the descriptor for the expressions. */
4950 rss = gfc_walk_expr (expr);
4951 se.want_pointer = 0;
4952 gfc_conv_expr_descriptor (&se, expr, rss);
4953 gfc_add_block_to_block (&block, &se.pre);
4954 gfc_add_modify (&block, dest, se.expr);
4956 /* Deal with arrays of derived types with allocatable components. */
4957 if (cm->ts.type == BT_DERIVED
4958 && cm->ts.u.derived->attr.alloc_comp)
4959 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4963 tmp = gfc_duplicate_allocatable (dest, se.expr,
4964 TREE_TYPE(cm->backend_decl),
4967 gfc_add_expr_to_block (&block, tmp);
4968 gfc_add_block_to_block (&block, &se.post);
4970 if (expr->expr_type != EXPR_VARIABLE)
4971 gfc_conv_descriptor_data_set (&block, se.expr,
4974 /* We need to know if the argument of a conversion function is a
4975 variable, so that the correct lower bound can be used. */
4976 if (expr->expr_type == EXPR_FUNCTION
4977 && expr->value.function.isym
4978 && expr->value.function.isym->conversion
4979 && expr->value.function.actual->expr
4980 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4981 arg = expr->value.function.actual->expr;
4983 /* Obtain the array spec of full array references. */
4985 as = gfc_get_full_arrayspec_from_expr (arg);
4987 as = gfc_get_full_arrayspec_from_expr (expr);
4989 /* Shift the lbound and ubound of temporaries to being unity,
4990 rather than zero, based. Always calculate the offset. */
4991 offset = gfc_conv_descriptor_offset_get (dest);
4992 gfc_add_modify (&block, offset, gfc_index_zero_node);
4993 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4995 for (n = 0; n < expr->rank; n++)
5000 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5001 TODO It looks as if gfc_conv_expr_descriptor should return
5002 the correct bounds and that the following should not be
5003 necessary. This would simplify gfc_conv_intrinsic_bound
5005 if (as && as->lower[n])
5008 gfc_init_se (&lbse, NULL);
5009 gfc_conv_expr (&lbse, as->lower[n]);
5010 gfc_add_block_to_block (&block, &lbse.pre);
5011 lbound = gfc_evaluate_now (lbse.expr, &block);
5015 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
5016 lbound = gfc_conv_descriptor_lbound_get (tmp,
5020 lbound = gfc_conv_descriptor_lbound_get (dest,
5023 lbound = gfc_index_one_node;
5025 lbound = fold_convert (gfc_array_index_type, lbound);
5027 /* Shift the bounds and set the offset accordingly. */
5028 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
5029 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5030 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
5031 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5033 gfc_conv_descriptor_ubound_set (&block, dest,
5034 gfc_rank_cst[n], tmp);
5035 gfc_conv_descriptor_lbound_set (&block, dest,
5036 gfc_rank_cst[n], lbound);
5038 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5039 gfc_conv_descriptor_lbound_get (dest,
5041 gfc_conv_descriptor_stride_get (dest,
5043 gfc_add_modify (&block, tmp2, tmp);
5044 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5046 gfc_conv_descriptor_offset_set (&block, dest, tmp);
5051 /* If a conversion expression has a null data pointer
5052 argument, nullify the allocatable component. */
5056 if (arg->symtree->n.sym->attr.allocatable
5057 || arg->symtree->n.sym->attr.pointer)
5059 non_null_expr = gfc_finish_block (&block);
5060 gfc_start_block (&block);
5061 gfc_conv_descriptor_data_set (&block, dest,
5063 null_expr = gfc_finish_block (&block);
5064 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
5065 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5066 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5067 return build3_v (COND_EXPR, tmp,
5068 null_expr, non_null_expr);
5072 return gfc_finish_block (&block);
5076 /* Assign a single component of a derived type constructor. */
5079 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
5087 gfc_start_block (&block);
5089 if (cm->attr.pointer)
5091 gfc_init_se (&se, NULL);
5092 /* Pointer component. */
5093 if (cm->attr.dimension)
5095 /* Array pointer. */
5096 if (expr->expr_type == EXPR_NULL)
5097 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5100 rss = gfc_walk_expr (expr);
5101 se.direct_byref = 1;
5103 gfc_conv_expr_descriptor (&se, expr, rss);
5104 gfc_add_block_to_block (&block, &se.pre);
5105 gfc_add_block_to_block (&block, &se.post);
5110 /* Scalar pointers. */
5111 se.want_pointer = 1;
5112 gfc_conv_expr (&se, expr);
5113 gfc_add_block_to_block (&block, &se.pre);
5114 gfc_add_modify (&block, dest,
5115 fold_convert (TREE_TYPE (dest), se.expr));
5116 gfc_add_block_to_block (&block, &se.post);
5119 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
5121 /* NULL initialization for CLASS components. */
5122 tmp = gfc_trans_structure_assign (dest,
5123 gfc_class_null_initializer (&cm->ts));
5124 gfc_add_expr_to_block (&block, tmp);
5126 else if (cm->attr.dimension && !cm->attr.proc_pointer)
5128 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
5129 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5130 else if (cm->attr.allocatable)
5132 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
5133 gfc_add_expr_to_block (&block, tmp);
5137 tmp = gfc_trans_subarray_assign (dest, cm, expr);
5138 gfc_add_expr_to_block (&block, tmp);
5141 else if (expr->ts.type == BT_DERIVED)
5143 if (expr->expr_type != EXPR_STRUCTURE)
5145 gfc_init_se (&se, NULL);
5146 gfc_conv_expr (&se, expr);
5147 gfc_add_block_to_block (&block, &se.pre);
5148 gfc_add_modify (&block, dest,
5149 fold_convert (TREE_TYPE (dest), se.expr));
5150 gfc_add_block_to_block (&block, &se.post);
5154 /* Nested constructors. */
5155 tmp = gfc_trans_structure_assign (dest, expr);
5156 gfc_add_expr_to_block (&block, tmp);
5161 /* Scalar component. */
5162 gfc_init_se (&se, NULL);
5163 gfc_init_se (&lse, NULL);
5165 gfc_conv_expr (&se, expr);
5166 if (cm->ts.type == BT_CHARACTER)
5167 lse.string_length = cm->ts.u.cl->backend_decl;
5169 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
5170 gfc_add_expr_to_block (&block, tmp);
5172 return gfc_finish_block (&block);
5175 /* Assign a derived type constructor to a variable. */
5178 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
5186 gfc_start_block (&block);
5187 cm = expr->ts.u.derived->components;
5189 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
5190 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
5191 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
5195 gcc_assert (cm->backend_decl == NULL);
5196 gfc_init_se (&se, NULL);
5197 gfc_init_se (&lse, NULL);
5198 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
5200 gfc_add_modify (&block, lse.expr,
5201 fold_convert (TREE_TYPE (lse.expr), se.expr));
5203 return gfc_finish_block (&block);
5206 for (c = gfc_constructor_first (expr->value.constructor);
5207 c; c = gfc_constructor_next (c), cm = cm->next)
5209 /* Skip absent members in default initializers. */
5213 field = cm->backend_decl;
5214 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
5215 dest, field, NULL_TREE);
5216 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
5217 gfc_add_expr_to_block (&block, tmp);
5219 return gfc_finish_block (&block);
5222 /* Build an expression for a constructor. If init is nonzero then
5223 this is part of a static variable initializer. */
5226 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
5233 VEC(constructor_elt,gc) *v = NULL;
5235 gcc_assert (se->ss == NULL);
5236 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
5237 type = gfc_typenode_for_spec (&expr->ts);
5241 /* Create a temporary variable and fill it in. */
5242 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
5243 tmp = gfc_trans_structure_assign (se->expr, expr);
5244 gfc_add_expr_to_block (&se->pre, tmp);
5248 cm = expr->ts.u.derived->components;
5250 for (c = gfc_constructor_first (expr->value.constructor);
5251 c; c = gfc_constructor_next (c), cm = cm->next)
5253 /* Skip absent members in default initializers and allocatable
5254 components. Although the latter have a default initializer
5255 of EXPR_NULL,... by default, the static nullify is not needed
5256 since this is done every time we come into scope. */
5257 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
5260 if (strcmp (cm->name, "_size") == 0)
5262 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
5263 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
5265 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
5266 && strcmp (cm->name, "_extends") == 0)
5270 vtabs = cm->initializer->symtree->n.sym;
5271 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
5272 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
5276 val = gfc_conv_initializer (c->expr, &cm->ts,
5277 TREE_TYPE (cm->backend_decl),
5278 cm->attr.dimension, cm->attr.pointer,
5279 cm->attr.proc_pointer);
5281 /* Append it to the constructor list. */
5282 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
5285 se->expr = build_constructor (type, v);
5287 TREE_CONSTANT (se->expr) = 1;
5291 /* Translate a substring expression. */
5294 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
5300 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
5302 se->expr = gfc_build_wide_string_const (expr->ts.kind,
5303 expr->value.character.length,
5304 expr->value.character.string);
5306 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
5307 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
5310 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
5314 /* Entry point for expression translation. Evaluates a scalar quantity.
5315 EXPR is the expression to be translated, and SE is the state structure if
5316 called from within the scalarized. */
5319 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
5324 if (ss && ss->info->expr == expr
5325 && (ss->info->type == GFC_SS_SCALAR
5326 || ss->info->type == GFC_SS_REFERENCE))
5328 gfc_ss_info *ss_info;
5331 /* Substitute a scalar expression evaluated outside the scalarization
5333 se->expr = ss_info->data.scalar.value;
5334 if (ss_info->type == GFC_SS_REFERENCE)
5335 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5336 se->string_length = ss_info->string_length;
5337 gfc_advance_se_ss_chain (se);
5341 /* We need to convert the expressions for the iso_c_binding derived types.
5342 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
5343 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
5344 typespec for the C_PTR and C_FUNPTR symbols, which has already been
5345 updated to be an integer with a kind equal to the size of a (void *). */
5346 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
5347 && expr->ts.u.derived->attr.is_iso_c)
5349 if (expr->expr_type == EXPR_VARIABLE
5350 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
5351 || expr->symtree->n.sym->intmod_sym_id
5352 == ISOCBINDING_NULL_FUNPTR))
5354 /* Set expr_type to EXPR_NULL, which will result in
5355 null_pointer_node being used below. */
5356 expr->expr_type = EXPR_NULL;
5360 /* Update the type/kind of the expression to be what the new
5361 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
5362 expr->ts.type = expr->ts.u.derived->ts.type;
5363 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
5364 expr->ts.kind = expr->ts.u.derived->ts.kind;
5368 /* TODO: make this work for general class array expressions. */
5369 if (expr->ts.type == BT_CLASS
5370 && expr->ref && expr->ref->type == REF_ARRAY)
5371 gfc_add_component_ref (expr, "_data");
5373 switch (expr->expr_type)
5376 gfc_conv_expr_op (se, expr);
5380 gfc_conv_function_expr (se, expr);
5384 gfc_conv_constant (se, expr);
5388 gfc_conv_variable (se, expr);
5392 se->expr = null_pointer_node;
5395 case EXPR_SUBSTRING:
5396 gfc_conv_substring_expr (se, expr);
5399 case EXPR_STRUCTURE:
5400 gfc_conv_structure (se, expr, 0);
5404 gfc_conv_array_constructor_expr (se, expr);
5413 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
5414 of an assignment. */
5416 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
5418 gfc_conv_expr (se, expr);
5419 /* All numeric lvalues should have empty post chains. If not we need to
5420 figure out a way of rewriting an lvalue so that it has no post chain. */
5421 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
5424 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
5425 numeric expressions. Used for scalar values where inserting cleanup code
5428 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
5432 gcc_assert (expr->ts.type != BT_CHARACTER);
5433 gfc_conv_expr (se, expr);
5436 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
5437 gfc_add_modify (&se->pre, val, se->expr);
5439 gfc_add_block_to_block (&se->pre, &se->post);
5443 /* Helper to translate an expression and convert it to a particular type. */
5445 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
5447 gfc_conv_expr_val (se, expr);
5448 se->expr = convert (type, se->expr);
5452 /* Converts an expression so that it can be passed by reference. Scalar
5456 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
5462 if (ss && ss->info->expr == expr
5463 && ss->info->type == GFC_SS_REFERENCE)
5465 /* Returns a reference to the scalar evaluated outside the loop
5467 gfc_conv_expr (se, expr);
5471 if (expr->ts.type == BT_CHARACTER)
5473 gfc_conv_expr (se, expr);
5474 gfc_conv_string_parameter (se);
5478 if (expr->expr_type == EXPR_VARIABLE)
5480 se->want_pointer = 1;
5481 gfc_conv_expr (se, expr);
5484 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5485 gfc_add_modify (&se->pre, var, se->expr);
5486 gfc_add_block_to_block (&se->pre, &se->post);
5492 if (expr->expr_type == EXPR_FUNCTION
5493 && ((expr->value.function.esym
5494 && expr->value.function.esym->result->attr.pointer
5495 && !expr->value.function.esym->result->attr.dimension)
5496 || (!expr->value.function.esym
5497 && expr->symtree->n.sym->attr.pointer
5498 && !expr->symtree->n.sym->attr.dimension)))
5500 se->want_pointer = 1;
5501 gfc_conv_expr (se, expr);
5502 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5503 gfc_add_modify (&se->pre, var, se->expr);
5508 gfc_conv_expr (se, expr);
5510 /* Create a temporary var to hold the value. */
5511 if (TREE_CONSTANT (se->expr))
5513 tree tmp = se->expr;
5514 STRIP_TYPE_NOPS (tmp);
5515 var = build_decl (input_location,
5516 CONST_DECL, NULL, TREE_TYPE (tmp));
5517 DECL_INITIAL (var) = tmp;
5518 TREE_STATIC (var) = 1;
5523 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5524 gfc_add_modify (&se->pre, var, se->expr);
5526 gfc_add_block_to_block (&se->pre, &se->post);
5528 /* Take the address of that value. */
5529 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5534 gfc_trans_pointer_assign (gfc_code * code)
5536 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5540 /* Generate code for a pointer assignment. */
5543 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5554 gfc_start_block (&block);
5556 gfc_init_se (&lse, NULL);
5558 lss = gfc_walk_expr (expr1);
5559 rss = gfc_walk_expr (expr2);
5560 if (lss == gfc_ss_terminator)
5562 /* Scalar pointers. */
5563 lse.want_pointer = 1;
5564 gfc_conv_expr (&lse, expr1);
5565 gcc_assert (rss == gfc_ss_terminator);
5566 gfc_init_se (&rse, NULL);
5567 rse.want_pointer = 1;
5568 gfc_conv_expr (&rse, expr2);
5570 if (expr1->symtree->n.sym->attr.proc_pointer
5571 && expr1->symtree->n.sym->attr.dummy)
5572 lse.expr = build_fold_indirect_ref_loc (input_location,
5575 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5576 && expr2->symtree->n.sym->attr.dummy)
5577 rse.expr = build_fold_indirect_ref_loc (input_location,
5580 gfc_add_block_to_block (&block, &lse.pre);
5581 gfc_add_block_to_block (&block, &rse.pre);
5583 /* Check character lengths if character expression. The test is only
5584 really added if -fbounds-check is enabled. Exclude deferred
5585 character length lefthand sides. */
5586 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5587 && !(expr1->ts.deferred
5588 && (TREE_CODE (lse.string_length) == VAR_DECL))
5589 && !expr1->symtree->n.sym->attr.proc_pointer
5590 && !gfc_is_proc_ptr_comp (expr1, NULL))
5592 gcc_assert (expr2->ts.type == BT_CHARACTER);
5593 gcc_assert (lse.string_length && rse.string_length);
5594 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5595 lse.string_length, rse.string_length,
5599 /* The assignment to an deferred character length sets the string
5600 length to that of the rhs. */
5601 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5603 if (expr2->expr_type != EXPR_NULL)
5604 gfc_add_modify (&block, lse.string_length, rse.string_length);
5606 gfc_add_modify (&block, lse.string_length,
5607 build_int_cst (gfc_charlen_type_node, 0));
5610 gfc_add_modify (&block, lse.expr,
5611 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5613 gfc_add_block_to_block (&block, &rse.post);
5614 gfc_add_block_to_block (&block, &lse.post);
5621 tree strlen_rhs = NULL_TREE;
5623 /* Array pointer. Find the last reference on the LHS and if it is an
5624 array section ref, we're dealing with bounds remapping. In this case,
5625 set it to AR_FULL so that gfc_conv_expr_descriptor does
5626 not see it and process the bounds remapping afterwards explicitely. */
5627 for (remap = expr1->ref; remap; remap = remap->next)
5628 if (!remap->next && remap->type == REF_ARRAY
5629 && remap->u.ar.type == AR_SECTION)
5631 remap->u.ar.type = AR_FULL;
5634 rank_remap = (remap && remap->u.ar.end[0]);
5636 gfc_conv_expr_descriptor (&lse, expr1, lss);
5637 strlen_lhs = lse.string_length;
5640 if (expr2->expr_type == EXPR_NULL)
5642 /* Just set the data pointer to null. */
5643 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5645 else if (rank_remap)
5647 /* If we are rank-remapping, just get the RHS's descriptor and
5648 process this later on. */
5649 gfc_init_se (&rse, NULL);
5650 rse.direct_byref = 1;
5651 rse.byref_noassign = 1;
5652 gfc_conv_expr_descriptor (&rse, expr2, rss);
5653 strlen_rhs = rse.string_length;
5655 else if (expr2->expr_type == EXPR_VARIABLE)
5657 /* Assign directly to the LHS's descriptor. */
5658 lse.direct_byref = 1;
5659 gfc_conv_expr_descriptor (&lse, expr2, rss);
5660 strlen_rhs = lse.string_length;
5662 /* If this is a subreference array pointer assignment, use the rhs
5663 descriptor element size for the lhs span. */
5664 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5666 decl = expr1->symtree->n.sym->backend_decl;
5667 gfc_init_se (&rse, NULL);
5668 rse.descriptor_only = 1;
5669 gfc_conv_expr (&rse, expr2);
5670 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5671 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5672 if (!INTEGER_CST_P (tmp))
5673 gfc_add_block_to_block (&lse.post, &rse.pre);
5674 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5679 /* Assign to a temporary descriptor and then copy that
5680 temporary to the pointer. */
5681 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5684 lse.direct_byref = 1;
5685 gfc_conv_expr_descriptor (&lse, expr2, rss);
5686 strlen_rhs = lse.string_length;
5687 gfc_add_modify (&lse.pre, desc, tmp);
5690 gfc_add_block_to_block (&block, &lse.pre);
5692 gfc_add_block_to_block (&block, &rse.pre);
5694 /* If we do bounds remapping, update LHS descriptor accordingly. */
5698 gcc_assert (remap->u.ar.dimen == expr1->rank);
5702 /* Do rank remapping. We already have the RHS's descriptor
5703 converted in rse and now have to build the correct LHS
5704 descriptor for it. */
5708 tree lbound, ubound;
5711 dtype = gfc_conv_descriptor_dtype (desc);
5712 tmp = gfc_get_dtype (TREE_TYPE (desc));
5713 gfc_add_modify (&block, dtype, tmp);
5715 /* Copy data pointer. */
5716 data = gfc_conv_descriptor_data_get (rse.expr);
5717 gfc_conv_descriptor_data_set (&block, desc, data);
5719 /* Copy offset but adjust it such that it would correspond
5720 to a lbound of zero. */
5721 offs = gfc_conv_descriptor_offset_get (rse.expr);
5722 for (dim = 0; dim < expr2->rank; ++dim)
5724 stride = gfc_conv_descriptor_stride_get (rse.expr,
5726 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5728 tmp = fold_build2_loc (input_location, MULT_EXPR,
5729 gfc_array_index_type, stride, lbound);
5730 offs = fold_build2_loc (input_location, PLUS_EXPR,
5731 gfc_array_index_type, offs, tmp);
5733 gfc_conv_descriptor_offset_set (&block, desc, offs);
5735 /* Set the bounds as declared for the LHS and calculate strides as
5736 well as another offset update accordingly. */
5737 stride = gfc_conv_descriptor_stride_get (rse.expr,
5739 for (dim = 0; dim < expr1->rank; ++dim)
5744 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5746 /* Convert declared bounds. */
5747 gfc_init_se (&lower_se, NULL);
5748 gfc_init_se (&upper_se, NULL);
5749 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5750 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5752 gfc_add_block_to_block (&block, &lower_se.pre);
5753 gfc_add_block_to_block (&block, &upper_se.pre);
5755 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5756 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5758 lbound = gfc_evaluate_now (lbound, &block);
5759 ubound = gfc_evaluate_now (ubound, &block);
5761 gfc_add_block_to_block (&block, &lower_se.post);
5762 gfc_add_block_to_block (&block, &upper_se.post);
5764 /* Set bounds in descriptor. */
5765 gfc_conv_descriptor_lbound_set (&block, desc,
5766 gfc_rank_cst[dim], lbound);
5767 gfc_conv_descriptor_ubound_set (&block, desc,
5768 gfc_rank_cst[dim], ubound);
5771 stride = gfc_evaluate_now (stride, &block);
5772 gfc_conv_descriptor_stride_set (&block, desc,
5773 gfc_rank_cst[dim], stride);
5775 /* Update offset. */
5776 offs = gfc_conv_descriptor_offset_get (desc);
5777 tmp = fold_build2_loc (input_location, MULT_EXPR,
5778 gfc_array_index_type, lbound, stride);
5779 offs = fold_build2_loc (input_location, MINUS_EXPR,
5780 gfc_array_index_type, offs, tmp);
5781 offs = gfc_evaluate_now (offs, &block);
5782 gfc_conv_descriptor_offset_set (&block, desc, offs);
5784 /* Update stride. */
5785 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5786 stride = fold_build2_loc (input_location, MULT_EXPR,
5787 gfc_array_index_type, stride, tmp);
5792 /* Bounds remapping. Just shift the lower bounds. */
5794 gcc_assert (expr1->rank == expr2->rank);
5796 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5800 gcc_assert (remap->u.ar.start[dim]);
5801 gcc_assert (!remap->u.ar.end[dim]);
5802 gfc_init_se (&lbound_se, NULL);
5803 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5805 gfc_add_block_to_block (&block, &lbound_se.pre);
5806 gfc_conv_shift_descriptor_lbound (&block, desc,
5807 dim, lbound_se.expr);
5808 gfc_add_block_to_block (&block, &lbound_se.post);
5813 /* Check string lengths if applicable. The check is only really added
5814 to the output code if -fbounds-check is enabled. */
5815 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5817 gcc_assert (expr2->ts.type == BT_CHARACTER);
5818 gcc_assert (strlen_lhs && strlen_rhs);
5819 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5820 strlen_lhs, strlen_rhs, &block);
5823 /* If rank remapping was done, check with -fcheck=bounds that
5824 the target is at least as large as the pointer. */
5825 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5831 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5832 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5834 lsize = gfc_evaluate_now (lsize, &block);
5835 rsize = gfc_evaluate_now (rsize, &block);
5836 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5839 msg = _("Target of rank remapping is too small (%ld < %ld)");
5840 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5844 gfc_add_block_to_block (&block, &lse.post);
5846 gfc_add_block_to_block (&block, &rse.post);
5849 return gfc_finish_block (&block);
5853 /* Makes sure se is suitable for passing as a function string parameter. */
5854 /* TODO: Need to check all callers of this function. It may be abused. */
5857 gfc_conv_string_parameter (gfc_se * se)
5861 if (TREE_CODE (se->expr) == STRING_CST)
5863 type = TREE_TYPE (TREE_TYPE (se->expr));
5864 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5868 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5870 if (TREE_CODE (se->expr) != INDIRECT_REF)
5872 type = TREE_TYPE (se->expr);
5873 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5877 type = gfc_get_character_type_len (gfc_default_character_kind,
5879 type = build_pointer_type (type);
5880 se->expr = gfc_build_addr_expr (type, se->expr);
5884 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5888 /* Generate code for assignment of scalar variables. Includes character
5889 strings and derived types with allocatable components.
5890 If you know that the LHS has no allocations, set dealloc to false. */
5893 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5894 bool l_is_temp, bool r_is_var, bool dealloc)
5900 gfc_init_block (&block);
5902 if (ts.type == BT_CHARACTER)
5907 if (lse->string_length != NULL_TREE)
5909 gfc_conv_string_parameter (lse);
5910 gfc_add_block_to_block (&block, &lse->pre);
5911 llen = lse->string_length;
5914 if (rse->string_length != NULL_TREE)
5916 gcc_assert (rse->string_length != NULL_TREE);
5917 gfc_conv_string_parameter (rse);
5918 gfc_add_block_to_block (&block, &rse->pre);
5919 rlen = rse->string_length;
5922 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5923 rse->expr, ts.kind);
5925 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5929 /* Are the rhs and the lhs the same? */
5932 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5933 gfc_build_addr_expr (NULL_TREE, lse->expr),
5934 gfc_build_addr_expr (NULL_TREE, rse->expr));
5935 cond = gfc_evaluate_now (cond, &lse->pre);
5938 /* Deallocate the lhs allocated components as long as it is not
5939 the same as the rhs. This must be done following the assignment
5940 to prevent deallocating data that could be used in the rhs
5942 if (!l_is_temp && dealloc)
5944 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5945 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5947 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5949 gfc_add_expr_to_block (&lse->post, tmp);
5952 gfc_add_block_to_block (&block, &rse->pre);
5953 gfc_add_block_to_block (&block, &lse->pre);
5955 gfc_add_modify (&block, lse->expr,
5956 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5958 /* Do a deep copy if the rhs is a variable, if it is not the
5962 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5963 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5965 gfc_add_expr_to_block (&block, tmp);
5968 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5970 gfc_add_block_to_block (&block, &lse->pre);
5971 gfc_add_block_to_block (&block, &rse->pre);
5972 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5973 TREE_TYPE (lse->expr), rse->expr);
5974 gfc_add_modify (&block, lse->expr, tmp);
5978 gfc_add_block_to_block (&block, &lse->pre);
5979 gfc_add_block_to_block (&block, &rse->pre);
5981 gfc_add_modify (&block, lse->expr,
5982 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5985 gfc_add_block_to_block (&block, &lse->post);
5986 gfc_add_block_to_block (&block, &rse->post);
5988 return gfc_finish_block (&block);
5992 /* There are quite a lot of restrictions on the optimisation in using an
5993 array function assign without a temporary. */
5996 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5999 bool seen_array_ref;
6001 gfc_symbol *sym = expr1->symtree->n.sym;
6003 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6004 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
6007 /* Elemental functions are scalarized so that they don't need a
6008 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6009 they would need special treatment in gfc_trans_arrayfunc_assign. */
6010 if (expr2->value.function.esym != NULL
6011 && expr2->value.function.esym->attr.elemental)
6014 /* Need a temporary if rhs is not FULL or a contiguous section. */
6015 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
6018 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6019 if (gfc_ref_needs_temporary_p (expr1->ref))
6022 /* Functions returning pointers or allocatables need temporaries. */
6023 c = expr2->value.function.esym
6024 ? (expr2->value.function.esym->attr.pointer
6025 || expr2->value.function.esym->attr.allocatable)
6026 : (expr2->symtree->n.sym->attr.pointer
6027 || expr2->symtree->n.sym->attr.allocatable);
6031 /* Character array functions need temporaries unless the
6032 character lengths are the same. */
6033 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
6035 if (expr1->ts.u.cl->length == NULL
6036 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6039 if (expr2->ts.u.cl->length == NULL
6040 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6043 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
6044 expr2->ts.u.cl->length->value.integer) != 0)
6048 /* Check that no LHS component references appear during an array
6049 reference. This is needed because we do not have the means to
6050 span any arbitrary stride with an array descriptor. This check
6051 is not needed for the rhs because the function result has to be
6053 seen_array_ref = false;
6054 for (ref = expr1->ref; ref; ref = ref->next)
6056 if (ref->type == REF_ARRAY)
6057 seen_array_ref= true;
6058 else if (ref->type == REF_COMPONENT && seen_array_ref)
6062 /* Check for a dependency. */
6063 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
6064 expr2->value.function.esym,
6065 expr2->value.function.actual,
6069 /* If we have reached here with an intrinsic function, we do not
6070 need a temporary except in the particular case that reallocation
6071 on assignment is active and the lhs is allocatable and a target. */
6072 if (expr2->value.function.isym)
6073 return (gfc_option.flag_realloc_lhs
6074 && sym->attr.allocatable
6075 && sym->attr.target);
6077 /* If the LHS is a dummy, we need a temporary if it is not
6079 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
6082 /* If the lhs has been host_associated, is in common, a pointer or is
6083 a target and the function is not using a RESULT variable, aliasing
6084 can occur and a temporary is needed. */
6085 if ((sym->attr.host_assoc
6086 || sym->attr.in_common
6087 || sym->attr.pointer
6088 || sym->attr.cray_pointee
6089 || sym->attr.target)
6090 && expr2->symtree != NULL
6091 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
6094 /* A PURE function can unconditionally be called without a temporary. */
6095 if (expr2->value.function.esym != NULL
6096 && expr2->value.function.esym->attr.pure)
6099 /* Implicit_pure functions are those which could legally be declared
6101 if (expr2->value.function.esym != NULL
6102 && expr2->value.function.esym->attr.implicit_pure)
6105 if (!sym->attr.use_assoc
6106 && !sym->attr.in_common
6107 && !sym->attr.pointer
6108 && !sym->attr.target
6109 && !sym->attr.cray_pointee
6110 && expr2->value.function.esym)
6112 /* A temporary is not needed if the function is not contained and
6113 the variable is local or host associated and not a pointer or
6115 if (!expr2->value.function.esym->attr.contained)
6118 /* A temporary is not needed if the lhs has never been host
6119 associated and the procedure is contained. */
6120 else if (!sym->attr.host_assoc)
6123 /* A temporary is not needed if the variable is local and not
6124 a pointer, a target or a result. */
6126 && expr2->value.function.esym->ns == sym->ns->parent)
6130 /* Default to temporary use. */
6135 /* Provide the loop info so that the lhs descriptor can be built for
6136 reallocatable assignments from extrinsic function calls. */
6139 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
6142 /* Signal that the function call should not be made by
6143 gfc_conv_loop_setup. */
6144 se->ss->is_alloc_lhs = 1;
6145 gfc_init_loopinfo (loop);
6146 gfc_add_ss_to_loop (loop, *ss);
6147 gfc_add_ss_to_loop (loop, se->ss);
6148 gfc_conv_ss_startstride (loop);
6149 gfc_conv_loop_setup (loop, where);
6150 gfc_copy_loopinfo_to_se (se, loop);
6151 gfc_add_block_to_block (&se->pre, &loop->pre);
6152 gfc_add_block_to_block (&se->pre, &loop->post);
6153 se->ss->is_alloc_lhs = 0;
6157 /* For Assignment to a reallocatable lhs from intrinsic functions,
6158 replace the se.expr (ie. the result) with a temporary descriptor.
6159 Null the data field so that the library allocates space for the
6160 result. Free the data of the original descriptor after the function,
6161 in case it appears in an argument expression and transfer the
6162 result to the original descriptor. */
6165 fcncall_realloc_result (gfc_se *se, int rank)
6173 /* Use the allocation done by the library. Substitute the lhs
6174 descriptor with a copy, whose data field is nulled.*/
6175 desc = build_fold_indirect_ref_loc (input_location, se->expr);
6176 /* Unallocated, the descriptor does not have a dtype. */
6177 tmp = gfc_conv_descriptor_dtype (desc);
6178 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
6179 res_desc = gfc_evaluate_now (desc, &se->pre);
6180 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
6181 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
6183 /* Free the lhs after the function call and copy the result to
6184 the lhs descriptor. */
6185 tmp = gfc_conv_descriptor_data_get (desc);
6186 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
6187 gfc_add_expr_to_block (&se->post, tmp);
6188 gfc_add_modify (&se->post, desc, res_desc);
6190 offset = gfc_index_zero_node;
6191 tmp = gfc_index_one_node;
6192 /* Now reset the bounds from zero based to unity based. */
6193 for (n = 0 ; n < rank; n++)
6195 /* Accumulate the offset. */
6196 offset = fold_build2_loc (input_location, MINUS_EXPR,
6197 gfc_array_index_type,
6199 /* Now do the bounds. */
6200 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
6201 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
6202 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6203 gfc_array_index_type,
6204 tmp, gfc_index_one_node);
6205 gfc_conv_descriptor_lbound_set (&se->post, desc,
6207 gfc_index_one_node);
6208 gfc_conv_descriptor_ubound_set (&se->post, desc,
6209 gfc_rank_cst[n], tmp);
6211 /* The extent for the next contribution to offset. */
6212 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6213 gfc_array_index_type,
6214 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
6215 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
6216 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6217 gfc_array_index_type,
6218 tmp, gfc_index_one_node);
6220 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
6225 /* Try to translate array(:) = func (...), where func is a transformational
6226 array function, without using a temporary. Returns NULL if this isn't the
6230 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
6234 gfc_component *comp = NULL;
6237 if (arrayfunc_assign_needs_temporary (expr1, expr2))
6240 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
6242 gcc_assert (expr2->value.function.isym
6243 || (gfc_is_proc_ptr_comp (expr2, &comp)
6244 && comp && comp->attr.dimension)
6245 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
6246 && expr2->value.function.esym->result->attr.dimension));
6248 ss = gfc_walk_expr (expr1);
6249 gcc_assert (ss != gfc_ss_terminator);
6250 gfc_init_se (&se, NULL);
6251 gfc_start_block (&se.pre);
6252 se.want_pointer = 1;
6254 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
6256 if (expr1->ts.type == BT_DERIVED
6257 && expr1->ts.u.derived->attr.alloc_comp)
6260 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
6262 gfc_add_expr_to_block (&se.pre, tmp);
6265 se.direct_byref = 1;
6266 se.ss = gfc_walk_expr (expr2);
6267 gcc_assert (se.ss != gfc_ss_terminator);
6269 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
6270 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
6271 Clearly, this cannot be done for an allocatable function result, since
6272 the shape of the result is unknown and, in any case, the function must
6273 correctly take care of the reallocation internally. For intrinsic
6274 calls, the array data is freed and the library takes care of allocation.
6275 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
6277 if (gfc_option.flag_realloc_lhs
6278 && gfc_is_reallocatable_lhs (expr1)
6279 && !gfc_expr_attr (expr1).codimension
6280 && !gfc_is_coindexed (expr1)
6281 && !(expr2->value.function.esym
6282 && expr2->value.function.esym->result->attr.allocatable))
6284 if (!expr2->value.function.isym)
6286 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
6287 ss->is_alloc_lhs = 1;
6290 fcncall_realloc_result (&se, expr1->rank);
6293 gfc_conv_function_expr (&se, expr2);
6294 gfc_add_block_to_block (&se.pre, &se.post);
6296 return gfc_finish_block (&se.pre);
6300 /* Try to efficiently translate array(:) = 0. Return NULL if this
6304 gfc_trans_zero_assign (gfc_expr * expr)
6306 tree dest, len, type;
6310 sym = expr->symtree->n.sym;
6311 dest = gfc_get_symbol_decl (sym);
6313 type = TREE_TYPE (dest);
6314 if (POINTER_TYPE_P (type))
6315 type = TREE_TYPE (type);
6316 if (!GFC_ARRAY_TYPE_P (type))
6319 /* Determine the length of the array. */
6320 len = GFC_TYPE_ARRAY_SIZE (type);
6321 if (!len || TREE_CODE (len) != INTEGER_CST)
6324 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6325 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
6326 fold_convert (gfc_array_index_type, tmp));
6328 /* If we are zeroing a local array avoid taking its address by emitting
6330 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
6331 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
6332 dest, build_constructor (TREE_TYPE (dest), NULL));
6334 /* Convert arguments to the correct types. */
6335 dest = fold_convert (pvoid_type_node, dest);
6336 len = fold_convert (size_type_node, len);
6338 /* Construct call to __builtin_memset. */
6339 tmp = build_call_expr_loc (input_location,
6340 builtin_decl_explicit (BUILT_IN_MEMSET),
6341 3, dest, integer_zero_node, len);
6342 return fold_convert (void_type_node, tmp);
6346 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
6347 that constructs the call to __builtin_memcpy. */
6350 gfc_build_memcpy_call (tree dst, tree src, tree len)
6354 /* Convert arguments to the correct types. */
6355 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
6356 dst = gfc_build_addr_expr (pvoid_type_node, dst);
6358 dst = fold_convert (pvoid_type_node, dst);
6360 if (!POINTER_TYPE_P (TREE_TYPE (src)))
6361 src = gfc_build_addr_expr (pvoid_type_node, src);
6363 src = fold_convert (pvoid_type_node, src);
6365 len = fold_convert (size_type_node, len);
6367 /* Construct call to __builtin_memcpy. */
6368 tmp = build_call_expr_loc (input_location,
6369 builtin_decl_explicit (BUILT_IN_MEMCPY),
6371 return fold_convert (void_type_node, tmp);
6375 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
6376 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
6377 source/rhs, both are gfc_full_array_ref_p which have been checked for
6381 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
6383 tree dst, dlen, dtype;
6384 tree src, slen, stype;
6387 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
6388 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
6390 dtype = TREE_TYPE (dst);
6391 if (POINTER_TYPE_P (dtype))
6392 dtype = TREE_TYPE (dtype);
6393 stype = TREE_TYPE (src);
6394 if (POINTER_TYPE_P (stype))
6395 stype = TREE_TYPE (stype);
6397 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
6400 /* Determine the lengths of the arrays. */
6401 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
6402 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
6404 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
6405 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6406 dlen, fold_convert (gfc_array_index_type, tmp));
6408 slen = GFC_TYPE_ARRAY_SIZE (stype);
6409 if (!slen || TREE_CODE (slen) != INTEGER_CST)
6411 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
6412 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6413 slen, fold_convert (gfc_array_index_type, tmp));
6415 /* Sanity check that they are the same. This should always be
6416 the case, as we should already have checked for conformance. */
6417 if (!tree_int_cst_equal (slen, dlen))
6420 return gfc_build_memcpy_call (dst, src, dlen);
6424 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
6425 this can't be done. EXPR1 is the destination/lhs for which
6426 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
6429 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
6431 unsigned HOST_WIDE_INT nelem;
6437 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
6441 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
6442 dtype = TREE_TYPE (dst);
6443 if (POINTER_TYPE_P (dtype))
6444 dtype = TREE_TYPE (dtype);
6445 if (!GFC_ARRAY_TYPE_P (dtype))
6448 /* Determine the lengths of the array. */
6449 len = GFC_TYPE_ARRAY_SIZE (dtype);
6450 if (!len || TREE_CODE (len) != INTEGER_CST)
6453 /* Confirm that the constructor is the same size. */
6454 if (compare_tree_int (len, nelem) != 0)
6457 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
6458 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
6459 fold_convert (gfc_array_index_type, tmp));
6461 stype = gfc_typenode_for_spec (&expr2->ts);
6462 src = gfc_build_constant_array_constructor (expr2, stype);
6464 stype = TREE_TYPE (src);
6465 if (POINTER_TYPE_P (stype))
6466 stype = TREE_TYPE (stype);
6468 return gfc_build_memcpy_call (dst, src, len);
6472 /* Tells whether the expression is to be treated as a variable reference. */
6475 expr_is_variable (gfc_expr *expr)
6479 if (expr->expr_type == EXPR_VARIABLE)
6482 arg = gfc_get_noncopying_intrinsic_argument (expr);
6485 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6486 return expr_is_variable (arg);
6493 /* Is the lhs OK for automatic reallocation? */
6496 is_scalar_reallocatable_lhs (gfc_expr *expr)
6500 /* An allocatable variable with no reference. */
6501 if (expr->symtree->n.sym->attr.allocatable
6505 /* All that can be left are allocatable components. */
6506 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6507 && expr->symtree->n.sym->ts.type != BT_CLASS)
6508 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6511 /* Find an allocatable component ref last. */
6512 for (ref = expr->ref; ref; ref = ref->next)
6513 if (ref->type == REF_COMPONENT
6515 && ref->u.c.component->attr.allocatable)
6522 /* Allocate or reallocate scalar lhs, as necessary. */
6525 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6539 if (!expr1 || expr1->rank)
6542 if (!expr2 || expr2->rank)
6545 /* Since this is a scalar lhs, we can afford to do this. That is,
6546 there is no risk of side effects being repeated. */
6547 gfc_init_se (&lse, NULL);
6548 lse.want_pointer = 1;
6549 gfc_conv_expr (&lse, expr1);
6551 jump_label1 = gfc_build_label_decl (NULL_TREE);
6552 jump_label2 = gfc_build_label_decl (NULL_TREE);
6554 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6555 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6556 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6558 tmp = build3_v (COND_EXPR, cond,
6559 build1_v (GOTO_EXPR, jump_label1),
6560 build_empty_stmt (input_location));
6561 gfc_add_expr_to_block (block, tmp);
6563 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6565 /* Use the rhs string length and the lhs element size. */
6566 size = string_length;
6567 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6568 tmp = TYPE_SIZE_UNIT (tmp);
6569 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6570 TREE_TYPE (tmp), tmp,
6571 fold_convert (TREE_TYPE (tmp), size));
6575 /* Otherwise use the length in bytes of the rhs. */
6576 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6577 size_in_bytes = size;
6580 tmp = build_call_expr_loc (input_location,
6581 builtin_decl_explicit (BUILT_IN_MALLOC),
6583 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6584 gfc_add_modify (block, lse.expr, tmp);
6585 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6587 /* Deferred characters need checking for lhs and rhs string
6588 length. Other deferred parameter variables will have to
6590 tmp = build1_v (GOTO_EXPR, jump_label2);
6591 gfc_add_expr_to_block (block, tmp);
6593 tmp = build1_v (LABEL_EXPR, jump_label1);
6594 gfc_add_expr_to_block (block, tmp);
6596 /* For a deferred length character, reallocate if lengths of lhs and
6597 rhs are different. */
6598 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6600 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6601 expr1->ts.u.cl->backend_decl, size);
6602 /* Jump past the realloc if the lengths are the same. */
6603 tmp = build3_v (COND_EXPR, cond,
6604 build1_v (GOTO_EXPR, jump_label2),
6605 build_empty_stmt (input_location));
6606 gfc_add_expr_to_block (block, tmp);
6607 tmp = build_call_expr_loc (input_location,
6608 builtin_decl_explicit (BUILT_IN_REALLOC),
6609 2, fold_convert (pvoid_type_node, lse.expr),
6611 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6612 gfc_add_modify (block, lse.expr, tmp);
6613 tmp = build1_v (LABEL_EXPR, jump_label2);
6614 gfc_add_expr_to_block (block, tmp);
6616 /* Update the lhs character length. */
6617 size = string_length;
6618 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6623 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6624 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6625 init_flag indicates initialization expressions and dealloc that no
6626 deallocate prior assignment is needed (if in doubt, set true). */
6629 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6635 gfc_ss *lss_section;
6642 bool scalar_to_array;
6647 /* Assignment of the form lhs = rhs. */
6648 gfc_start_block (&block);
6650 gfc_init_se (&lse, NULL);
6651 gfc_init_se (&rse, NULL);
6654 lss = gfc_walk_expr (expr1);
6655 if (gfc_is_reallocatable_lhs (expr1)
6656 && !(expr2->expr_type == EXPR_FUNCTION
6657 && expr2->value.function.isym != NULL))
6658 lss->is_alloc_lhs = 1;
6660 if (lss != gfc_ss_terminator)
6662 /* The assignment needs scalarization. */
6665 /* Find a non-scalar SS from the lhs. */
6666 while (lss_section != gfc_ss_terminator
6667 && lss_section->info->type != GFC_SS_SECTION)
6668 lss_section = lss_section->next;
6670 gcc_assert (lss_section != gfc_ss_terminator);
6672 /* Initialize the scalarizer. */
6673 gfc_init_loopinfo (&loop);
6676 rss = gfc_walk_expr (expr2);
6677 if (rss == gfc_ss_terminator)
6678 /* The rhs is scalar. Add a ss for the expression. */
6679 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6681 /* Associate the SS with the loop. */
6682 gfc_add_ss_to_loop (&loop, lss);
6683 gfc_add_ss_to_loop (&loop, rss);
6685 /* Calculate the bounds of the scalarization. */
6686 gfc_conv_ss_startstride (&loop);
6687 /* Enable loop reversal. */
6688 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6689 loop.reverse[n] = GFC_ENABLE_REVERSE;
6690 /* Resolve any data dependencies in the statement. */
6691 gfc_conv_resolve_dependencies (&loop, lss, rss);
6692 /* Setup the scalarizing loops. */
6693 gfc_conv_loop_setup (&loop, &expr2->where);
6695 /* Setup the gfc_se structures. */
6696 gfc_copy_loopinfo_to_se (&lse, &loop);
6697 gfc_copy_loopinfo_to_se (&rse, &loop);
6700 gfc_mark_ss_chain_used (rss, 1);
6701 if (loop.temp_ss == NULL)
6704 gfc_mark_ss_chain_used (lss, 1);
6708 lse.ss = loop.temp_ss;
6709 gfc_mark_ss_chain_used (lss, 3);
6710 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6713 /* Allow the scalarizer to workshare array assignments. */
6714 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6715 ompws_flags |= OMPWS_SCALARIZER_WS;
6717 /* Start the scalarized loop body. */
6718 gfc_start_scalarized_body (&loop, &body);
6721 gfc_init_block (&body);
6723 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6725 /* Translate the expression. */
6726 gfc_conv_expr (&rse, expr2);
6728 /* Stabilize a string length for temporaries. */
6729 if (expr2->ts.type == BT_CHARACTER)
6730 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6732 string_length = NULL_TREE;
6736 gfc_conv_tmp_array_ref (&lse);
6737 if (expr2->ts.type == BT_CHARACTER)
6738 lse.string_length = string_length;
6741 gfc_conv_expr (&lse, expr1);
6743 /* Assignments of scalar derived types with allocatable components
6744 to arrays must be done with a deep copy and the rhs temporary
6745 must have its components deallocated afterwards. */
6746 scalar_to_array = (expr2->ts.type == BT_DERIVED
6747 && expr2->ts.u.derived->attr.alloc_comp
6748 && !expr_is_variable (expr2)
6749 && !gfc_is_constant_expr (expr2)
6750 && expr1->rank && !expr2->rank);
6751 if (scalar_to_array && dealloc)
6753 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6754 gfc_add_expr_to_block (&loop.post, tmp);
6757 /* For a deferred character length function, the function call must
6758 happen before the (re)allocation of the lhs, otherwise the character
6759 length of the result is not known. */
6760 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6761 || (expr2->expr_type == EXPR_COMPCALL)
6762 || (expr2->expr_type == EXPR_PPC))
6763 && expr2->ts.deferred);
6764 if (gfc_option.flag_realloc_lhs
6765 && expr2->ts.type == BT_CHARACTER
6766 && (def_clen_func || expr2->expr_type == EXPR_OP)
6767 && expr1->ts.deferred)
6768 gfc_add_block_to_block (&block, &rse.pre);
6770 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6771 l_is_temp || init_flag,
6772 expr_is_variable (expr2) || scalar_to_array
6773 || expr2->expr_type == EXPR_ARRAY, dealloc);
6774 gfc_add_expr_to_block (&body, tmp);
6776 if (lss == gfc_ss_terminator)
6778 /* F2003: Add the code for reallocation on assignment. */
6779 if (gfc_option.flag_realloc_lhs
6780 && is_scalar_reallocatable_lhs (expr1))
6781 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6784 /* Use the scalar assignment as is. */
6785 gfc_add_block_to_block (&block, &body);
6789 gcc_assert (lse.ss == gfc_ss_terminator
6790 && rse.ss == gfc_ss_terminator);
6794 gfc_trans_scalarized_loop_boundary (&loop, &body);
6796 /* We need to copy the temporary to the actual lhs. */
6797 gfc_init_se (&lse, NULL);
6798 gfc_init_se (&rse, NULL);
6799 gfc_copy_loopinfo_to_se (&lse, &loop);
6800 gfc_copy_loopinfo_to_se (&rse, &loop);
6802 rse.ss = loop.temp_ss;
6805 gfc_conv_tmp_array_ref (&rse);
6806 gfc_conv_expr (&lse, expr1);
6808 gcc_assert (lse.ss == gfc_ss_terminator
6809 && rse.ss == gfc_ss_terminator);
6811 if (expr2->ts.type == BT_CHARACTER)
6812 rse.string_length = string_length;
6814 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6815 false, false, dealloc);
6816 gfc_add_expr_to_block (&body, tmp);
6819 /* F2003: Allocate or reallocate lhs of allocatable array. */
6820 if (gfc_option.flag_realloc_lhs
6821 && gfc_is_reallocatable_lhs (expr1)
6822 && !gfc_expr_attr (expr1).codimension
6823 && !gfc_is_coindexed (expr1))
6825 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6826 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6827 if (tmp != NULL_TREE)
6828 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6831 /* Generate the copying loops. */
6832 gfc_trans_scalarizing_loops (&loop, &body);
6834 /* Wrap the whole thing up. */
6835 gfc_add_block_to_block (&block, &loop.pre);
6836 gfc_add_block_to_block (&block, &loop.post);
6838 gfc_cleanup_loop (&loop);
6841 return gfc_finish_block (&block);
6845 /* Check whether EXPR is a copyable array. */
6848 copyable_array_p (gfc_expr * expr)
6850 if (expr->expr_type != EXPR_VARIABLE)
6853 /* First check it's an array. */
6854 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6857 if (!gfc_full_array_ref_p (expr->ref, NULL))
6860 /* Next check that it's of a simple enough type. */
6861 switch (expr->ts.type)
6873 return !expr->ts.u.derived->attr.alloc_comp;
6882 /* Translate an assignment. */
6885 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6890 /* Special case a single function returning an array. */
6891 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6893 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6898 /* Special case assigning an array to zero. */
6899 if (copyable_array_p (expr1)
6900 && is_zero_initializer_p (expr2))
6902 tmp = gfc_trans_zero_assign (expr1);
6907 /* Special case copying one array to another. */
6908 if (copyable_array_p (expr1)
6909 && copyable_array_p (expr2)
6910 && gfc_compare_types (&expr1->ts, &expr2->ts)
6911 && !gfc_check_dependency (expr1, expr2, 0))
6913 tmp = gfc_trans_array_copy (expr1, expr2);
6918 /* Special case initializing an array from a constant array constructor. */
6919 if (copyable_array_p (expr1)
6920 && expr2->expr_type == EXPR_ARRAY
6921 && gfc_compare_types (&expr1->ts, &expr2->ts))
6923 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6928 /* Fallback to the scalarizer to generate explicit loops. */
6929 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6933 gfc_trans_init_assign (gfc_code * code)
6935 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6939 gfc_trans_assign (gfc_code * code)
6941 return gfc_trans_assignment (code->expr1, code->expr2, false, true);