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);
306 /* Given a class array declaration and an index, returns the address
307 of the referenced element. */
310 gfc_get_class_array_ref (tree index, tree class_decl)
312 tree data = gfc_class_data_get (class_decl);
313 tree size = gfc_vtable_size_get (class_decl);
314 tree offset = fold_build2_loc (input_location, MULT_EXPR,
315 gfc_array_index_type,
318 data = gfc_conv_descriptor_data_get (data);
319 ptr = fold_convert (pvoid_type_node, data);
320 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
321 return fold_convert (TREE_TYPE (data), ptr);
325 /* Copies one class expression to another, assuming that if either
326 'to' or 'from' are arrays they are packed. Should 'from' be
327 NULL_TREE, the inialization expression for 'to' is used, assuming
328 that the _vptr is set. */
331 gfc_copy_class_to_class (tree from, tree to, tree nelems)
342 stmtblock_t loopbody;
348 if (from != NULL_TREE)
349 fcn = gfc_vtable_copy_get (from);
351 fcn = gfc_vtable_copy_get (to);
353 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
355 if (from != NULL_TREE)
356 from_data = gfc_class_data_get (from);
358 from_data = gfc_vtable_def_init_get (to);
360 to_data = gfc_class_data_get (to);
362 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
364 gfc_init_block (&body);
365 tmp = fold_build2_loc (input_location, MINUS_EXPR,
366 gfc_array_index_type, nelems,
368 nelems = gfc_evaluate_now (tmp, &body);
369 index = gfc_create_var (gfc_array_index_type, "S");
371 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
373 from_ref = gfc_get_class_array_ref (index, from);
374 VEC_safe_push (tree, gc, args, from_ref);
377 VEC_safe_push (tree, gc, args, from_data);
379 to_ref = gfc_get_class_array_ref (index, to);
380 VEC_safe_push (tree, gc, args, to_ref);
382 tmp = build_call_vec (fcn_type, fcn, args);
384 /* Build the body of the loop. */
385 gfc_init_block (&loopbody);
386 gfc_add_expr_to_block (&loopbody, tmp);
388 /* Build the loop and return. */
389 gfc_init_loopinfo (&loop);
391 loop.from[0] = gfc_index_zero_node;
392 loop.loopvar[0] = index;
394 gfc_trans_scalarizing_loops (&loop, &loopbody);
395 gfc_add_block_to_block (&body, &loop.pre);
396 tmp = gfc_finish_block (&body);
400 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
401 VEC_safe_push (tree, gc, args, from_data);
402 VEC_safe_push (tree, gc, args, to_data);
403 tmp = build_call_vec (fcn_type, fcn, args);
410 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
412 gfc_actual_arglist *actual;
417 actual = gfc_get_actual_arglist ();
418 actual->expr = gfc_copy_expr (rhs);
419 actual->next = gfc_get_actual_arglist ();
420 actual->next->expr = gfc_copy_expr (lhs);
421 ppc = gfc_copy_expr (obj);
422 gfc_add_vptr_component (ppc);
423 gfc_add_component_ref (ppc, "_copy");
424 ppc_code = gfc_get_code ();
425 ppc_code->resolved_sym = ppc->symtree->n.sym;
426 /* Although '_copy' is set to be elemental in class.c, it is
427 not staying that way. Find out why, sometime.... */
428 ppc_code->resolved_sym->attr.elemental = 1;
429 ppc_code->ext.actual = actual;
430 ppc_code->expr1 = ppc;
431 ppc_code->op = EXEC_CALL;
432 /* Since '_copy' is elemental, the scalarizer will take care
433 of arrays in gfc_trans_call. */
434 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
435 gfc_free_statements (ppc_code);
439 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
440 A MEMCPY is needed to copy the full data from the default initializer
441 of the dynamic type. */
444 gfc_trans_class_init_assign (gfc_code *code)
448 gfc_se dst,src,memsz;
449 gfc_expr *lhs, *rhs, *sz;
451 gfc_start_block (&block);
453 lhs = gfc_copy_expr (code->expr1);
454 gfc_add_data_component (lhs);
456 rhs = gfc_copy_expr (code->expr1);
457 gfc_add_vptr_component (rhs);
459 /* Make sure that the component backend_decls have been built, which
460 will not have happened if the derived types concerned have not
462 gfc_get_derived_type (rhs->ts.u.derived);
463 gfc_add_def_init_component (rhs);
465 if (code->expr1->ts.type == BT_CLASS
466 && CLASS_DATA (code->expr1)->attr.dimension)
467 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
470 sz = gfc_copy_expr (code->expr1);
471 gfc_add_vptr_component (sz);
472 gfc_add_size_component (sz);
474 gfc_init_se (&dst, NULL);
475 gfc_init_se (&src, NULL);
476 gfc_init_se (&memsz, NULL);
477 gfc_conv_expr (&dst, lhs);
478 gfc_conv_expr (&src, rhs);
479 gfc_conv_expr (&memsz, sz);
480 gfc_add_block_to_block (&block, &src.pre);
481 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
483 gfc_add_expr_to_block (&block, tmp);
485 return gfc_finish_block (&block);
489 /* Translate an assignment to a CLASS object
490 (pointer or ordinary assignment). */
493 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
501 gfc_start_block (&block);
504 while (ref && ref->next)
507 /* Class valued proc_pointer assignments do not need any further
509 if (ref && ref->type == REF_COMPONENT
510 && ref->u.c.component->attr.proc_pointer
511 && expr2->expr_type == EXPR_VARIABLE
512 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
513 && op == EXEC_POINTER_ASSIGN)
516 if (expr2->ts.type != BT_CLASS)
518 /* Insert an additional assignment which sets the '_vptr' field. */
519 gfc_symbol *vtab = NULL;
522 lhs = gfc_copy_expr (expr1);
523 gfc_add_vptr_component (lhs);
525 if (expr2->ts.type == BT_DERIVED)
526 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
527 else if (expr2->expr_type == EXPR_NULL)
528 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
531 rhs = gfc_get_expr ();
532 rhs->expr_type = EXPR_VARIABLE;
533 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
537 tmp = gfc_trans_pointer_assignment (lhs, rhs);
538 gfc_add_expr_to_block (&block, tmp);
543 else if (CLASS_DATA (expr2)->attr.dimension)
545 /* Insert an additional assignment which sets the '_vptr' field. */
546 lhs = gfc_copy_expr (expr1);
547 gfc_add_vptr_component (lhs);
549 rhs = gfc_copy_expr (expr2);
550 gfc_add_vptr_component (rhs);
552 tmp = gfc_trans_pointer_assignment (lhs, rhs);
553 gfc_add_expr_to_block (&block, tmp);
559 /* Do the actual CLASS assignment. */
560 if (expr2->ts.type == BT_CLASS
561 && !CLASS_DATA (expr2)->attr.dimension)
564 gfc_add_data_component (expr1);
568 if (op == EXEC_ASSIGN)
569 tmp = gfc_trans_assignment (expr1, expr2, false, true);
570 else if (op == EXEC_POINTER_ASSIGN)
571 tmp = gfc_trans_pointer_assignment (expr1, expr2);
575 gfc_add_expr_to_block (&block, tmp);
577 return gfc_finish_block (&block);
581 /* End of prototype trans-class.c */
584 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
585 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
588 /* Copy the scalarization loop variables. */
591 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
594 dest->loop = src->loop;
598 /* Initialize a simple expression holder.
600 Care must be taken when multiple se are created with the same parent.
601 The child se must be kept in sync. The easiest way is to delay creation
602 of a child se until after after the previous se has been translated. */
605 gfc_init_se (gfc_se * se, gfc_se * parent)
607 memset (se, 0, sizeof (gfc_se));
608 gfc_init_block (&se->pre);
609 gfc_init_block (&se->post);
614 gfc_copy_se_loopvars (se, parent);
618 /* Advances to the next SS in the chain. Use this rather than setting
619 se->ss = se->ss->next because all the parents needs to be kept in sync.
623 gfc_advance_se_ss_chain (gfc_se * se)
628 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
631 /* Walk down the parent chain. */
634 /* Simple consistency check. */
635 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
636 || p->parent->ss->nested_ss == p->ss);
638 /* If we were in a nested loop, the next scalarized expression can be
639 on the parent ss' next pointer. Thus we should not take the next
640 pointer blindly, but rather go up one nest level as long as next
641 is the end of chain. */
643 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
653 /* Ensures the result of the expression as either a temporary variable
654 or a constant so that it can be used repeatedly. */
657 gfc_make_safe_expr (gfc_se * se)
661 if (CONSTANT_CLASS_P (se->expr))
664 /* We need a temporary for this result. */
665 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
666 gfc_add_modify (&se->pre, var, se->expr);
671 /* Return an expression which determines if a dummy parameter is present.
672 Also used for arguments to procedures with multiple entry points. */
675 gfc_conv_expr_present (gfc_symbol * sym)
679 gcc_assert (sym->attr.dummy);
681 decl = gfc_get_symbol_decl (sym);
682 if (TREE_CODE (decl) != PARM_DECL)
684 /* Array parameters use a temporary descriptor, we want the real
686 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
687 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
688 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
691 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
692 fold_convert (TREE_TYPE (decl), null_pointer_node));
694 /* Fortran 2008 allows to pass null pointers and non-associated pointers
695 as actual argument to denote absent dummies. For array descriptors,
696 we thus also need to check the array descriptor. */
697 if (!sym->attr.pointer && !sym->attr.allocatable
698 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
699 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
702 tmp = build_fold_indirect_ref_loc (input_location, decl);
703 tmp = gfc_conv_array_data (tmp);
704 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
705 fold_convert (TREE_TYPE (tmp), null_pointer_node));
706 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
707 boolean_type_node, cond, tmp);
714 /* Converts a missing, dummy argument into a null or zero. */
717 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
722 present = gfc_conv_expr_present (arg->symtree->n.sym);
726 /* Create a temporary and convert it to the correct type. */
727 tmp = gfc_get_int_type (kind);
728 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
731 /* Test for a NULL value. */
732 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
733 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
734 tmp = gfc_evaluate_now (tmp, &se->pre);
735 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
739 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
741 build_zero_cst (TREE_TYPE (se->expr)));
742 tmp = gfc_evaluate_now (tmp, &se->pre);
746 if (ts.type == BT_CHARACTER)
748 tmp = build_int_cst (gfc_charlen_type_node, 0);
749 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
750 present, se->string_length, tmp);
751 tmp = gfc_evaluate_now (tmp, &se->pre);
752 se->string_length = tmp;
758 /* Get the character length of an expression, looking through gfc_refs
762 gfc_get_expr_charlen (gfc_expr *e)
767 gcc_assert (e->expr_type == EXPR_VARIABLE
768 && e->ts.type == BT_CHARACTER);
770 length = NULL; /* To silence compiler warning. */
772 if (is_subref_array (e) && e->ts.u.cl->length)
775 gfc_init_se (&tmpse, NULL);
776 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
777 e->ts.u.cl->backend_decl = tmpse.expr;
781 /* First candidate: if the variable is of type CHARACTER, the
782 expression's length could be the length of the character
784 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
785 length = e->symtree->n.sym->ts.u.cl->backend_decl;
787 /* Look through the reference chain for component references. */
788 for (r = e->ref; r; r = r->next)
793 if (r->u.c.component->ts.type == BT_CHARACTER)
794 length = r->u.c.component->ts.u.cl->backend_decl;
802 /* We should never got substring references here. These will be
803 broken down by the scalarizer. */
809 gcc_assert (length != NULL);
814 /* Return for an expression the backend decl of the coarray. */
817 get_tree_for_caf_expr (gfc_expr *expr)
819 tree caf_decl = NULL_TREE;
822 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
823 if (expr->symtree->n.sym->attr.codimension)
824 caf_decl = expr->symtree->n.sym->backend_decl;
826 for (ref = expr->ref; ref; ref = ref->next)
827 if (ref->type == REF_COMPONENT)
829 gfc_component *comp = ref->u.c.component;
830 if (comp->attr.pointer || comp->attr.allocatable)
831 caf_decl = NULL_TREE;
832 if (comp->attr.codimension)
833 caf_decl = comp->backend_decl;
836 gcc_assert (caf_decl != NULL_TREE);
841 /* For each character array constructor subexpression without a ts.u.cl->length,
842 replace it by its first element (if there aren't any elements, the length
843 should already be set to zero). */
846 flatten_array_ctors_without_strlen (gfc_expr* e)
848 gfc_actual_arglist* arg;
854 switch (e->expr_type)
858 flatten_array_ctors_without_strlen (e->value.op.op1);
859 flatten_array_ctors_without_strlen (e->value.op.op2);
863 /* TODO: Implement as with EXPR_FUNCTION when needed. */
867 for (arg = e->value.function.actual; arg; arg = arg->next)
868 flatten_array_ctors_without_strlen (arg->expr);
873 /* We've found what we're looking for. */
874 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
879 gcc_assert (e->value.constructor);
881 c = gfc_constructor_first (e->value.constructor);
885 flatten_array_ctors_without_strlen (new_expr);
886 gfc_replace_expr (e, new_expr);
890 /* Otherwise, fall through to handle constructor elements. */
892 for (c = gfc_constructor_first (e->value.constructor);
893 c; c = gfc_constructor_next (c))
894 flatten_array_ctors_without_strlen (c->expr);
904 /* Generate code to initialize a string length variable. Returns the
905 value. For array constructors, cl->length might be NULL and in this case,
906 the first element of the constructor is needed. expr is the original
907 expression so we can access it but can be NULL if this is not needed. */
910 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
914 gfc_init_se (&se, NULL);
918 && TREE_CODE (cl->backend_decl) == VAR_DECL)
921 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
922 "flatten" array constructors by taking their first element; all elements
923 should be the same length or a cl->length should be present. */
928 expr_flat = gfc_copy_expr (expr);
929 flatten_array_ctors_without_strlen (expr_flat);
930 gfc_resolve_expr (expr_flat);
932 gfc_conv_expr (&se, expr_flat);
933 gfc_add_block_to_block (pblock, &se.pre);
934 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
936 gfc_free_expr (expr_flat);
940 /* Convert cl->length. */
942 gcc_assert (cl->length);
944 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
945 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
946 se.expr, build_int_cst (gfc_charlen_type_node, 0));
947 gfc_add_block_to_block (pblock, &se.pre);
949 if (cl->backend_decl)
950 gfc_add_modify (pblock, cl->backend_decl, se.expr);
952 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
957 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
958 const char *name, locus *where)
967 type = gfc_get_character_type (kind, ref->u.ss.length);
968 type = build_pointer_type (type);
970 gfc_init_se (&start, se);
971 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
972 gfc_add_block_to_block (&se->pre, &start.pre);
974 if (integer_onep (start.expr))
975 gfc_conv_string_parameter (se);
980 /* Avoid multiple evaluation of substring start. */
981 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
982 start.expr = gfc_evaluate_now (start.expr, &se->pre);
984 /* Change the start of the string. */
985 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
988 tmp = build_fold_indirect_ref_loc (input_location,
990 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
991 se->expr = gfc_build_addr_expr (type, tmp);
994 /* Length = end + 1 - start. */
995 gfc_init_se (&end, se);
996 if (ref->u.ss.end == NULL)
997 end.expr = se->string_length;
1000 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
1001 gfc_add_block_to_block (&se->pre, &end.pre);
1005 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
1006 end.expr = gfc_evaluate_now (end.expr, &se->pre);
1008 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1010 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
1011 boolean_type_node, start.expr,
1014 /* Check lower bound. */
1015 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1017 build_int_cst (gfc_charlen_type_node, 1));
1018 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1019 boolean_type_node, nonempty, fault);
1021 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
1022 "is less than one", name);
1024 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
1025 "is less than one");
1026 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
1027 fold_convert (long_integer_type_node,
1031 /* Check upper bound. */
1032 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1033 end.expr, se->string_length);
1034 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1035 boolean_type_node, nonempty, fault);
1037 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
1038 "exceeds string length (%%ld)", name);
1040 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
1041 "exceeds string length (%%ld)");
1042 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
1043 fold_convert (long_integer_type_node, end.expr),
1044 fold_convert (long_integer_type_node,
1045 se->string_length));
1049 /* If the start and end expressions are equal, the length is one. */
1051 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
1052 tmp = build_int_cst (gfc_charlen_type_node, 1);
1055 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
1056 end.expr, start.expr);
1057 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
1058 build_int_cst (gfc_charlen_type_node, 1), tmp);
1059 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
1060 tmp, build_int_cst (gfc_charlen_type_node, 0));
1063 se->string_length = tmp;
1067 /* Convert a derived type component reference. */
1070 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
1077 c = ref->u.c.component;
1079 gcc_assert (c->backend_decl);
1081 field = c->backend_decl;
1082 gcc_assert (TREE_CODE (field) == FIELD_DECL);
1085 /* Components can correspond to fields of different containing
1086 types, as components are created without context, whereas
1087 a concrete use of a component has the type of decl as context.
1088 So, if the type doesn't match, we search the corresponding
1089 FIELD_DECL in the parent type. To not waste too much time
1090 we cache this result in norestrict_decl. */
1092 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
1094 tree f2 = c->norestrict_decl;
1095 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
1096 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
1097 if (TREE_CODE (f2) == FIELD_DECL
1098 && DECL_NAME (f2) == DECL_NAME (field))
1101 c->norestrict_decl = f2;
1104 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1105 decl, field, NULL_TREE);
1109 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
1111 tmp = c->ts.u.cl->backend_decl;
1112 /* Components must always be constant length. */
1113 gcc_assert (tmp && INTEGER_CST_P (tmp));
1114 se->string_length = tmp;
1117 if (((c->attr.pointer || c->attr.allocatable)
1118 && (!c->attr.dimension && !c->attr.codimension)
1119 && c->ts.type != BT_CHARACTER)
1120 || c->attr.proc_pointer)
1121 se->expr = build_fold_indirect_ref_loc (input_location,
1126 /* This function deals with component references to components of the
1127 parent type for derived type extensons. */
1129 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
1137 c = ref->u.c.component;
1139 /* Return if the component is not in the parent type. */
1140 for (cmp = dt->components; cmp; cmp = cmp->next)
1141 if (strcmp (c->name, cmp->name) == 0)
1144 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1145 parent.type = REF_COMPONENT;
1147 parent.u.c.sym = dt;
1148 parent.u.c.component = dt->components;
1150 if (dt->backend_decl == NULL)
1151 gfc_get_derived_type (dt);
1153 /* Build the reference and call self. */
1154 gfc_conv_component_ref (se, &parent);
1155 parent.u.c.sym = dt->components->ts.u.derived;
1156 parent.u.c.component = c;
1157 conv_parent_component_references (se, &parent);
1160 /* Return the contents of a variable. Also handles reference/pointer
1161 variables (all Fortran pointer references are implicit). */
1164 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
1169 tree parent_decl = NULL_TREE;
1172 bool alternate_entry;
1175 sym = expr->symtree->n.sym;
1179 gfc_ss_info *ss_info = ss->info;
1181 /* Check that something hasn't gone horribly wrong. */
1182 gcc_assert (ss != gfc_ss_terminator);
1183 gcc_assert (ss_info->expr == expr);
1185 /* A scalarized term. We already know the descriptor. */
1186 se->expr = ss_info->data.array.descriptor;
1187 se->string_length = ss_info->string_length;
1188 for (ref = ss_info->data.array.ref; ref; ref = ref->next)
1189 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
1194 tree se_expr = NULL_TREE;
1196 se->expr = gfc_get_symbol_decl (sym);
1198 /* Deal with references to a parent results or entries by storing
1199 the current_function_decl and moving to the parent_decl. */
1200 return_value = sym->attr.function && sym->result == sym;
1201 alternate_entry = sym->attr.function && sym->attr.entry
1202 && sym->result == sym;
1203 entry_master = sym->attr.result
1204 && sym->ns->proc_name->attr.entry_master
1205 && !gfc_return_by_reference (sym->ns->proc_name);
1206 if (current_function_decl)
1207 parent_decl = DECL_CONTEXT (current_function_decl);
1209 if ((se->expr == parent_decl && return_value)
1210 || (sym->ns && sym->ns->proc_name
1212 && sym->ns->proc_name->backend_decl == parent_decl
1213 && (alternate_entry || entry_master)))
1218 /* Special case for assigning the return value of a function.
1219 Self recursive functions must have an explicit return value. */
1220 if (return_value && (se->expr == current_function_decl || parent_flag))
1221 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1223 /* Similarly for alternate entry points. */
1224 else if (alternate_entry
1225 && (sym->ns->proc_name->backend_decl == current_function_decl
1228 gfc_entry_list *el = NULL;
1230 for (el = sym->ns->entries; el; el = el->next)
1233 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1238 else if (entry_master
1239 && (sym->ns->proc_name->backend_decl == current_function_decl
1241 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1246 /* Procedure actual arguments. */
1247 else if (sym->attr.flavor == FL_PROCEDURE
1248 && se->expr != current_function_decl)
1250 if (!sym->attr.dummy && !sym->attr.proc_pointer)
1252 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
1253 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1259 /* Dereference the expression, where needed. Since characters
1260 are entirely different from other types, they are treated
1262 if (sym->ts.type == BT_CHARACTER)
1264 /* Dereference character pointer dummy arguments
1266 if ((sym->attr.pointer || sym->attr.allocatable)
1268 || sym->attr.function
1269 || sym->attr.result))
1270 se->expr = build_fold_indirect_ref_loc (input_location,
1274 else if (!sym->attr.value)
1276 /* Dereference non-character scalar dummy arguments. */
1277 if (sym->attr.dummy && !sym->attr.dimension
1278 && !(sym->attr.codimension && sym->attr.allocatable))
1279 se->expr = build_fold_indirect_ref_loc (input_location,
1282 /* Dereference scalar hidden result. */
1283 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
1284 && (sym->attr.function || sym->attr.result)
1285 && !sym->attr.dimension && !sym->attr.pointer
1286 && !sym->attr.always_explicit)
1287 se->expr = build_fold_indirect_ref_loc (input_location,
1290 /* Dereference non-character pointer variables.
1291 These must be dummies, results, or scalars. */
1292 if ((sym->attr.pointer || sym->attr.allocatable
1293 || gfc_is_associate_pointer (sym))
1295 || sym->attr.function
1297 || (!sym->attr.dimension
1298 && (!sym->attr.codimension || !sym->attr.allocatable))))
1299 se->expr = build_fold_indirect_ref_loc (input_location,
1306 /* For character variables, also get the length. */
1307 if (sym->ts.type == BT_CHARACTER)
1309 /* If the character length of an entry isn't set, get the length from
1310 the master function instead. */
1311 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
1312 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
1314 se->string_length = sym->ts.u.cl->backend_decl;
1315 gcc_assert (se->string_length);
1323 /* Return the descriptor if that's what we want and this is an array
1324 section reference. */
1325 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
1327 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1328 /* Return the descriptor for array pointers and allocations. */
1329 if (se->want_pointer
1330 && ref->next == NULL && (se->descriptor_only))
1333 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
1334 /* Return a pointer to an element. */
1338 if (ref->u.c.sym->attr.extension)
1339 conv_parent_component_references (se, ref);
1341 gfc_conv_component_ref (se, ref);
1346 gfc_conv_substring (se, ref, expr->ts.kind,
1347 expr->symtree->name, &expr->where);
1356 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1358 if (se->want_pointer)
1360 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
1361 gfc_conv_string_parameter (se);
1363 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1368 /* Unary ops are easy... Or they would be if ! was a valid op. */
1371 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
1376 gcc_assert (expr->ts.type != BT_CHARACTER);
1377 /* Initialize the operand. */
1378 gfc_init_se (&operand, se);
1379 gfc_conv_expr_val (&operand, expr->value.op.op1);
1380 gfc_add_block_to_block (&se->pre, &operand.pre);
1382 type = gfc_typenode_for_spec (&expr->ts);
1384 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1385 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1386 All other unary operators have an equivalent GIMPLE unary operator. */
1387 if (code == TRUTH_NOT_EXPR)
1388 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
1389 build_int_cst (type, 0));
1391 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
1395 /* Expand power operator to optimal multiplications when a value is raised
1396 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1397 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1398 Programming", 3rd Edition, 1998. */
1400 /* This code is mostly duplicated from expand_powi in the backend.
1401 We establish the "optimal power tree" lookup table with the defined size.
1402 The items in the table are the exponents used to calculate the index
1403 exponents. Any integer n less than the value can get an "addition chain",
1404 with the first node being one. */
1405 #define POWI_TABLE_SIZE 256
1407 /* The table is from builtins.c. */
1408 static const unsigned char powi_table[POWI_TABLE_SIZE] =
1410 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1411 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1412 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1413 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1414 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1415 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1416 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1417 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1418 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1419 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1420 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1421 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1422 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1423 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1424 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1425 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1426 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1427 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1428 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1429 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1430 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1431 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1432 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1433 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1434 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1435 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1436 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1437 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1438 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1439 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1440 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1441 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1444 /* If n is larger than lookup table's max index, we use the "window
1446 #define POWI_WINDOW_SIZE 3
1448 /* Recursive function to expand the power operator. The temporary
1449 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1451 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
1458 if (n < POWI_TABLE_SIZE)
1463 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
1464 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
1468 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
1469 op0 = gfc_conv_powi (se, n - digit, tmpvar);
1470 op1 = gfc_conv_powi (se, digit, tmpvar);
1474 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
1478 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
1479 tmp = gfc_evaluate_now (tmp, &se->pre);
1481 if (n < POWI_TABLE_SIZE)
1488 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1489 return 1. Else return 0 and a call to runtime library functions
1490 will have to be built. */
1492 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
1497 tree vartmp[POWI_TABLE_SIZE];
1499 unsigned HOST_WIDE_INT n;
1502 /* If exponent is too large, we won't expand it anyway, so don't bother
1503 with large integer values. */
1504 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
1507 m = double_int_to_shwi (TREE_INT_CST (rhs));
1508 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1509 of the asymmetric range of the integer type. */
1510 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
1512 type = TREE_TYPE (lhs);
1513 sgn = tree_int_cst_sgn (rhs);
1515 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
1516 || optimize_size) && (m > 2 || m < -1))
1522 se->expr = gfc_build_const (type, integer_one_node);
1526 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1527 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
1529 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1530 lhs, build_int_cst (TREE_TYPE (lhs), -1));
1531 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1532 lhs, build_int_cst (TREE_TYPE (lhs), 1));
1535 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1538 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1539 boolean_type_node, tmp, cond);
1540 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1541 tmp, build_int_cst (type, 1),
1542 build_int_cst (type, 0));
1546 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1547 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
1548 build_int_cst (type, -1),
1549 build_int_cst (type, 0));
1550 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1551 cond, build_int_cst (type, 1), tmp);
1555 memset (vartmp, 0, sizeof (vartmp));
1559 tmp = gfc_build_const (type, integer_one_node);
1560 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1564 se->expr = gfc_conv_powi (se, n, vartmp);
1570 /* Power op (**). Constant integer exponent has special handling. */
1573 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1575 tree gfc_int4_type_node;
1578 int res_ikind_1, res_ikind_2;
1583 gfc_init_se (&lse, se);
1584 gfc_conv_expr_val (&lse, expr->value.op.op1);
1585 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1586 gfc_add_block_to_block (&se->pre, &lse.pre);
1588 gfc_init_se (&rse, se);
1589 gfc_conv_expr_val (&rse, expr->value.op.op2);
1590 gfc_add_block_to_block (&se->pre, &rse.pre);
1592 if (expr->value.op.op2->ts.type == BT_INTEGER
1593 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1594 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1597 gfc_int4_type_node = gfc_get_int_type (4);
1599 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1600 library routine. But in the end, we have to convert the result back
1601 if this case applies -- with res_ikind_K, we keep track whether operand K
1602 falls into this case. */
1606 kind = expr->value.op.op1->ts.kind;
1607 switch (expr->value.op.op2->ts.type)
1610 ikind = expr->value.op.op2->ts.kind;
1615 rse.expr = convert (gfc_int4_type_node, rse.expr);
1616 res_ikind_2 = ikind;
1638 if (expr->value.op.op1->ts.type == BT_INTEGER)
1640 lse.expr = convert (gfc_int4_type_node, lse.expr);
1667 switch (expr->value.op.op1->ts.type)
1670 if (kind == 3) /* Case 16 was not handled properly above. */
1672 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1676 /* Use builtins for real ** int4. */
1682 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
1686 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
1690 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1694 /* Use the __builtin_powil() only if real(kind=16) is
1695 actually the C long double type. */
1696 if (!gfc_real16_is_float128)
1697 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1705 /* If we don't have a good builtin for this, go for the
1706 library function. */
1708 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1712 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1721 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1725 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1733 se->expr = build_call_expr_loc (input_location,
1734 fndecl, 2, lse.expr, rse.expr);
1736 /* Convert the result back if it is of wrong integer kind. */
1737 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1739 /* We want the maximum of both operand kinds as result. */
1740 if (res_ikind_1 < res_ikind_2)
1741 res_ikind_1 = res_ikind_2;
1742 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1747 /* Generate code to allocate a string temporary. */
1750 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1755 if (gfc_can_put_var_on_stack (len))
1757 /* Create a temporary variable to hold the result. */
1758 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1759 gfc_charlen_type_node, len,
1760 build_int_cst (gfc_charlen_type_node, 1));
1761 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1763 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1764 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1766 tmp = build_array_type (TREE_TYPE (type), tmp);
1768 var = gfc_create_var (tmp, "str");
1769 var = gfc_build_addr_expr (type, var);
1773 /* Allocate a temporary to hold the result. */
1774 var = gfc_create_var (type, "pstr");
1775 tmp = gfc_call_malloc (&se->pre, type,
1776 fold_build2_loc (input_location, MULT_EXPR,
1777 TREE_TYPE (len), len,
1778 fold_convert (TREE_TYPE (len),
1779 TYPE_SIZE (type))));
1780 gfc_add_modify (&se->pre, var, tmp);
1782 /* Free the temporary afterwards. */
1783 tmp = gfc_call_free (convert (pvoid_type_node, var));
1784 gfc_add_expr_to_block (&se->post, tmp);
1791 /* Handle a string concatenation operation. A temporary will be allocated to
1795 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1798 tree len, type, var, tmp, fndecl;
1800 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1801 && expr->value.op.op2->ts.type == BT_CHARACTER);
1802 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1804 gfc_init_se (&lse, se);
1805 gfc_conv_expr (&lse, expr->value.op.op1);
1806 gfc_conv_string_parameter (&lse);
1807 gfc_init_se (&rse, se);
1808 gfc_conv_expr (&rse, expr->value.op.op2);
1809 gfc_conv_string_parameter (&rse);
1811 gfc_add_block_to_block (&se->pre, &lse.pre);
1812 gfc_add_block_to_block (&se->pre, &rse.pre);
1814 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1815 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1816 if (len == NULL_TREE)
1818 len = fold_build2_loc (input_location, PLUS_EXPR,
1819 TREE_TYPE (lse.string_length),
1820 lse.string_length, rse.string_length);
1823 type = build_pointer_type (type);
1825 var = gfc_conv_string_tmp (se, type, len);
1827 /* Do the actual concatenation. */
1828 if (expr->ts.kind == 1)
1829 fndecl = gfor_fndecl_concat_string;
1830 else if (expr->ts.kind == 4)
1831 fndecl = gfor_fndecl_concat_string_char4;
1835 tmp = build_call_expr_loc (input_location,
1836 fndecl, 6, len, var, lse.string_length, lse.expr,
1837 rse.string_length, rse.expr);
1838 gfc_add_expr_to_block (&se->pre, tmp);
1840 /* Add the cleanup for the operands. */
1841 gfc_add_block_to_block (&se->pre, &rse.post);
1842 gfc_add_block_to_block (&se->pre, &lse.post);
1845 se->string_length = len;
1848 /* Translates an op expression. Common (binary) cases are handled by this
1849 function, others are passed on. Recursion is used in either case.
1850 We use the fact that (op1.ts == op2.ts) (except for the power
1852 Operators need no special handling for scalarized expressions as long as
1853 they call gfc_conv_simple_val to get their operands.
1854 Character strings get special handling. */
1857 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1859 enum tree_code code;
1868 switch (expr->value.op.op)
1870 case INTRINSIC_PARENTHESES:
1871 if ((expr->ts.type == BT_REAL
1872 || expr->ts.type == BT_COMPLEX)
1873 && gfc_option.flag_protect_parens)
1875 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1876 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1881 case INTRINSIC_UPLUS:
1882 gfc_conv_expr (se, expr->value.op.op1);
1885 case INTRINSIC_UMINUS:
1886 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1890 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1893 case INTRINSIC_PLUS:
1897 case INTRINSIC_MINUS:
1901 case INTRINSIC_TIMES:
1905 case INTRINSIC_DIVIDE:
1906 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1907 an integer, we must round towards zero, so we use a
1909 if (expr->ts.type == BT_INTEGER)
1910 code = TRUNC_DIV_EXPR;
1915 case INTRINSIC_POWER:
1916 gfc_conv_power_op (se, expr);
1919 case INTRINSIC_CONCAT:
1920 gfc_conv_concat_op (se, expr);
1924 code = TRUTH_ANDIF_EXPR;
1929 code = TRUTH_ORIF_EXPR;
1933 /* EQV and NEQV only work on logicals, but since we represent them
1934 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1936 case INTRINSIC_EQ_OS:
1944 case INTRINSIC_NE_OS:
1945 case INTRINSIC_NEQV:
1952 case INTRINSIC_GT_OS:
1959 case INTRINSIC_GE_OS:
1966 case INTRINSIC_LT_OS:
1973 case INTRINSIC_LE_OS:
1979 case INTRINSIC_USER:
1980 case INTRINSIC_ASSIGN:
1981 /* These should be converted into function calls by the frontend. */
1985 fatal_error ("Unknown intrinsic op");
1989 /* The only exception to this is **, which is handled separately anyway. */
1990 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1992 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1996 gfc_init_se (&lse, se);
1997 gfc_conv_expr (&lse, expr->value.op.op1);
1998 gfc_add_block_to_block (&se->pre, &lse.pre);
2001 gfc_init_se (&rse, se);
2002 gfc_conv_expr (&rse, expr->value.op.op2);
2003 gfc_add_block_to_block (&se->pre, &rse.pre);
2007 gfc_conv_string_parameter (&lse);
2008 gfc_conv_string_parameter (&rse);
2010 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
2011 rse.string_length, rse.expr,
2012 expr->value.op.op1->ts.kind,
2014 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
2015 gfc_add_block_to_block (&lse.post, &rse.post);
2018 type = gfc_typenode_for_spec (&expr->ts);
2022 /* The result of logical ops is always boolean_type_node. */
2023 tmp = fold_build2_loc (input_location, code, boolean_type_node,
2024 lse.expr, rse.expr);
2025 se->expr = convert (type, tmp);
2028 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
2030 /* Add the post blocks. */
2031 gfc_add_block_to_block (&se->post, &rse.post);
2032 gfc_add_block_to_block (&se->post, &lse.post);
2035 /* If a string's length is one, we convert it to a single character. */
2038 gfc_string_to_single_character (tree len, tree str, int kind)
2041 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
2042 || !POINTER_TYPE_P (TREE_TYPE (str)))
2045 if (TREE_INT_CST_LOW (len) == 1)
2047 str = fold_convert (gfc_get_pchar_type (kind), str);
2048 return build_fold_indirect_ref_loc (input_location, str);
2052 && TREE_CODE (str) == ADDR_EXPR
2053 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2054 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2055 && array_ref_low_bound (TREE_OPERAND (str, 0))
2056 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2057 && TREE_INT_CST_LOW (len) > 1
2058 && TREE_INT_CST_LOW (len)
2059 == (unsigned HOST_WIDE_INT)
2060 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2062 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
2063 ret = build_fold_indirect_ref_loc (input_location, ret);
2064 if (TREE_CODE (ret) == INTEGER_CST)
2066 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2067 int i, length = TREE_STRING_LENGTH (string_cst);
2068 const char *ptr = TREE_STRING_POINTER (string_cst);
2070 for (i = 1; i < length; i++)
2083 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
2086 if (sym->backend_decl)
2088 /* This becomes the nominal_type in
2089 function.c:assign_parm_find_data_types. */
2090 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
2091 /* This becomes the passed_type in
2092 function.c:assign_parm_find_data_types. C promotes char to
2093 integer for argument passing. */
2094 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
2096 DECL_BY_REFERENCE (sym->backend_decl) = 0;
2101 /* If we have a constant character expression, make it into an
2103 if ((*expr)->expr_type == EXPR_CONSTANT)
2108 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
2109 (int)(*expr)->value.character.string[0]);
2110 if ((*expr)->ts.kind != gfc_c_int_kind)
2112 /* The expr needs to be compatible with a C int. If the
2113 conversion fails, then the 2 causes an ICE. */
2114 ts.type = BT_INTEGER;
2115 ts.kind = gfc_c_int_kind;
2116 gfc_convert_type (*expr, &ts, 2);
2119 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
2121 if ((*expr)->ref == NULL)
2123 se->expr = gfc_string_to_single_character
2124 (build_int_cst (integer_type_node, 1),
2125 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2127 ((*expr)->symtree->n.sym)),
2132 gfc_conv_variable (se, *expr);
2133 se->expr = gfc_string_to_single_character
2134 (build_int_cst (integer_type_node, 1),
2135 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2143 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2144 if STR is a string literal, otherwise return -1. */
2147 gfc_optimize_len_trim (tree len, tree str, int kind)
2150 && TREE_CODE (str) == ADDR_EXPR
2151 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2152 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2153 && array_ref_low_bound (TREE_OPERAND (str, 0))
2154 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2155 && TREE_INT_CST_LOW (len) >= 1
2156 && TREE_INT_CST_LOW (len)
2157 == (unsigned HOST_WIDE_INT)
2158 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2160 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
2161 folded = build_fold_indirect_ref_loc (input_location, folded);
2162 if (TREE_CODE (folded) == INTEGER_CST)
2164 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2165 int length = TREE_STRING_LENGTH (string_cst);
2166 const char *ptr = TREE_STRING_POINTER (string_cst);
2168 for (; length > 0; length--)
2169 if (ptr[length - 1] != ' ')
2178 /* Compare two strings. If they are all single characters, the result is the
2179 subtraction of them. Otherwise, we build a library call. */
2182 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
2183 enum tree_code code)
2189 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
2190 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
2192 sc1 = gfc_string_to_single_character (len1, str1, kind);
2193 sc2 = gfc_string_to_single_character (len2, str2, kind);
2195 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
2197 /* Deal with single character specially. */
2198 sc1 = fold_convert (integer_type_node, sc1);
2199 sc2 = fold_convert (integer_type_node, sc2);
2200 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
2204 if ((code == EQ_EXPR || code == NE_EXPR)
2206 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
2208 /* If one string is a string literal with LEN_TRIM longer
2209 than the length of the second string, the strings
2211 int len = gfc_optimize_len_trim (len1, str1, kind);
2212 if (len > 0 && compare_tree_int (len2, len) < 0)
2213 return integer_one_node;
2214 len = gfc_optimize_len_trim (len2, str2, kind);
2215 if (len > 0 && compare_tree_int (len1, len) < 0)
2216 return integer_one_node;
2219 /* Build a call for the comparison. */
2221 fndecl = gfor_fndecl_compare_string;
2223 fndecl = gfor_fndecl_compare_string_char4;
2227 return build_call_expr_loc (input_location, fndecl, 4,
2228 len1, str1, len2, str2);
2232 /* Return the backend_decl for a procedure pointer component. */
2235 get_proc_ptr_comp (gfc_expr *e)
2241 gfc_init_se (&comp_se, NULL);
2242 e2 = gfc_copy_expr (e);
2243 /* We have to restore the expr type later so that gfc_free_expr frees
2244 the exact same thing that was allocated.
2245 TODO: This is ugly. */
2246 old_type = e2->expr_type;
2247 e2->expr_type = EXPR_VARIABLE;
2248 gfc_conv_expr (&comp_se, e2);
2249 e2->expr_type = old_type;
2251 return build_fold_addr_expr_loc (input_location, comp_se.expr);
2255 /* Convert a typebound function reference from a class object. */
2257 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
2262 if (TREE_CODE (base_object) != VAR_DECL)
2264 var = gfc_create_var (TREE_TYPE (base_object), NULL);
2265 gfc_add_modify (&se->pre, var, base_object);
2267 se->expr = gfc_class_vptr_get (base_object);
2268 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2270 while (ref && ref->next)
2272 gcc_assert (ref && ref->type == REF_COMPONENT);
2273 if (ref->u.c.sym->attr.extension)
2274 conv_parent_component_references (se, ref);
2275 gfc_conv_component_ref (se, ref);
2276 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
2281 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
2285 if (gfc_is_proc_ptr_comp (expr, NULL))
2286 tmp = get_proc_ptr_comp (expr);
2287 else if (sym->attr.dummy)
2289 tmp = gfc_get_symbol_decl (sym);
2290 if (sym->attr.proc_pointer)
2291 tmp = build_fold_indirect_ref_loc (input_location,
2293 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
2294 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
2298 if (!sym->backend_decl)
2299 sym->backend_decl = gfc_get_extern_function_decl (sym);
2301 tmp = sym->backend_decl;
2303 if (sym->attr.cray_pointee)
2305 /* TODO - make the cray pointee a pointer to a procedure,
2306 assign the pointer to it and use it for the call. This
2308 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
2309 gfc_get_symbol_decl (sym->cp_pointer));
2310 tmp = gfc_evaluate_now (tmp, &se->pre);
2313 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
2315 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
2316 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2323 /* Initialize MAPPING. */
2326 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
2328 mapping->syms = NULL;
2329 mapping->charlens = NULL;
2333 /* Free all memory held by MAPPING (but not MAPPING itself). */
2336 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
2338 gfc_interface_sym_mapping *sym;
2339 gfc_interface_sym_mapping *nextsym;
2341 gfc_charlen *nextcl;
2343 for (sym = mapping->syms; sym; sym = nextsym)
2345 nextsym = sym->next;
2346 sym->new_sym->n.sym->formal = NULL;
2347 gfc_free_symbol (sym->new_sym->n.sym);
2348 gfc_free_expr (sym->expr);
2349 free (sym->new_sym);
2352 for (cl = mapping->charlens; cl; cl = nextcl)
2355 gfc_free_expr (cl->length);
2361 /* Return a copy of gfc_charlen CL. Add the returned structure to
2362 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2364 static gfc_charlen *
2365 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
2368 gfc_charlen *new_charlen;
2370 new_charlen = gfc_get_charlen ();
2371 new_charlen->next = mapping->charlens;
2372 new_charlen->length = gfc_copy_expr (cl->length);
2374 mapping->charlens = new_charlen;
2379 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2380 array variable that can be used as the actual argument for dummy
2381 argument SYM. Add any initialization code to BLOCK. PACKED is as
2382 for gfc_get_nodesc_array_type and DATA points to the first element
2383 in the passed array. */
2386 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
2387 gfc_packed packed, tree data)
2392 type = gfc_typenode_for_spec (&sym->ts);
2393 type = gfc_get_nodesc_array_type (type, sym->as, packed,
2394 !sym->attr.target && !sym->attr.pointer
2395 && !sym->attr.proc_pointer);
2397 var = gfc_create_var (type, "ifm");
2398 gfc_add_modify (block, var, fold_convert (type, data));
2404 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2405 and offset of descriptorless array type TYPE given that it has the same
2406 size as DESC. Add any set-up code to BLOCK. */
2409 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
2416 offset = gfc_index_zero_node;
2417 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
2419 dim = gfc_rank_cst[n];
2420 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
2421 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
2423 GFC_TYPE_ARRAY_LBOUND (type, n)
2424 = gfc_conv_descriptor_lbound_get (desc, dim);
2425 GFC_TYPE_ARRAY_UBOUND (type, n)
2426 = gfc_conv_descriptor_ubound_get (desc, dim);
2428 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
2430 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2431 gfc_array_index_type,
2432 gfc_conv_descriptor_ubound_get (desc, dim),
2433 gfc_conv_descriptor_lbound_get (desc, dim));
2434 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2435 gfc_array_index_type,
2436 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
2437 tmp = gfc_evaluate_now (tmp, block);
2438 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
2440 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2441 GFC_TYPE_ARRAY_LBOUND (type, n),
2442 GFC_TYPE_ARRAY_STRIDE (type, n));
2443 offset = fold_build2_loc (input_location, MINUS_EXPR,
2444 gfc_array_index_type, offset, tmp);
2446 offset = gfc_evaluate_now (offset, block);
2447 GFC_TYPE_ARRAY_OFFSET (type) = offset;
2451 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2452 in SE. The caller may still use se->expr and se->string_length after
2453 calling this function. */
2456 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
2457 gfc_symbol * sym, gfc_se * se,
2460 gfc_interface_sym_mapping *sm;
2464 gfc_symbol *new_sym;
2466 gfc_symtree *new_symtree;
2468 /* Create a new symbol to represent the actual argument. */
2469 new_sym = gfc_new_symbol (sym->name, NULL);
2470 new_sym->ts = sym->ts;
2471 new_sym->as = gfc_copy_array_spec (sym->as);
2472 new_sym->attr.referenced = 1;
2473 new_sym->attr.dimension = sym->attr.dimension;
2474 new_sym->attr.contiguous = sym->attr.contiguous;
2475 new_sym->attr.codimension = sym->attr.codimension;
2476 new_sym->attr.pointer = sym->attr.pointer;
2477 new_sym->attr.allocatable = sym->attr.allocatable;
2478 new_sym->attr.flavor = sym->attr.flavor;
2479 new_sym->attr.function = sym->attr.function;
2481 /* Ensure that the interface is available and that
2482 descriptors are passed for array actual arguments. */
2483 if (sym->attr.flavor == FL_PROCEDURE)
2485 new_sym->formal = expr->symtree->n.sym->formal;
2486 new_sym->attr.always_explicit
2487 = expr->symtree->n.sym->attr.always_explicit;
2490 /* Create a fake symtree for it. */
2492 new_symtree = gfc_new_symtree (&root, sym->name);
2493 new_symtree->n.sym = new_sym;
2494 gcc_assert (new_symtree == root);
2496 /* Create a dummy->actual mapping. */
2497 sm = XCNEW (gfc_interface_sym_mapping);
2498 sm->next = mapping->syms;
2500 sm->new_sym = new_symtree;
2501 sm->expr = gfc_copy_expr (expr);
2504 /* Stabilize the argument's value. */
2505 if (!sym->attr.function && se)
2506 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2508 if (sym->ts.type == BT_CHARACTER)
2510 /* Create a copy of the dummy argument's length. */
2511 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
2512 sm->expr->ts.u.cl = new_sym->ts.u.cl;
2514 /* If the length is specified as "*", record the length that
2515 the caller is passing. We should use the callee's length
2516 in all other cases. */
2517 if (!new_sym->ts.u.cl->length && se)
2519 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
2520 new_sym->ts.u.cl->backend_decl = se->string_length;
2527 /* Use the passed value as-is if the argument is a function. */
2528 if (sym->attr.flavor == FL_PROCEDURE)
2531 /* If the argument is either a string or a pointer to a string,
2532 convert it to a boundless character type. */
2533 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
2535 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
2536 tmp = build_pointer_type (tmp);
2537 if (sym->attr.pointer)
2538 value = build_fold_indirect_ref_loc (input_location,
2542 value = fold_convert (tmp, value);
2545 /* If the argument is a scalar, a pointer to an array or an allocatable,
2547 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
2548 value = build_fold_indirect_ref_loc (input_location,
2551 /* For character(*), use the actual argument's descriptor. */
2552 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
2553 value = build_fold_indirect_ref_loc (input_location,
2556 /* If the argument is an array descriptor, use it to determine
2557 information about the actual argument's shape. */
2558 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
2559 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
2561 /* Get the actual argument's descriptor. */
2562 desc = build_fold_indirect_ref_loc (input_location,
2565 /* Create the replacement variable. */
2566 tmp = gfc_conv_descriptor_data_get (desc);
2567 value = gfc_get_interface_mapping_array (&se->pre, sym,
2570 /* Use DESC to work out the upper bounds, strides and offset. */
2571 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
2574 /* Otherwise we have a packed array. */
2575 value = gfc_get_interface_mapping_array (&se->pre, sym,
2576 PACKED_FULL, se->expr);
2578 new_sym->backend_decl = value;
2582 /* Called once all dummy argument mappings have been added to MAPPING,
2583 but before the mapping is used to evaluate expressions. Pre-evaluate
2584 the length of each argument, adding any initialization code to PRE and
2585 any finalization code to POST. */
2588 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2589 stmtblock_t * pre, stmtblock_t * post)
2591 gfc_interface_sym_mapping *sym;
2595 for (sym = mapping->syms; sym; sym = sym->next)
2596 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2597 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2599 expr = sym->new_sym->n.sym->ts.u.cl->length;
2600 gfc_apply_interface_mapping_to_expr (mapping, expr);
2601 gfc_init_se (&se, NULL);
2602 gfc_conv_expr (&se, expr);
2603 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2604 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2605 gfc_add_block_to_block (pre, &se.pre);
2606 gfc_add_block_to_block (post, &se.post);
2608 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2613 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2617 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2618 gfc_constructor_base base)
2621 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2623 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2626 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2627 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2628 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2634 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2638 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2643 for (; ref; ref = ref->next)
2647 for (n = 0; n < ref->u.ar.dimen; n++)
2649 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2650 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2651 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2653 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2660 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2661 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2667 /* Convert intrinsic function calls into result expressions. */
2670 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2678 arg1 = expr->value.function.actual->expr;
2679 if (expr->value.function.actual->next)
2680 arg2 = expr->value.function.actual->next->expr;
2684 sym = arg1->symtree->n.sym;
2686 if (sym->attr.dummy)
2691 switch (expr->value.function.isym->id)
2694 /* TODO figure out why this condition is necessary. */
2695 if (sym->attr.function
2696 && (arg1->ts.u.cl->length == NULL
2697 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2698 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2701 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2705 if (!sym->as || sym->as->rank == 0)
2708 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2710 dup = mpz_get_si (arg2->value.integer);
2715 dup = sym->as->rank;
2719 for (; d < dup; d++)
2723 if (!sym->as->upper[d] || !sym->as->lower[d])
2725 gfc_free_expr (new_expr);
2729 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2730 gfc_get_int_expr (gfc_default_integer_kind,
2732 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2734 new_expr = gfc_multiply (new_expr, tmp);
2740 case GFC_ISYM_LBOUND:
2741 case GFC_ISYM_UBOUND:
2742 /* TODO These implementations of lbound and ubound do not limit if
2743 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2745 if (!sym->as || sym->as->rank == 0)
2748 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2749 d = mpz_get_si (arg2->value.integer) - 1;
2751 /* TODO: If the need arises, this could produce an array of
2755 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2757 if (sym->as->lower[d])
2758 new_expr = gfc_copy_expr (sym->as->lower[d]);
2762 if (sym->as->upper[d])
2763 new_expr = gfc_copy_expr (sym->as->upper[d]);
2771 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2775 gfc_replace_expr (expr, new_expr);
2781 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2782 gfc_interface_mapping * mapping)
2784 gfc_formal_arglist *f;
2785 gfc_actual_arglist *actual;
2787 actual = expr->value.function.actual;
2788 f = map_expr->symtree->n.sym->formal;
2790 for (; f && actual; f = f->next, actual = actual->next)
2795 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2798 if (map_expr->symtree->n.sym->attr.dimension)
2803 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2805 for (d = 0; d < as->rank; d++)
2807 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2808 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2811 expr->value.function.esym->as = as;
2814 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2816 expr->value.function.esym->ts.u.cl->length
2817 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2819 gfc_apply_interface_mapping_to_expr (mapping,
2820 expr->value.function.esym->ts.u.cl->length);
2825 /* EXPR is a copy of an expression that appeared in the interface
2826 associated with MAPPING. Walk it recursively looking for references to
2827 dummy arguments that MAPPING maps to actual arguments. Replace each such
2828 reference with a reference to the associated actual argument. */
2831 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2834 gfc_interface_sym_mapping *sym;
2835 gfc_actual_arglist *actual;
2840 /* Copying an expression does not copy its length, so do that here. */
2841 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2843 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2844 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2847 /* Apply the mapping to any references. */
2848 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2850 /* ...and to the expression's symbol, if it has one. */
2851 /* TODO Find out why the condition on expr->symtree had to be moved into
2852 the loop rather than being outside it, as originally. */
2853 for (sym = mapping->syms; sym; sym = sym->next)
2854 if (expr->symtree && sym->old == expr->symtree->n.sym)
2856 if (sym->new_sym->n.sym->backend_decl)
2857 expr->symtree = sym->new_sym;
2859 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2860 /* Replace base type for polymorphic arguments. */
2861 if (expr->ref && expr->ref->type == REF_COMPONENT
2862 && sym->expr && sym->expr->ts.type == BT_CLASS)
2863 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2866 /* ...and to subexpressions in expr->value. */
2867 switch (expr->expr_type)
2872 case EXPR_SUBSTRING:
2876 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2877 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2881 for (actual = expr->value.function.actual; actual; actual = actual->next)
2882 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2884 if (expr->value.function.esym == NULL
2885 && expr->value.function.isym != NULL
2886 && expr->value.function.actual->expr->symtree
2887 && gfc_map_intrinsic_function (expr, mapping))
2890 for (sym = mapping->syms; sym; sym = sym->next)
2891 if (sym->old == expr->value.function.esym)
2893 expr->value.function.esym = sym->new_sym->n.sym;
2894 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2895 expr->value.function.esym->result = sym->new_sym->n.sym;
2900 case EXPR_STRUCTURE:
2901 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2914 /* Evaluate interface expression EXPR using MAPPING. Store the result
2918 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2919 gfc_se * se, gfc_expr * expr)
2921 expr = gfc_copy_expr (expr);
2922 gfc_apply_interface_mapping_to_expr (mapping, expr);
2923 gfc_conv_expr (se, expr);
2924 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2925 gfc_free_expr (expr);
2929 /* Returns a reference to a temporary array into which a component of
2930 an actual argument derived type array is copied and then returned
2931 after the function call. */
2933 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2934 sym_intent intent, bool formal_ptr)
2942 gfc_array_info *info;
2952 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2954 gfc_init_se (&lse, NULL);
2955 gfc_init_se (&rse, NULL);
2957 /* Walk the argument expression. */
2958 rss = gfc_walk_expr (expr);
2960 gcc_assert (rss != gfc_ss_terminator);
2962 /* Initialize the scalarizer. */
2963 gfc_init_loopinfo (&loop);
2964 gfc_add_ss_to_loop (&loop, rss);
2966 /* Calculate the bounds of the scalarization. */
2967 gfc_conv_ss_startstride (&loop);
2969 /* Build an ss for the temporary. */
2970 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2971 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2973 base_type = gfc_typenode_for_spec (&expr->ts);
2974 if (GFC_ARRAY_TYPE_P (base_type)
2975 || GFC_DESCRIPTOR_TYPE_P (base_type))
2976 base_type = gfc_get_element_type (base_type);
2978 if (expr->ts.type == BT_CLASS)
2979 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
2981 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
2982 ? expr->ts.u.cl->backend_decl
2986 parmse->string_length = loop.temp_ss->info->string_length;
2988 /* Associate the SS with the loop. */
2989 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2991 /* Setup the scalarizing loops. */
2992 gfc_conv_loop_setup (&loop, &expr->where);
2994 /* Pass the temporary descriptor back to the caller. */
2995 info = &loop.temp_ss->info->data.array;
2996 parmse->expr = info->descriptor;
2998 /* Setup the gfc_se structures. */
2999 gfc_copy_loopinfo_to_se (&lse, &loop);
3000 gfc_copy_loopinfo_to_se (&rse, &loop);
3003 lse.ss = loop.temp_ss;
3004 gfc_mark_ss_chain_used (rss, 1);
3005 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3007 /* Start the scalarized loop body. */
3008 gfc_start_scalarized_body (&loop, &body);
3010 /* Translate the expression. */
3011 gfc_conv_expr (&rse, expr);
3013 gfc_conv_tmp_array_ref (&lse);
3015 if (intent != INTENT_OUT)
3017 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
3018 gfc_add_expr_to_block (&body, tmp);
3019 gcc_assert (rse.ss == gfc_ss_terminator);
3020 gfc_trans_scalarizing_loops (&loop, &body);
3024 /* Make sure that the temporary declaration survives by merging
3025 all the loop declarations into the current context. */
3026 for (n = 0; n < loop.dimen; n++)
3028 gfc_merge_block_scope (&body);
3029 body = loop.code[loop.order[n]];
3031 gfc_merge_block_scope (&body);
3034 /* Add the post block after the second loop, so that any
3035 freeing of allocated memory is done at the right time. */
3036 gfc_add_block_to_block (&parmse->pre, &loop.pre);
3038 /**********Copy the temporary back again.*********/
3040 gfc_init_se (&lse, NULL);
3041 gfc_init_se (&rse, NULL);
3043 /* Walk the argument expression. */
3044 lss = gfc_walk_expr (expr);
3045 rse.ss = loop.temp_ss;
3048 /* Initialize the scalarizer. */
3049 gfc_init_loopinfo (&loop2);
3050 gfc_add_ss_to_loop (&loop2, lss);
3052 /* Calculate the bounds of the scalarization. */
3053 gfc_conv_ss_startstride (&loop2);
3055 /* Setup the scalarizing loops. */
3056 gfc_conv_loop_setup (&loop2, &expr->where);
3058 gfc_copy_loopinfo_to_se (&lse, &loop2);
3059 gfc_copy_loopinfo_to_se (&rse, &loop2);
3061 gfc_mark_ss_chain_used (lss, 1);
3062 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3064 /* Declare the variable to hold the temporary offset and start the
3065 scalarized loop body. */
3066 offset = gfc_create_var (gfc_array_index_type, NULL);
3067 gfc_start_scalarized_body (&loop2, &body);
3069 /* Build the offsets for the temporary from the loop variables. The
3070 temporary array has lbounds of zero and strides of one in all
3071 dimensions, so this is very simple. The offset is only computed
3072 outside the innermost loop, so the overall transfer could be
3073 optimized further. */
3074 info = &rse.ss->info->data.array;
3075 dimen = rse.ss->dimen;
3077 tmp_index = gfc_index_zero_node;
3078 for (n = dimen - 1; n > 0; n--)
3081 tmp = rse.loop->loopvar[n];
3082 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3083 tmp, rse.loop->from[n]);
3084 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3087 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
3088 gfc_array_index_type,
3089 rse.loop->to[n-1], rse.loop->from[n-1]);
3090 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
3091 gfc_array_index_type,
3092 tmp_str, gfc_index_one_node);
3094 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
3095 gfc_array_index_type, tmp, tmp_str);
3098 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
3099 gfc_array_index_type,
3100 tmp_index, rse.loop->from[0]);
3101 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
3103 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
3104 gfc_array_index_type,
3105 rse.loop->loopvar[0], offset);
3107 /* Now use the offset for the reference. */
3108 tmp = build_fold_indirect_ref_loc (input_location,
3110 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
3112 if (expr->ts.type == BT_CHARACTER)
3113 rse.string_length = expr->ts.u.cl->backend_decl;
3115 gfc_conv_expr (&lse, expr);
3117 gcc_assert (lse.ss == gfc_ss_terminator);
3119 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
3120 gfc_add_expr_to_block (&body, tmp);
3122 /* Generate the copying loops. */
3123 gfc_trans_scalarizing_loops (&loop2, &body);
3125 /* Wrap the whole thing up by adding the second loop to the post-block
3126 and following it by the post-block of the first loop. In this way,
3127 if the temporary needs freeing, it is done after use! */
3128 if (intent != INTENT_IN)
3130 gfc_add_block_to_block (&parmse->post, &loop2.pre);
3131 gfc_add_block_to_block (&parmse->post, &loop2.post);
3134 gfc_add_block_to_block (&parmse->post, &loop.post);
3136 gfc_cleanup_loop (&loop);
3137 gfc_cleanup_loop (&loop2);
3139 /* Pass the string length to the argument expression. */
3140 if (expr->ts.type == BT_CHARACTER)
3141 parmse->string_length = expr->ts.u.cl->backend_decl;
3143 /* Determine the offset for pointer formal arguments and set the
3147 size = gfc_index_one_node;
3148 offset = gfc_index_zero_node;
3149 for (n = 0; n < dimen; n++)
3151 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
3153 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3154 gfc_array_index_type, tmp,
3155 gfc_index_one_node);
3156 gfc_conv_descriptor_ubound_set (&parmse->pre,
3160 gfc_conv_descriptor_lbound_set (&parmse->pre,
3163 gfc_index_one_node);
3164 size = gfc_evaluate_now (size, &parmse->pre);
3165 offset = fold_build2_loc (input_location, MINUS_EXPR,
3166 gfc_array_index_type,
3168 offset = gfc_evaluate_now (offset, &parmse->pre);
3169 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3170 gfc_array_index_type,
3171 rse.loop->to[n], rse.loop->from[n]);
3172 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3173 gfc_array_index_type,
3174 tmp, gfc_index_one_node);
3175 size = fold_build2_loc (input_location, MULT_EXPR,
3176 gfc_array_index_type, size, tmp);
3179 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
3183 /* We want either the address for the data or the address of the descriptor,
3184 depending on the mode of passing array arguments. */
3186 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
3188 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
3194 /* Generate the code for argument list functions. */
3197 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
3199 /* Pass by value for g77 %VAL(arg), pass the address
3200 indirectly for %LOC, else by reference. Thus %REF
3201 is a "do-nothing" and %LOC is the same as an F95
3203 if (strncmp (name, "%VAL", 4) == 0)
3204 gfc_conv_expr (se, expr);
3205 else if (strncmp (name, "%LOC", 4) == 0)
3207 gfc_conv_expr_reference (se, expr);
3208 se->expr = gfc_build_addr_expr (NULL, se->expr);
3210 else if (strncmp (name, "%REF", 4) == 0)
3211 gfc_conv_expr_reference (se, expr);
3213 gfc_error ("Unknown argument list function at %L", &expr->where);
3217 /* The following routine generates code for the intrinsic
3218 procedures from the ISO_C_BINDING module:
3220 * C_FUNLOC (function)
3221 * C_F_POINTER (subroutine)
3222 * C_F_PROCPOINTER (subroutine)
3223 * C_ASSOCIATED (function)
3224 One exception which is not handled here is C_F_POINTER with non-scalar
3225 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3228 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
3229 gfc_actual_arglist * arg)
3234 if (sym->intmod_sym_id == ISOCBINDING_LOC)
3236 if (arg->expr->rank == 0)
3237 gfc_conv_expr_reference (se, arg->expr);
3241 /* This is really the actual arg because no formal arglist is
3242 created for C_LOC. */
3243 fsym = arg->expr->symtree->n.sym;
3245 /* We should want it to do g77 calling convention. */
3247 && !(fsym->attr.pointer || fsym->attr.allocatable)
3248 && fsym->as->type != AS_ASSUMED_SHAPE;
3249 f = f || !sym->attr.always_explicit;
3251 argss = gfc_walk_expr (arg->expr);
3252 gfc_conv_array_parameter (se, arg->expr, argss, f,
3256 /* TODO -- the following two lines shouldn't be necessary, but if
3257 they're removed, a bug is exposed later in the code path.
3258 This workaround was thus introduced, but will have to be
3259 removed; please see PR 35150 for details about the issue. */
3260 se->expr = convert (pvoid_type_node, se->expr);
3261 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3265 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
3267 arg->expr->ts.type = sym->ts.u.derived->ts.type;
3268 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
3269 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
3270 gfc_conv_expr_reference (se, arg->expr);
3274 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
3275 && arg->next->expr->rank == 0)
3276 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3278 /* Convert c_f_pointer if fptr is a scalar
3279 and convert c_f_procpointer. */
3283 gfc_init_se (&cptrse, NULL);
3284 gfc_conv_expr (&cptrse, arg->expr);
3285 gfc_add_block_to_block (&se->pre, &cptrse.pre);
3286 gfc_add_block_to_block (&se->post, &cptrse.post);
3288 gfc_init_se (&fptrse, NULL);
3289 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
3290 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
3291 fptrse.want_pointer = 1;
3293 gfc_conv_expr (&fptrse, arg->next->expr);
3294 gfc_add_block_to_block (&se->pre, &fptrse.pre);
3295 gfc_add_block_to_block (&se->post, &fptrse.post);
3297 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
3298 && arg->next->expr->symtree->n.sym->attr.dummy)
3299 fptrse.expr = build_fold_indirect_ref_loc (input_location,
3302 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
3303 TREE_TYPE (fptrse.expr),
3305 fold_convert (TREE_TYPE (fptrse.expr),
3310 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3315 /* Build the addr_expr for the first argument. The argument is
3316 already an *address* so we don't need to set want_pointer in
3318 gfc_init_se (&arg1se, NULL);
3319 gfc_conv_expr (&arg1se, arg->expr);
3320 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3321 gfc_add_block_to_block (&se->post, &arg1se.post);
3323 /* See if we were given two arguments. */
3324 if (arg->next == NULL)
3325 /* Only given one arg so generate a null and do a
3326 not-equal comparison against the first arg. */
3327 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3329 fold_convert (TREE_TYPE (arg1se.expr),
3330 null_pointer_node));
3336 /* Given two arguments so build the arg2se from second arg. */
3337 gfc_init_se (&arg2se, NULL);
3338 gfc_conv_expr (&arg2se, arg->next->expr);
3339 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3340 gfc_add_block_to_block (&se->post, &arg2se.post);
3342 /* Generate test to compare that the two args are equal. */
3343 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3344 arg1se.expr, arg2se.expr);
3345 /* Generate test to ensure that the first arg is not null. */
3346 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
3348 arg1se.expr, null_pointer_node);
3350 /* Finally, the generated test must check that both arg1 is not
3351 NULL and that it is equal to the second arg. */
3352 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3354 not_null_expr, eq_expr);
3360 /* Nothing was done. */
3365 /* Generate code for a procedure call. Note can return se->post != NULL.
3366 If se->direct_byref is set then se->expr contains the return parameter.
3367 Return nonzero, if the call has alternate specifiers.
3368 'expr' is only needed for procedure pointer components. */
3371 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
3372 gfc_actual_arglist * args, gfc_expr * expr,
3373 VEC(tree,gc) *append_args)
3375 gfc_interface_mapping mapping;
3376 VEC(tree,gc) *arglist;
3377 VEC(tree,gc) *retargs;
3382 gfc_array_info *info;
3389 VEC(tree,gc) *stringargs;
3391 gfc_formal_arglist *formal;
3392 gfc_actual_arglist *arg;
3393 int has_alternate_specifier = 0;
3394 bool need_interface_mapping;
3401 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
3402 gfc_component *comp = NULL;
3412 if (sym->from_intmod == INTMOD_ISO_C_BINDING
3413 && conv_isocbinding_procedure (se, sym, args))
3416 gfc_is_proc_ptr_comp (expr, &comp);
3420 if (!sym->attr.elemental && !(comp && comp->attr.elemental))
3422 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
3423 if (se->ss->info->useflags)
3425 gcc_assert ((!comp && gfc_return_by_reference (sym)
3426 && sym->result->attr.dimension)
3427 || (comp && comp->attr.dimension));
3428 gcc_assert (se->loop != NULL);
3430 /* Access the previously obtained result. */
3431 gfc_conv_tmp_array_ref (se);
3435 info = &se->ss->info->data.array;
3440 gfc_init_block (&post);
3441 gfc_init_interface_mapping (&mapping);
3444 formal = sym->formal;
3445 need_interface_mapping = sym->attr.dimension ||
3446 (sym->ts.type == BT_CHARACTER
3447 && sym->ts.u.cl->length
3448 && sym->ts.u.cl->length->expr_type
3453 formal = comp->formal;
3454 need_interface_mapping = comp->attr.dimension ||
3455 (comp->ts.type == BT_CHARACTER
3456 && comp->ts.u.cl->length
3457 && comp->ts.u.cl->length->expr_type
3461 base_object = NULL_TREE;
3463 /* Evaluate the arguments. */
3464 for (arg = args; arg != NULL;
3465 arg = arg->next, formal = formal ? formal->next : NULL)
3468 fsym = formal ? formal->sym : NULL;
3469 parm_kind = MISSING;
3471 /* Class array expressions are sometimes coming completely unadorned
3472 with either arrayspec or _data component. Correct that here.
3473 OOP-TODO: Move this to the frontend. */
3474 if (e && e->expr_type == EXPR_VARIABLE
3476 && e->ts.type == BT_CLASS
3477 && CLASS_DATA (e)->attr.dimension)
3479 gfc_typespec temp_ts = e->ts;
3480 gfc_add_class_array_ref (e);
3486 if (se->ignore_optional)
3488 /* Some intrinsics have already been resolved to the correct
3492 else if (arg->label)
3494 has_alternate_specifier = 1;
3499 /* Pass a NULL pointer for an absent arg. */
3500 gfc_init_se (&parmse, NULL);
3501 parmse.expr = null_pointer_node;
3502 if (arg->missing_arg_type == BT_CHARACTER)
3503 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
3506 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
3508 /* Pass a NULL pointer to denote an absent arg. */
3509 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
3510 gfc_init_se (&parmse, NULL);
3511 parmse.expr = null_pointer_node;
3512 if (arg->missing_arg_type == BT_CHARACTER)
3513 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
3515 else if (fsym && fsym->ts.type == BT_CLASS
3516 && e->ts.type == BT_DERIVED)
3518 /* The derived type needs to be converted to a temporary
3520 gfc_init_se (&parmse, se);
3521 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
3523 else if (se->ss && se->ss->info->useflags)
3525 /* An elemental function inside a scalarized loop. */
3526 gfc_init_se (&parmse, se);
3527 parm_kind = ELEMENTAL;
3529 if (se->ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
3530 && se->ss->info->data.array.ref == NULL)
3532 gfc_conv_tmp_array_ref (&parmse);
3533 if (e->ts.type == BT_CHARACTER)
3534 gfc_conv_string_parameter (&parmse);
3536 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3539 gfc_conv_expr_reference (&parmse, e);
3541 /* The scalarizer does not repackage the reference to a class
3542 array - instead it returns a pointer to the data element. */
3543 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
3544 gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
3548 /* A scalar or transformational function. */
3549 gfc_init_se (&parmse, NULL);
3550 argss = gfc_walk_expr (e);
3552 if (argss == gfc_ss_terminator)
3554 if (e->expr_type == EXPR_VARIABLE
3555 && e->symtree->n.sym->attr.cray_pointee
3556 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3558 /* The Cray pointer needs to be converted to a pointer to
3559 a type given by the expression. */
3560 gfc_conv_expr (&parmse, e);
3561 type = build_pointer_type (TREE_TYPE (parmse.expr));
3562 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3563 parmse.expr = convert (type, tmp);
3565 else if (fsym && fsym->attr.value)
3567 if (fsym->ts.type == BT_CHARACTER
3568 && fsym->ts.is_c_interop
3569 && fsym->ns->proc_name != NULL
3570 && fsym->ns->proc_name->attr.is_bind_c)
3573 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3574 if (parmse.expr == NULL)
3575 gfc_conv_expr (&parmse, e);
3578 gfc_conv_expr (&parmse, e);
3580 else if (arg->name && arg->name[0] == '%')
3581 /* Argument list functions %VAL, %LOC and %REF are signalled
3582 through arg->name. */
3583 conv_arglist_function (&parmse, arg->expr, arg->name);
3584 else if ((e->expr_type == EXPR_FUNCTION)
3585 && ((e->value.function.esym
3586 && e->value.function.esym->result->attr.pointer)
3587 || (!e->value.function.esym
3588 && e->symtree->n.sym->attr.pointer))
3589 && fsym && fsym->attr.target)
3591 gfc_conv_expr (&parmse, e);
3592 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3594 else if (e->expr_type == EXPR_FUNCTION
3595 && e->symtree->n.sym->result
3596 && e->symtree->n.sym->result != e->symtree->n.sym
3597 && e->symtree->n.sym->result->attr.proc_pointer)
3599 /* Functions returning procedure pointers. */
3600 gfc_conv_expr (&parmse, e);
3601 if (fsym && fsym->attr.proc_pointer)
3602 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3606 gfc_conv_expr_reference (&parmse, e);
3608 /* Catch base objects that are not variables. */
3609 if (e->ts.type == BT_CLASS
3610 && e->expr_type != EXPR_VARIABLE
3611 && expr && e == expr->base_expr)
3612 base_object = build_fold_indirect_ref_loc (input_location,
3615 /* A class array element needs converting back to be a
3616 class object, if the formal argument is a class object. */
3617 if (fsym && fsym->ts.type == BT_CLASS
3618 && e->ts.type == BT_CLASS
3619 && CLASS_DATA (e)->attr.dimension)
3620 gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
3622 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3623 allocated on entry, it must be deallocated. */
3624 if (fsym && fsym->attr.allocatable
3625 && fsym->attr.intent == INTENT_OUT)
3629 gfc_init_block (&block);
3630 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3631 NULL_TREE, NULL_TREE,
3632 NULL_TREE, true, NULL,
3634 gfc_add_expr_to_block (&block, tmp);
3635 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3636 void_type_node, parmse.expr,
3638 gfc_add_expr_to_block (&block, tmp);
3640 if (fsym->attr.optional
3641 && e->expr_type == EXPR_VARIABLE
3642 && e->symtree->n.sym->attr.optional)
3644 tmp = fold_build3_loc (input_location, COND_EXPR,
3646 gfc_conv_expr_present (e->symtree->n.sym),
3647 gfc_finish_block (&block),
3648 build_empty_stmt (input_location));
3651 tmp = gfc_finish_block (&block);
3653 gfc_add_expr_to_block (&se->pre, tmp);
3656 if (fsym && e->expr_type != EXPR_NULL
3657 && ((fsym->attr.pointer
3658 && fsym->attr.flavor != FL_PROCEDURE)
3659 || (fsym->attr.proc_pointer
3660 && !(e->expr_type == EXPR_VARIABLE
3661 && e->symtree->n.sym->attr.dummy))
3662 || (fsym->attr.proc_pointer
3663 && e->expr_type == EXPR_VARIABLE
3664 && gfc_is_proc_ptr_comp (e, NULL))
3665 || (fsym->attr.allocatable
3666 && fsym->attr.flavor != FL_PROCEDURE)))
3668 /* Scalar pointer dummy args require an extra level of
3669 indirection. The null pointer already contains
3670 this level of indirection. */
3671 parm_kind = SCALAR_POINTER;
3672 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3676 else if (e->ts.type == BT_CLASS
3677 && fsym && fsym->ts.type == BT_CLASS
3678 && CLASS_DATA (fsym)->attr.dimension)
3680 /* Pass a class array. */
3681 gfc_init_se (&parmse, se);
3682 gfc_conv_expr_descriptor (&parmse, e, argss);
3683 /* The conversion does not repackage the reference to a class
3684 array - _data descriptor. */
3685 gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
3689 /* If the procedure requires an explicit interface, the actual
3690 argument is passed according to the corresponding formal
3691 argument. If the corresponding formal argument is a POINTER,
3692 ALLOCATABLE or assumed shape, we do not use g77's calling
3693 convention, and pass the address of the array descriptor
3694 instead. Otherwise we use g77's calling convention. */
3697 && !(fsym->attr.pointer || fsym->attr.allocatable)
3698 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3700 f = f || !comp->attr.always_explicit;
3702 f = f || !sym->attr.always_explicit;
3704 /* If the argument is a function call that may not create
3705 a temporary for the result, we have to check that we
3706 can do it, i.e. that there is no alias between this
3707 argument and another one. */
3708 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3714 intent = fsym->attr.intent;
3716 intent = INTENT_UNKNOWN;
3718 if (gfc_check_fncall_dependency (e, intent, sym, args,
3720 parmse.force_tmp = 1;
3722 iarg = e->value.function.actual->expr;
3724 /* Temporary needed if aliasing due to host association. */
3725 if (sym->attr.contained
3727 && !sym->attr.implicit_pure
3728 && !sym->attr.use_assoc
3729 && iarg->expr_type == EXPR_VARIABLE
3730 && sym->ns == iarg->symtree->n.sym->ns)
3731 parmse.force_tmp = 1;
3733 /* Ditto within module. */
3734 if (sym->attr.use_assoc
3736 && !sym->attr.implicit_pure
3737 && iarg->expr_type == EXPR_VARIABLE
3738 && sym->module == iarg->symtree->n.sym->module)
3739 parmse.force_tmp = 1;
3742 if (e->expr_type == EXPR_VARIABLE
3743 && is_subref_array (e))
3744 /* The actual argument is a component reference to an
3745 array of derived types. In this case, the argument
3746 is converted to a temporary, which is passed and then
3747 written back after the procedure call. */
3748 gfc_conv_subref_array_arg (&parmse, e, f,
3749 fsym ? fsym->attr.intent : INTENT_INOUT,
3750 fsym && fsym->attr.pointer);
3751 else if (gfc_is_class_array_ref (e, NULL)
3752 && fsym && fsym->ts.type == BT_DERIVED)
3753 /* The actual argument is a component reference to an
3754 array of derived types. In this case, the argument
3755 is converted to a temporary, which is passed and then
3756 written back after the procedure call.
3757 OOP-TODO: Insert code so that if the dynamic type is
3758 the same as the declared type, copy-in/copy-out does
3760 gfc_conv_subref_array_arg (&parmse, e, f,
3761 fsym ? fsym->attr.intent : INTENT_INOUT,
3762 fsym && fsym->attr.pointer);
3764 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3767 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3768 allocated on entry, it must be deallocated. */
3769 if (fsym && fsym->attr.allocatable
3770 && fsym->attr.intent == INTENT_OUT)
3772 tmp = build_fold_indirect_ref_loc (input_location,
3774 tmp = gfc_trans_dealloc_allocated (tmp, false);
3775 if (fsym->attr.optional
3776 && e->expr_type == EXPR_VARIABLE
3777 && e->symtree->n.sym->attr.optional)
3778 tmp = fold_build3_loc (input_location, COND_EXPR,
3780 gfc_conv_expr_present (e->symtree->n.sym),
3781 tmp, build_empty_stmt (input_location));
3782 gfc_add_expr_to_block (&se->pre, tmp);
3787 /* The case with fsym->attr.optional is that of a user subroutine
3788 with an interface indicating an optional argument. When we call
3789 an intrinsic subroutine, however, fsym is NULL, but we might still
3790 have an optional argument, so we proceed to the substitution
3792 if (e && (fsym == NULL || fsym->attr.optional))
3794 /* If an optional argument is itself an optional dummy argument,
3795 check its presence and substitute a null if absent. This is
3796 only needed when passing an array to an elemental procedure
3797 as then array elements are accessed - or no NULL pointer is
3798 allowed and a "1" or "0" should be passed if not present.
3799 When passing a non-array-descriptor full array to a
3800 non-array-descriptor dummy, no check is needed. For
3801 array-descriptor actual to array-descriptor dummy, see
3802 PR 41911 for why a check has to be inserted.
3803 fsym == NULL is checked as intrinsics required the descriptor
3804 but do not always set fsym. */
3805 if (e->expr_type == EXPR_VARIABLE
3806 && e->symtree->n.sym->attr.optional
3807 && ((e->rank > 0 && sym->attr.elemental)
3808 || e->representation.length || e->ts.type == BT_CHARACTER
3812 && (fsym->as->type == AS_ASSUMED_SHAPE
3813 || fsym->as->type == AS_DEFERRED))))))
3814 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3815 e->representation.length);
3820 /* Obtain the character length of an assumed character length
3821 length procedure from the typespec. */
3822 if (fsym->ts.type == BT_CHARACTER
3823 && parmse.string_length == NULL_TREE
3824 && e->ts.type == BT_PROCEDURE
3825 && e->symtree->n.sym->ts.type == BT_CHARACTER
3826 && e->symtree->n.sym->ts.u.cl->length != NULL
3827 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3829 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3830 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3834 if (fsym && need_interface_mapping && e)
3835 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3837 gfc_add_block_to_block (&se->pre, &parmse.pre);
3838 gfc_add_block_to_block (&post, &parmse.post);
3840 /* Allocated allocatable components of derived types must be
3841 deallocated for non-variable scalars. Non-variable arrays are
3842 dealt with in trans-array.c(gfc_conv_array_parameter). */
3843 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
3844 && e->ts.u.derived->attr.alloc_comp
3845 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3846 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3849 tmp = build_fold_indirect_ref_loc (input_location,
3851 parm_rank = e->rank;
3859 case (SCALAR_POINTER):
3860 tmp = build_fold_indirect_ref_loc (input_location,
3865 if (e->expr_type == EXPR_OP
3866 && e->value.op.op == INTRINSIC_PARENTHESES
3867 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3870 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3871 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3872 gfc_add_expr_to_block (&se->post, local_tmp);
3875 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
3877 /* The derived type is passed to gfc_deallocate_alloc_comp.
3878 Therefore, class actuals can handled correctly but derived
3879 types passed to class formals need the _data component. */
3880 tmp = gfc_class_data_get (tmp);
3881 if (!CLASS_DATA (fsym)->attr.dimension)
3882 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3885 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3887 gfc_add_expr_to_block (&se->post, tmp);
3890 /* Add argument checking of passing an unallocated/NULL actual to
3891 a nonallocatable/nonpointer dummy. */
3893 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3895 symbol_attribute attr;
3899 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3900 attr = gfc_expr_attr (e);
3902 goto end_pointer_check;
3904 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3905 allocatable to an optional dummy, cf. 12.5.2.12. */
3906 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3907 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3908 goto end_pointer_check;
3912 /* If the actual argument is an optional pointer/allocatable and
3913 the formal argument takes an nonpointer optional value,
3914 it is invalid to pass a non-present argument on, even
3915 though there is no technical reason for this in gfortran.
3916 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3917 tree present, null_ptr, type;
3919 if (attr.allocatable
3920 && (fsym == NULL || !fsym->attr.allocatable))
3921 asprintf (&msg, "Allocatable actual argument '%s' is not "
3922 "allocated or not present", e->symtree->n.sym->name);
3923 else if (attr.pointer
3924 && (fsym == NULL || !fsym->attr.pointer))
3925 asprintf (&msg, "Pointer actual argument '%s' is not "
3926 "associated or not present",
3927 e->symtree->n.sym->name);
3928 else if (attr.proc_pointer
3929 && (fsym == NULL || !fsym->attr.proc_pointer))
3930 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3931 "associated or not present",
3932 e->symtree->n.sym->name);
3934 goto end_pointer_check;
3936 present = gfc_conv_expr_present (e->symtree->n.sym);
3937 type = TREE_TYPE (present);
3938 present = fold_build2_loc (input_location, EQ_EXPR,
3939 boolean_type_node, present,
3941 null_pointer_node));
3942 type = TREE_TYPE (parmse.expr);
3943 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3944 boolean_type_node, parmse.expr,
3946 null_pointer_node));
3947 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3948 boolean_type_node, present, null_ptr);
3952 if (attr.allocatable
3953 && (fsym == NULL || !fsym->attr.allocatable))
3954 asprintf (&msg, "Allocatable actual argument '%s' is not "
3955 "allocated", e->symtree->n.sym->name);
3956 else if (attr.pointer
3957 && (fsym == NULL || !fsym->attr.pointer))
3958 asprintf (&msg, "Pointer actual argument '%s' is not "
3959 "associated", e->symtree->n.sym->name);
3960 else if (attr.proc_pointer
3961 && (fsym == NULL || !fsym->attr.proc_pointer))
3962 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3963 "associated", e->symtree->n.sym->name);
3965 goto end_pointer_check;
3969 /* If the argument is passed by value, we need to strip the
3971 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
3972 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3974 cond = fold_build2_loc (input_location, EQ_EXPR,
3975 boolean_type_node, tmp,
3976 fold_convert (TREE_TYPE (tmp),
3977 null_pointer_node));
3980 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3986 /* Deferred length dummies pass the character length by reference
3987 so that the value can be returned. */
3988 if (parmse.string_length && fsym && fsym->ts.deferred)
3990 tmp = parmse.string_length;
3991 if (TREE_CODE (tmp) != VAR_DECL)
3992 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3993 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3996 /* Character strings are passed as two parameters, a length and a
3997 pointer - except for Bind(c) which only passes the pointer. */
3998 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3999 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
4001 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4002 pass the token and the offset as additional arguments. */
4003 if (fsym && fsym->attr.codimension
4004 && gfc_option.coarray == GFC_FCOARRAY_LIB
4005 && !fsym->attr.allocatable
4008 /* Token and offset. */
4009 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
4010 VEC_safe_push (tree, gc, stringargs,
4011 build_int_cst (gfc_array_index_type, 0));
4012 gcc_assert (fsym->attr.optional);
4014 else if (fsym && fsym->attr.codimension
4015 && !fsym->attr.allocatable
4016 && gfc_option.coarray == GFC_FCOARRAY_LIB)
4018 tree caf_decl, caf_type;
4021 caf_decl = get_tree_for_caf_expr (e);
4022 caf_type = TREE_TYPE (caf_decl);
4024 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
4025 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
4026 tmp = gfc_conv_descriptor_token (caf_decl);
4027 else if (DECL_LANG_SPECIFIC (caf_decl)
4028 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
4029 tmp = GFC_DECL_TOKEN (caf_decl);
4032 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
4033 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
4034 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
4037 VEC_safe_push (tree, gc, stringargs, tmp);
4039 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
4040 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
4041 offset = build_int_cst (gfc_array_index_type, 0);
4042 else if (DECL_LANG_SPECIFIC (caf_decl)
4043 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
4044 offset = GFC_DECL_CAF_OFFSET (caf_decl);
4045 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
4046 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
4048 offset = build_int_cst (gfc_array_index_type, 0);
4050 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
4051 tmp = gfc_conv_descriptor_data_get (caf_decl);
4054 gcc_assert (POINTER_TYPE_P (caf_type));
4058 if (fsym->as->type == AS_ASSUMED_SHAPE)
4060 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
4061 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4062 (TREE_TYPE (parmse.expr))));
4063 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
4064 tmp2 = gfc_conv_descriptor_data_get (tmp2);
4066 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
4067 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
4070 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
4074 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4075 gfc_array_index_type,
4076 fold_convert (gfc_array_index_type, tmp2),
4077 fold_convert (gfc_array_index_type, tmp));
4078 offset = fold_build2_loc (input_location, PLUS_EXPR,
4079 gfc_array_index_type, offset, tmp);
4081 VEC_safe_push (tree, gc, stringargs, offset);
4084 VEC_safe_push (tree, gc, arglist, parmse.expr);
4086 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
4093 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
4094 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
4095 else if (ts.type == BT_CHARACTER)
4097 if (ts.u.cl->length == NULL)
4099 /* Assumed character length results are not allowed by 5.1.1.5 of the
4100 standard and are trapped in resolve.c; except in the case of SPREAD
4101 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4102 we take the character length of the first argument for the result.
4103 For dummies, we have to look through the formal argument list for
4104 this function and use the character length found there.*/
4105 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
4106 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
4107 else if (!sym->attr.dummy)
4108 cl.backend_decl = VEC_index (tree, stringargs, 0);
4111 formal = sym->ns->proc_name->formal;
4112 for (; formal; formal = formal->next)
4113 if (strcmp (formal->sym->name, sym->name) == 0)
4114 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
4121 /* Calculate the length of the returned string. */
4122 gfc_init_se (&parmse, NULL);
4123 if (need_interface_mapping)
4124 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
4126 gfc_conv_expr (&parmse, ts.u.cl->length);
4127 gfc_add_block_to_block (&se->pre, &parmse.pre);
4128 gfc_add_block_to_block (&se->post, &parmse.post);
4130 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
4131 tmp = fold_build2_loc (input_location, MAX_EXPR,
4132 gfc_charlen_type_node, tmp,
4133 build_int_cst (gfc_charlen_type_node, 0));
4134 cl.backend_decl = tmp;
4137 /* Set up a charlen structure for it. */
4142 len = cl.backend_decl;
4145 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
4146 || (!comp && gfc_return_by_reference (sym));
4149 if (se->direct_byref)
4151 /* Sometimes, too much indirection can be applied; e.g. for
4152 function_result = array_valued_recursive_function. */
4153 if (TREE_TYPE (TREE_TYPE (se->expr))
4154 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
4155 && GFC_DESCRIPTOR_TYPE_P
4156 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
4157 se->expr = build_fold_indirect_ref_loc (input_location,
4160 /* If the lhs of an assignment x = f(..) is allocatable and
4161 f2003 is allowed, we must do the automatic reallocation.
4162 TODO - deal with intrinsics, without using a temporary. */
4163 if (gfc_option.flag_realloc_lhs
4164 && se->ss && se->ss->loop_chain
4165 && se->ss->loop_chain->is_alloc_lhs
4166 && !expr->value.function.isym
4167 && sym->result->as != NULL)
4169 /* Evaluate the bounds of the result, if known. */
4170 gfc_set_loop_bounds_from_array_spec (&mapping, se,
4173 /* Perform the automatic reallocation. */
4174 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
4176 gfc_add_expr_to_block (&se->pre, tmp);
4178 /* Pass the temporary as the first argument. */
4179 result = info->descriptor;
4182 result = build_fold_indirect_ref_loc (input_location,
4184 VEC_safe_push (tree, gc, retargs, se->expr);
4186 else if (comp && comp->attr.dimension)
4188 gcc_assert (se->loop && info);
4190 /* Set the type of the array. */
4191 tmp = gfc_typenode_for_spec (&comp->ts);
4192 gcc_assert (se->ss->dimen == se->loop->dimen);
4194 /* Evaluate the bounds of the result, if known. */
4195 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
4197 /* If the lhs of an assignment x = f(..) is allocatable and
4198 f2003 is allowed, we must not generate the function call
4199 here but should just send back the results of the mapping.
4200 This is signalled by the function ss being flagged. */
4201 if (gfc_option.flag_realloc_lhs
4202 && se->ss && se->ss->is_alloc_lhs)
4204 gfc_free_interface_mapping (&mapping);
4205 return has_alternate_specifier;
4208 /* Create a temporary to store the result. In case the function
4209 returns a pointer, the temporary will be a shallow copy and
4210 mustn't be deallocated. */
4211 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
4212 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4213 tmp, NULL_TREE, false,
4214 !comp->attr.pointer, callee_alloc,
4215 &se->ss->info->expr->where);
4217 /* Pass the temporary as the first argument. */
4218 result = info->descriptor;
4219 tmp = gfc_build_addr_expr (NULL_TREE, result);
4220 VEC_safe_push (tree, gc, retargs, tmp);
4222 else if (!comp && sym->result->attr.dimension)
4224 gcc_assert (se->loop && info);
4226 /* Set the type of the array. */
4227 tmp = gfc_typenode_for_spec (&ts);
4228 gcc_assert (se->ss->dimen == se->loop->dimen);
4230 /* Evaluate the bounds of the result, if known. */
4231 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
4233 /* If the lhs of an assignment x = f(..) is allocatable and
4234 f2003 is allowed, we must not generate the function call
4235 here but should just send back the results of the mapping.
4236 This is signalled by the function ss being flagged. */
4237 if (gfc_option.flag_realloc_lhs
4238 && se->ss && se->ss->is_alloc_lhs)
4240 gfc_free_interface_mapping (&mapping);
4241 return has_alternate_specifier;
4244 /* Create a temporary to store the result. In case the function
4245 returns a pointer, the temporary will be a shallow copy and
4246 mustn't be deallocated. */
4247 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
4248 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4249 tmp, NULL_TREE, false,
4250 !sym->attr.pointer, callee_alloc,
4251 &se->ss->info->expr->where);
4253 /* Pass the temporary as the first argument. */
4254 result = info->descriptor;
4255 tmp = gfc_build_addr_expr (NULL_TREE, result);
4256 VEC_safe_push (tree, gc, retargs, tmp);
4258 else if (ts.type == BT_CHARACTER)
4260 /* Pass the string length. */
4261 type = gfc_get_character_type (ts.kind, ts.u.cl);
4262 type = build_pointer_type (type);
4264 /* Return an address to a char[0:len-1]* temporary for
4265 character pointers. */
4266 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4267 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
4269 var = gfc_create_var (type, "pstr");
4271 if ((!comp && sym->attr.allocatable)
4272 || (comp && comp->attr.allocatable))
4273 gfc_add_modify (&se->pre, var,
4274 fold_convert (TREE_TYPE (var),
4275 null_pointer_node));
4277 /* Provide an address expression for the function arguments. */
4278 var = gfc_build_addr_expr (NULL_TREE, var);
4281 var = gfc_conv_string_tmp (se, type, len);
4283 VEC_safe_push (tree, gc, retargs, var);
4287 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
4289 type = gfc_get_complex_type (ts.kind);
4290 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
4291 VEC_safe_push (tree, gc, retargs, var);
4294 if (ts.type == BT_CHARACTER && ts.deferred
4295 && (sym->attr.allocatable || sym->attr.pointer))
4298 if (TREE_CODE (tmp) != VAR_DECL)
4299 tmp = gfc_evaluate_now (len, &se->pre);
4300 len = gfc_build_addr_expr (NULL_TREE, tmp);
4303 /* Add the string length to the argument list. */
4304 if (ts.type == BT_CHARACTER)
4305 VEC_safe_push (tree, gc, retargs, len);
4307 gfc_free_interface_mapping (&mapping);
4309 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
4310 arglen = (VEC_length (tree, arglist)
4311 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
4312 VEC_reserve_exact (tree, gc, retargs, arglen);
4314 /* Add the return arguments. */
4315 VEC_splice (tree, retargs, arglist);
4317 /* Add the hidden string length parameters to the arguments. */
4318 VEC_splice (tree, retargs, stringargs);
4320 /* We may want to append extra arguments here. This is used e.g. for
4321 calls to libgfortran_matmul_??, which need extra information. */
4322 if (!VEC_empty (tree, append_args))
4323 VEC_splice (tree, retargs, append_args);
4326 /* Generate the actual call. */
4327 if (base_object == NULL_TREE)
4328 conv_function_val (se, sym, expr);
4330 conv_base_obj_fcn_val (se, base_object, expr);
4332 /* If there are alternate return labels, function type should be
4333 integer. Can't modify the type in place though, since it can be shared
4334 with other functions. For dummy arguments, the typing is done to
4335 this result, even if it has to be repeated for each call. */
4336 if (has_alternate_specifier
4337 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
4339 if (!sym->attr.dummy)
4341 TREE_TYPE (sym->backend_decl)
4342 = build_function_type (integer_type_node,
4343 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
4344 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
4347 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
4350 fntype = TREE_TYPE (TREE_TYPE (se->expr));
4351 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
4353 /* If we have a pointer function, but we don't want a pointer, e.g.
4356 where f is pointer valued, we have to dereference the result. */
4357 if (!se->want_pointer && !byref
4358 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4359 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
4360 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4362 /* f2c calling conventions require a scalar default real function to
4363 return a double precision result. Convert this back to default
4364 real. We only care about the cases that can happen in Fortran 77.
4366 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
4367 && sym->ts.kind == gfc_default_real_kind
4368 && !sym->attr.always_explicit)
4369 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
4371 /* A pure function may still have side-effects - it may modify its
4373 TREE_SIDE_EFFECTS (se->expr) = 1;
4375 if (!sym->attr.pure)
4376 TREE_SIDE_EFFECTS (se->expr) = 1;
4381 /* Add the function call to the pre chain. There is no expression. */
4382 gfc_add_expr_to_block (&se->pre, se->expr);
4383 se->expr = NULL_TREE;
4385 if (!se->direct_byref)
4387 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
4389 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4391 /* Check the data pointer hasn't been modified. This would
4392 happen in a function returning a pointer. */
4393 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4394 tmp = fold_build2_loc (input_location, NE_EXPR,
4397 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
4400 se->expr = info->descriptor;
4401 /* Bundle in the string length. */
4402 se->string_length = len;
4404 else if (ts.type == BT_CHARACTER)
4406 /* Dereference for character pointer results. */
4407 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4408 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
4409 se->expr = build_fold_indirect_ref_loc (input_location, var);
4414 se->string_length = len;
4415 else if (sym->attr.allocatable || sym->attr.pointer)
4416 se->string_length = cl.backend_decl;
4420 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
4421 se->expr = build_fold_indirect_ref_loc (input_location, var);
4426 /* Follow the function call with the argument post block. */
4429 gfc_add_block_to_block (&se->pre, &post);
4431 /* Transformational functions of derived types with allocatable
4432 components must have the result allocatable components copied. */
4433 arg = expr->value.function.actual;
4434 if (result && arg && expr->rank
4435 && expr->value.function.isym
4436 && expr->value.function.isym->transformational
4437 && arg->expr->ts.type == BT_DERIVED
4438 && arg->expr->ts.u.derived->attr.alloc_comp)
4441 /* Copy the allocatable components. We have to use a
4442 temporary here to prevent source allocatable components
4443 from being corrupted. */
4444 tmp2 = gfc_evaluate_now (result, &se->pre);
4445 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
4446 result, tmp2, expr->rank);
4447 gfc_add_expr_to_block (&se->pre, tmp);
4448 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
4450 gfc_add_expr_to_block (&se->pre, tmp);
4452 /* Finally free the temporary's data field. */
4453 tmp = gfc_conv_descriptor_data_get (tmp2);
4454 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
4455 NULL_TREE, NULL_TREE, true,
4457 gfc_add_expr_to_block (&se->pre, tmp);
4461 gfc_add_block_to_block (&se->post, &post);
4463 return has_alternate_specifier;
4467 /* Fill a character string with spaces. */
4470 fill_with_spaces (tree start, tree type, tree size)
4472 stmtblock_t block, loop;
4473 tree i, el, exit_label, cond, tmp;
4475 /* For a simple char type, we can call memset(). */
4476 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
4477 return build_call_expr_loc (input_location,
4478 builtin_decl_explicit (BUILT_IN_MEMSET),
4480 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
4481 lang_hooks.to_target_charset (' ')),
4484 /* Otherwise, we use a loop:
4485 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
4489 /* Initialize variables. */
4490 gfc_init_block (&block);
4491 i = gfc_create_var (sizetype, "i");
4492 gfc_add_modify (&block, i, fold_convert (sizetype, size));
4493 el = gfc_create_var (build_pointer_type (type), "el");
4494 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
4495 exit_label = gfc_build_label_decl (NULL_TREE);
4496 TREE_USED (exit_label) = 1;
4500 gfc_init_block (&loop);
4502 /* Exit condition. */
4503 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
4504 build_zero_cst (sizetype));
4505 tmp = build1_v (GOTO_EXPR, exit_label);
4506 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4507 build_empty_stmt (input_location));
4508 gfc_add_expr_to_block (&loop, tmp);
4511 gfc_add_modify (&loop,
4512 fold_build1_loc (input_location, INDIRECT_REF, type, el),
4513 build_int_cst (type, lang_hooks.to_target_charset (' ')));
4515 /* Increment loop variables. */
4516 gfc_add_modify (&loop, i,
4517 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
4518 TYPE_SIZE_UNIT (type)));
4519 gfc_add_modify (&loop, el,
4520 fold_build_pointer_plus_loc (input_location,
4521 el, TYPE_SIZE_UNIT (type)));
4523 /* Making the loop... actually loop! */
4524 tmp = gfc_finish_block (&loop);
4525 tmp = build1_v (LOOP_EXPR, tmp);
4526 gfc_add_expr_to_block (&block, tmp);
4528 /* The exit label. */
4529 tmp = build1_v (LABEL_EXPR, exit_label);
4530 gfc_add_expr_to_block (&block, tmp);
4533 return gfc_finish_block (&block);
4537 /* Generate code to copy a string. */
4540 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
4541 int dkind, tree slength, tree src, int skind)
4543 tree tmp, dlen, slen;
4552 stmtblock_t tempblock;
4554 gcc_assert (dkind == skind);
4556 if (slength != NULL_TREE)
4558 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
4559 ssc = gfc_string_to_single_character (slen, src, skind);
4563 slen = build_int_cst (size_type_node, 1);
4567 if (dlength != NULL_TREE)
4569 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
4570 dsc = gfc_string_to_single_character (dlen, dest, dkind);
4574 dlen = build_int_cst (size_type_node, 1);
4578 /* Assign directly if the types are compatible. */
4579 if (dsc != NULL_TREE && ssc != NULL_TREE
4580 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
4582 gfc_add_modify (block, dsc, ssc);
4586 /* Do nothing if the destination length is zero. */
4587 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
4588 build_int_cst (size_type_node, 0));
4590 /* The following code was previously in _gfortran_copy_string:
4592 // The two strings may overlap so we use memmove.
4594 copy_string (GFC_INTEGER_4 destlen, char * dest,
4595 GFC_INTEGER_4 srclen, const char * src)
4597 if (srclen >= destlen)
4599 // This will truncate if too long.
4600 memmove (dest, src, destlen);
4604 memmove (dest, src, srclen);
4606 memset (&dest[srclen], ' ', destlen - srclen);
4610 We're now doing it here for better optimization, but the logic
4613 /* For non-default character kinds, we have to multiply the string
4614 length by the base type size. */
4615 chartype = gfc_get_char_type (dkind);
4616 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4617 fold_convert (size_type_node, slen),
4618 fold_convert (size_type_node,
4619 TYPE_SIZE_UNIT (chartype)));
4620 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4621 fold_convert (size_type_node, dlen),
4622 fold_convert (size_type_node,
4623 TYPE_SIZE_UNIT (chartype)));
4625 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4626 dest = fold_convert (pvoid_type_node, dest);
4628 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4630 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4631 src = fold_convert (pvoid_type_node, src);
4633 src = gfc_build_addr_expr (pvoid_type_node, src);
4635 /* Truncate string if source is too long. */
4636 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4638 tmp2 = build_call_expr_loc (input_location,
4639 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4640 3, dest, src, dlen);
4642 /* Else copy and pad with spaces. */
4643 tmp3 = build_call_expr_loc (input_location,
4644 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4645 3, dest, src, slen);
4647 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4648 tmp4 = fill_with_spaces (tmp4, chartype,
4649 fold_build2_loc (input_location, MINUS_EXPR,
4650 TREE_TYPE(dlen), dlen, slen));
4652 gfc_init_block (&tempblock);
4653 gfc_add_expr_to_block (&tempblock, tmp3);
4654 gfc_add_expr_to_block (&tempblock, tmp4);
4655 tmp3 = gfc_finish_block (&tempblock);
4657 /* The whole copy_string function is there. */
4658 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4660 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4661 build_empty_stmt (input_location));
4662 gfc_add_expr_to_block (block, tmp);
4666 /* Translate a statement function.
4667 The value of a statement function reference is obtained by evaluating the
4668 expression using the values of the actual arguments for the values of the
4669 corresponding dummy arguments. */
4672 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4676 gfc_formal_arglist *fargs;
4677 gfc_actual_arglist *args;
4680 gfc_saved_var *saved_vars;
4686 sym = expr->symtree->n.sym;
4687 args = expr->value.function.actual;
4688 gfc_init_se (&lse, NULL);
4689 gfc_init_se (&rse, NULL);
4692 for (fargs = sym->formal; fargs; fargs = fargs->next)
4694 saved_vars = XCNEWVEC (gfc_saved_var, n);
4695 temp_vars = XCNEWVEC (tree, n);
4697 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4699 /* Each dummy shall be specified, explicitly or implicitly, to be
4701 gcc_assert (fargs->sym->attr.dimension == 0);
4704 if (fsym->ts.type == BT_CHARACTER)
4706 /* Copy string arguments. */
4709 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4710 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4712 /* Create a temporary to hold the value. */
4713 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4714 fsym->ts.u.cl->backend_decl
4715 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4717 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4718 temp_vars[n] = gfc_create_var (type, fsym->name);
4720 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4722 gfc_conv_expr (&rse, args->expr);
4723 gfc_conv_string_parameter (&rse);
4724 gfc_add_block_to_block (&se->pre, &lse.pre);
4725 gfc_add_block_to_block (&se->pre, &rse.pre);
4727 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4728 rse.string_length, rse.expr, fsym->ts.kind);
4729 gfc_add_block_to_block (&se->pre, &lse.post);
4730 gfc_add_block_to_block (&se->pre, &rse.post);
4734 /* For everything else, just evaluate the expression. */
4736 /* Create a temporary to hold the value. */
4737 type = gfc_typenode_for_spec (&fsym->ts);
4738 temp_vars[n] = gfc_create_var (type, fsym->name);
4740 gfc_conv_expr (&lse, args->expr);
4742 gfc_add_block_to_block (&se->pre, &lse.pre);
4743 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4744 gfc_add_block_to_block (&se->pre, &lse.post);
4750 /* Use the temporary variables in place of the real ones. */
4751 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4752 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4754 gfc_conv_expr (se, sym->value);
4756 if (sym->ts.type == BT_CHARACTER)
4758 gfc_conv_const_charlen (sym->ts.u.cl);
4760 /* Force the expression to the correct length. */
4761 if (!INTEGER_CST_P (se->string_length)
4762 || tree_int_cst_lt (se->string_length,
4763 sym->ts.u.cl->backend_decl))
4765 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4766 tmp = gfc_create_var (type, sym->name);
4767 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4768 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4769 sym->ts.kind, se->string_length, se->expr,
4773 se->string_length = sym->ts.u.cl->backend_decl;
4776 /* Restore the original variables. */
4777 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4778 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4783 /* Translate a function expression. */
4786 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4790 if (expr->value.function.isym)
4792 gfc_conv_intrinsic_function (se, expr);
4796 /* We distinguish statement functions from general functions to improve
4797 runtime performance. */
4798 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4800 gfc_conv_statement_function (se, expr);
4804 /* expr.value.function.esym is the resolved (specific) function symbol for
4805 most functions. However this isn't set for dummy procedures. */
4806 sym = expr->value.function.esym;
4808 sym = expr->symtree->n.sym;
4810 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4814 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4817 is_zero_initializer_p (gfc_expr * expr)
4819 if (expr->expr_type != EXPR_CONSTANT)
4822 /* We ignore constants with prescribed memory representations for now. */
4823 if (expr->representation.string)
4826 switch (expr->ts.type)
4829 return mpz_cmp_si (expr->value.integer, 0) == 0;
4832 return mpfr_zero_p (expr->value.real)
4833 && MPFR_SIGN (expr->value.real) >= 0;
4836 return expr->value.logical == 0;
4839 return mpfr_zero_p (mpc_realref (expr->value.complex))
4840 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4841 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4842 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4852 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4857 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
4858 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
4860 gfc_conv_tmp_array_ref (se);
4864 /* Build a static initializer. EXPR is the expression for the initial value.
4865 The other parameters describe the variable of the component being
4866 initialized. EXPR may be null. */
4869 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4870 bool array, bool pointer, bool procptr)
4874 if (!(expr || pointer || procptr))
4877 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4878 (these are the only two iso_c_binding derived types that can be
4879 used as initialization expressions). If so, we need to modify
4880 the 'expr' to be that for a (void *). */
4881 if (expr != NULL && expr->ts.type == BT_DERIVED
4882 && expr->ts.is_iso_c && expr->ts.u.derived)
4884 gfc_symbol *derived = expr->ts.u.derived;
4886 /* The derived symbol has already been converted to a (void *). Use
4888 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4889 expr->ts.f90_type = derived->ts.f90_type;
4891 gfc_init_se (&se, NULL);
4892 gfc_conv_constant (&se, expr);
4893 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4897 if (array && !procptr)
4900 /* Arrays need special handling. */
4902 ctor = gfc_build_null_descriptor (type);
4903 /* Special case assigning an array to zero. */
4904 else if (is_zero_initializer_p (expr))
4905 ctor = build_constructor (type, NULL);
4907 ctor = gfc_conv_array_initializer (type, expr);
4908 TREE_STATIC (ctor) = 1;
4911 else if (pointer || procptr)
4913 if (!expr || expr->expr_type == EXPR_NULL)
4914 return fold_convert (type, null_pointer_node);
4917 gfc_init_se (&se, NULL);
4918 se.want_pointer = 1;
4919 gfc_conv_expr (&se, expr);
4920 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4930 gfc_init_se (&se, NULL);
4931 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4932 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4934 gfc_conv_structure (&se, expr, 1);
4935 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4936 TREE_STATIC (se.expr) = 1;
4941 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4942 TREE_STATIC (ctor) = 1;
4947 gfc_init_se (&se, NULL);
4948 gfc_conv_constant (&se, expr);
4949 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4956 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4962 gfc_array_info *lss_array;
4969 gfc_start_block (&block);
4971 /* Initialize the scalarizer. */
4972 gfc_init_loopinfo (&loop);
4974 gfc_init_se (&lse, NULL);
4975 gfc_init_se (&rse, NULL);
4978 rss = gfc_walk_expr (expr);
4979 if (rss == gfc_ss_terminator)
4980 /* The rhs is scalar. Add a ss for the expression. */
4981 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4983 /* Create a SS for the destination. */
4984 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4986 lss_array = &lss->info->data.array;
4987 lss_array->shape = gfc_get_shape (cm->as->rank);
4988 lss_array->descriptor = dest;
4989 lss_array->data = gfc_conv_array_data (dest);
4990 lss_array->offset = gfc_conv_array_offset (dest);
4991 for (n = 0; n < cm->as->rank; n++)
4993 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
4994 lss_array->stride[n] = gfc_index_one_node;
4996 mpz_init (lss_array->shape[n]);
4997 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
4998 cm->as->lower[n]->value.integer);
4999 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
5002 /* Associate the SS with the loop. */
5003 gfc_add_ss_to_loop (&loop, lss);
5004 gfc_add_ss_to_loop (&loop, rss);
5006 /* Calculate the bounds of the scalarization. */
5007 gfc_conv_ss_startstride (&loop);
5009 /* Setup the scalarizing loops. */
5010 gfc_conv_loop_setup (&loop, &expr->where);
5012 /* Setup the gfc_se structures. */
5013 gfc_copy_loopinfo_to_se (&lse, &loop);
5014 gfc_copy_loopinfo_to_se (&rse, &loop);
5017 gfc_mark_ss_chain_used (rss, 1);
5019 gfc_mark_ss_chain_used (lss, 1);
5021 /* Start the scalarized loop body. */
5022 gfc_start_scalarized_body (&loop, &body);
5024 gfc_conv_tmp_array_ref (&lse);
5025 if (cm->ts.type == BT_CHARACTER)
5026 lse.string_length = cm->ts.u.cl->backend_decl;
5028 gfc_conv_expr (&rse, expr);
5030 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
5031 gfc_add_expr_to_block (&body, tmp);
5033 gcc_assert (rse.ss == gfc_ss_terminator);
5035 /* Generate the copying loops. */
5036 gfc_trans_scalarizing_loops (&loop, &body);
5038 /* Wrap the whole thing up. */
5039 gfc_add_block_to_block (&block, &loop.pre);
5040 gfc_add_block_to_block (&block, &loop.post);
5042 gcc_assert (lss_array->shape != NULL);
5043 gfc_free_shape (&lss_array->shape, cm->as->rank);
5044 gfc_cleanup_loop (&loop);
5046 return gfc_finish_block (&block);
5051 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
5062 gfc_expr *arg = NULL;
5064 gfc_start_block (&block);
5065 gfc_init_se (&se, NULL);
5067 /* Get the descriptor for the expressions. */
5068 rss = gfc_walk_expr (expr);
5069 se.want_pointer = 0;
5070 gfc_conv_expr_descriptor (&se, expr, rss);
5071 gfc_add_block_to_block (&block, &se.pre);
5072 gfc_add_modify (&block, dest, se.expr);
5074 /* Deal with arrays of derived types with allocatable components. */
5075 if (cm->ts.type == BT_DERIVED
5076 && cm->ts.u.derived->attr.alloc_comp)
5077 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
5081 tmp = gfc_duplicate_allocatable (dest, se.expr,
5082 TREE_TYPE(cm->backend_decl),
5085 gfc_add_expr_to_block (&block, tmp);
5086 gfc_add_block_to_block (&block, &se.post);
5088 if (expr->expr_type != EXPR_VARIABLE)
5089 gfc_conv_descriptor_data_set (&block, se.expr,
5092 /* We need to know if the argument of a conversion function is a
5093 variable, so that the correct lower bound can be used. */
5094 if (expr->expr_type == EXPR_FUNCTION
5095 && expr->value.function.isym
5096 && expr->value.function.isym->conversion
5097 && expr->value.function.actual->expr
5098 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
5099 arg = expr->value.function.actual->expr;
5101 /* Obtain the array spec of full array references. */
5103 as = gfc_get_full_arrayspec_from_expr (arg);
5105 as = gfc_get_full_arrayspec_from_expr (expr);
5107 /* Shift the lbound and ubound of temporaries to being unity,
5108 rather than zero, based. Always calculate the offset. */
5109 offset = gfc_conv_descriptor_offset_get (dest);
5110 gfc_add_modify (&block, offset, gfc_index_zero_node);
5111 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
5113 for (n = 0; n < expr->rank; n++)
5118 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5119 TODO It looks as if gfc_conv_expr_descriptor should return
5120 the correct bounds and that the following should not be
5121 necessary. This would simplify gfc_conv_intrinsic_bound
5123 if (as && as->lower[n])
5126 gfc_init_se (&lbse, NULL);
5127 gfc_conv_expr (&lbse, as->lower[n]);
5128 gfc_add_block_to_block (&block, &lbse.pre);
5129 lbound = gfc_evaluate_now (lbse.expr, &block);
5133 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
5134 lbound = gfc_conv_descriptor_lbound_get (tmp,
5138 lbound = gfc_conv_descriptor_lbound_get (dest,
5141 lbound = gfc_index_one_node;
5143 lbound = fold_convert (gfc_array_index_type, lbound);
5145 /* Shift the bounds and set the offset accordingly. */
5146 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
5147 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5148 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
5149 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5151 gfc_conv_descriptor_ubound_set (&block, dest,
5152 gfc_rank_cst[n], tmp);
5153 gfc_conv_descriptor_lbound_set (&block, dest,
5154 gfc_rank_cst[n], lbound);
5156 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5157 gfc_conv_descriptor_lbound_get (dest,
5159 gfc_conv_descriptor_stride_get (dest,
5161 gfc_add_modify (&block, tmp2, tmp);
5162 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5164 gfc_conv_descriptor_offset_set (&block, dest, tmp);
5169 /* If a conversion expression has a null data pointer
5170 argument, nullify the allocatable component. */
5174 if (arg->symtree->n.sym->attr.allocatable
5175 || arg->symtree->n.sym->attr.pointer)
5177 non_null_expr = gfc_finish_block (&block);
5178 gfc_start_block (&block);
5179 gfc_conv_descriptor_data_set (&block, dest,
5181 null_expr = gfc_finish_block (&block);
5182 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
5183 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5184 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5185 return build3_v (COND_EXPR, tmp,
5186 null_expr, non_null_expr);
5190 return gfc_finish_block (&block);
5194 /* Assign a single component of a derived type constructor. */
5197 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
5205 gfc_start_block (&block);
5207 if (cm->attr.pointer)
5209 gfc_init_se (&se, NULL);
5210 /* Pointer component. */
5211 if (cm->attr.dimension)
5213 /* Array pointer. */
5214 if (expr->expr_type == EXPR_NULL)
5215 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5218 rss = gfc_walk_expr (expr);
5219 se.direct_byref = 1;
5221 gfc_conv_expr_descriptor (&se, expr, rss);
5222 gfc_add_block_to_block (&block, &se.pre);
5223 gfc_add_block_to_block (&block, &se.post);
5228 /* Scalar pointers. */
5229 se.want_pointer = 1;
5230 gfc_conv_expr (&se, expr);
5231 gfc_add_block_to_block (&block, &se.pre);
5232 gfc_add_modify (&block, dest,
5233 fold_convert (TREE_TYPE (dest), se.expr));
5234 gfc_add_block_to_block (&block, &se.post);
5237 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
5239 /* NULL initialization for CLASS components. */
5240 tmp = gfc_trans_structure_assign (dest,
5241 gfc_class_null_initializer (&cm->ts));
5242 gfc_add_expr_to_block (&block, tmp);
5244 else if (cm->attr.dimension && !cm->attr.proc_pointer)
5246 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
5247 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5248 else if (cm->attr.allocatable)
5250 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
5251 gfc_add_expr_to_block (&block, tmp);
5255 tmp = gfc_trans_subarray_assign (dest, cm, expr);
5256 gfc_add_expr_to_block (&block, tmp);
5259 else if (expr->ts.type == BT_DERIVED)
5261 if (expr->expr_type != EXPR_STRUCTURE)
5263 gfc_init_se (&se, NULL);
5264 gfc_conv_expr (&se, expr);
5265 gfc_add_block_to_block (&block, &se.pre);
5266 gfc_add_modify (&block, dest,
5267 fold_convert (TREE_TYPE (dest), se.expr));
5268 gfc_add_block_to_block (&block, &se.post);
5272 /* Nested constructors. */
5273 tmp = gfc_trans_structure_assign (dest, expr);
5274 gfc_add_expr_to_block (&block, tmp);
5279 /* Scalar component. */
5280 gfc_init_se (&se, NULL);
5281 gfc_init_se (&lse, NULL);
5283 gfc_conv_expr (&se, expr);
5284 if (cm->ts.type == BT_CHARACTER)
5285 lse.string_length = cm->ts.u.cl->backend_decl;
5287 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
5288 gfc_add_expr_to_block (&block, tmp);
5290 return gfc_finish_block (&block);
5293 /* Assign a derived type constructor to a variable. */
5296 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
5304 gfc_start_block (&block);
5305 cm = expr->ts.u.derived->components;
5307 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
5308 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
5309 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
5313 gcc_assert (cm->backend_decl == NULL);
5314 gfc_init_se (&se, NULL);
5315 gfc_init_se (&lse, NULL);
5316 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
5318 gfc_add_modify (&block, lse.expr,
5319 fold_convert (TREE_TYPE (lse.expr), se.expr));
5321 return gfc_finish_block (&block);
5324 for (c = gfc_constructor_first (expr->value.constructor);
5325 c; c = gfc_constructor_next (c), cm = cm->next)
5327 /* Skip absent members in default initializers. */
5331 field = cm->backend_decl;
5332 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
5333 dest, field, NULL_TREE);
5334 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
5335 gfc_add_expr_to_block (&block, tmp);
5337 return gfc_finish_block (&block);
5340 /* Build an expression for a constructor. If init is nonzero then
5341 this is part of a static variable initializer. */
5344 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
5351 VEC(constructor_elt,gc) *v = NULL;
5353 gcc_assert (se->ss == NULL);
5354 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
5355 type = gfc_typenode_for_spec (&expr->ts);
5359 /* Create a temporary variable and fill it in. */
5360 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
5361 tmp = gfc_trans_structure_assign (se->expr, expr);
5362 gfc_add_expr_to_block (&se->pre, tmp);
5366 cm = expr->ts.u.derived->components;
5368 for (c = gfc_constructor_first (expr->value.constructor);
5369 c; c = gfc_constructor_next (c), cm = cm->next)
5371 /* Skip absent members in default initializers and allocatable
5372 components. Although the latter have a default initializer
5373 of EXPR_NULL,... by default, the static nullify is not needed
5374 since this is done every time we come into scope. */
5375 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
5378 if (strcmp (cm->name, "_size") == 0)
5380 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
5381 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
5383 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
5384 && strcmp (cm->name, "_extends") == 0)
5388 vtabs = cm->initializer->symtree->n.sym;
5389 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
5390 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
5394 val = gfc_conv_initializer (c->expr, &cm->ts,
5395 TREE_TYPE (cm->backend_decl),
5396 cm->attr.dimension, cm->attr.pointer,
5397 cm->attr.proc_pointer);
5399 /* Append it to the constructor list. */
5400 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
5403 se->expr = build_constructor (type, v);
5405 TREE_CONSTANT (se->expr) = 1;
5409 /* Translate a substring expression. */
5412 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
5418 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
5420 se->expr = gfc_build_wide_string_const (expr->ts.kind,
5421 expr->value.character.length,
5422 expr->value.character.string);
5424 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
5425 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
5428 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
5432 /* Entry point for expression translation. Evaluates a scalar quantity.
5433 EXPR is the expression to be translated, and SE is the state structure if
5434 called from within the scalarized. */
5437 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
5442 if (ss && ss->info->expr == expr
5443 && (ss->info->type == GFC_SS_SCALAR
5444 || ss->info->type == GFC_SS_REFERENCE))
5446 gfc_ss_info *ss_info;
5449 /* Substitute a scalar expression evaluated outside the scalarization
5451 se->expr = ss_info->data.scalar.value;
5452 /* If the reference can be NULL, the value field contains the reference,
5453 not the value the reference points to (see gfc_add_loop_ss_code). */
5454 if (ss_info->data.scalar.can_be_null_ref)
5455 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5457 se->string_length = ss_info->string_length;
5458 gfc_advance_se_ss_chain (se);
5462 /* We need to convert the expressions for the iso_c_binding derived types.
5463 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
5464 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
5465 typespec for the C_PTR and C_FUNPTR symbols, which has already been
5466 updated to be an integer with a kind equal to the size of a (void *). */
5467 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
5468 && expr->ts.u.derived->attr.is_iso_c)
5470 if (expr->expr_type == EXPR_VARIABLE
5471 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
5472 || expr->symtree->n.sym->intmod_sym_id
5473 == ISOCBINDING_NULL_FUNPTR))
5475 /* Set expr_type to EXPR_NULL, which will result in
5476 null_pointer_node being used below. */
5477 expr->expr_type = EXPR_NULL;
5481 /* Update the type/kind of the expression to be what the new
5482 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
5483 expr->ts.type = expr->ts.u.derived->ts.type;
5484 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
5485 expr->ts.kind = expr->ts.u.derived->ts.kind;
5489 gfc_fix_class_refs (expr);
5491 switch (expr->expr_type)
5494 gfc_conv_expr_op (se, expr);
5498 gfc_conv_function_expr (se, expr);
5502 gfc_conv_constant (se, expr);
5506 gfc_conv_variable (se, expr);
5510 se->expr = null_pointer_node;
5513 case EXPR_SUBSTRING:
5514 gfc_conv_substring_expr (se, expr);
5517 case EXPR_STRUCTURE:
5518 gfc_conv_structure (se, expr, 0);
5522 gfc_conv_array_constructor_expr (se, expr);
5531 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
5532 of an assignment. */
5534 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
5536 gfc_conv_expr (se, expr);
5537 /* All numeric lvalues should have empty post chains. If not we need to
5538 figure out a way of rewriting an lvalue so that it has no post chain. */
5539 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
5542 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
5543 numeric expressions. Used for scalar values where inserting cleanup code
5546 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
5550 gcc_assert (expr->ts.type != BT_CHARACTER);
5551 gfc_conv_expr (se, expr);
5554 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
5555 gfc_add_modify (&se->pre, val, se->expr);
5557 gfc_add_block_to_block (&se->pre, &se->post);
5561 /* Helper to translate an expression and convert it to a particular type. */
5563 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
5565 gfc_conv_expr_val (se, expr);
5566 se->expr = convert (type, se->expr);
5570 /* Converts an expression so that it can be passed by reference. Scalar
5574 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
5580 if (ss && ss->info->expr == expr
5581 && ss->info->type == GFC_SS_REFERENCE)
5583 /* Returns a reference to the scalar evaluated outside the loop
5585 gfc_conv_expr (se, expr);
5586 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5590 if (expr->ts.type == BT_CHARACTER)
5592 gfc_conv_expr (se, expr);
5593 gfc_conv_string_parameter (se);
5597 if (expr->expr_type == EXPR_VARIABLE)
5599 se->want_pointer = 1;
5600 gfc_conv_expr (se, expr);
5603 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5604 gfc_add_modify (&se->pre, var, se->expr);
5605 gfc_add_block_to_block (&se->pre, &se->post);
5611 if (expr->expr_type == EXPR_FUNCTION
5612 && ((expr->value.function.esym
5613 && expr->value.function.esym->result->attr.pointer
5614 && !expr->value.function.esym->result->attr.dimension)
5615 || (!expr->value.function.esym
5616 && expr->symtree->n.sym->attr.pointer
5617 && !expr->symtree->n.sym->attr.dimension)))
5619 se->want_pointer = 1;
5620 gfc_conv_expr (se, expr);
5621 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5622 gfc_add_modify (&se->pre, var, se->expr);
5627 gfc_conv_expr (se, expr);
5629 /* Create a temporary var to hold the value. */
5630 if (TREE_CONSTANT (se->expr))
5632 tree tmp = se->expr;
5633 STRIP_TYPE_NOPS (tmp);
5634 var = build_decl (input_location,
5635 CONST_DECL, NULL, TREE_TYPE (tmp));
5636 DECL_INITIAL (var) = tmp;
5637 TREE_STATIC (var) = 1;
5642 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5643 gfc_add_modify (&se->pre, var, se->expr);
5645 gfc_add_block_to_block (&se->pre, &se->post);
5647 /* Take the address of that value. */
5648 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5653 gfc_trans_pointer_assign (gfc_code * code)
5655 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5659 /* Generate code for a pointer assignment. */
5662 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5673 gfc_start_block (&block);
5675 gfc_init_se (&lse, NULL);
5677 lss = gfc_walk_expr (expr1);
5678 rss = gfc_walk_expr (expr2);
5679 if (lss == gfc_ss_terminator)
5681 /* Scalar pointers. */
5682 lse.want_pointer = 1;
5683 gfc_conv_expr (&lse, expr1);
5684 gcc_assert (rss == gfc_ss_terminator);
5685 gfc_init_se (&rse, NULL);
5686 rse.want_pointer = 1;
5687 gfc_conv_expr (&rse, expr2);
5689 if (expr1->symtree->n.sym->attr.proc_pointer
5690 && expr1->symtree->n.sym->attr.dummy)
5691 lse.expr = build_fold_indirect_ref_loc (input_location,
5694 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5695 && expr2->symtree->n.sym->attr.dummy)
5696 rse.expr = build_fold_indirect_ref_loc (input_location,
5699 gfc_add_block_to_block (&block, &lse.pre);
5700 gfc_add_block_to_block (&block, &rse.pre);
5702 /* Check character lengths if character expression. The test is only
5703 really added if -fbounds-check is enabled. Exclude deferred
5704 character length lefthand sides. */
5705 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5706 && !(expr1->ts.deferred
5707 && (TREE_CODE (lse.string_length) == VAR_DECL))
5708 && !expr1->symtree->n.sym->attr.proc_pointer
5709 && !gfc_is_proc_ptr_comp (expr1, NULL))
5711 gcc_assert (expr2->ts.type == BT_CHARACTER);
5712 gcc_assert (lse.string_length && rse.string_length);
5713 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5714 lse.string_length, rse.string_length,
5718 /* The assignment to an deferred character length sets the string
5719 length to that of the rhs. */
5720 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5722 if (expr2->expr_type != EXPR_NULL)
5723 gfc_add_modify (&block, lse.string_length, rse.string_length);
5725 gfc_add_modify (&block, lse.string_length,
5726 build_int_cst (gfc_charlen_type_node, 0));
5729 gfc_add_modify (&block, lse.expr,
5730 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5732 gfc_add_block_to_block (&block, &rse.post);
5733 gfc_add_block_to_block (&block, &lse.post);
5740 tree strlen_rhs = NULL_TREE;
5742 /* Array pointer. Find the last reference on the LHS and if it is an
5743 array section ref, we're dealing with bounds remapping. In this case,
5744 set it to AR_FULL so that gfc_conv_expr_descriptor does
5745 not see it and process the bounds remapping afterwards explicitely. */
5746 for (remap = expr1->ref; remap; remap = remap->next)
5747 if (!remap->next && remap->type == REF_ARRAY
5748 && remap->u.ar.type == AR_SECTION)
5750 remap->u.ar.type = AR_FULL;
5753 rank_remap = (remap && remap->u.ar.end[0]);
5755 gfc_conv_expr_descriptor (&lse, expr1, lss);
5756 strlen_lhs = lse.string_length;
5759 if (expr2->expr_type == EXPR_NULL)
5761 /* Just set the data pointer to null. */
5762 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5764 else if (rank_remap)
5766 /* If we are rank-remapping, just get the RHS's descriptor and
5767 process this later on. */
5768 gfc_init_se (&rse, NULL);
5769 rse.direct_byref = 1;
5770 rse.byref_noassign = 1;
5771 gfc_conv_expr_descriptor (&rse, expr2, rss);
5772 strlen_rhs = rse.string_length;
5774 else if (expr2->expr_type == EXPR_VARIABLE)
5776 /* Assign directly to the LHS's descriptor. */
5777 lse.direct_byref = 1;
5778 gfc_conv_expr_descriptor (&lse, expr2, rss);
5779 strlen_rhs = lse.string_length;
5781 /* If this is a subreference array pointer assignment, use the rhs
5782 descriptor element size for the lhs span. */
5783 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5785 decl = expr1->symtree->n.sym->backend_decl;
5786 gfc_init_se (&rse, NULL);
5787 rse.descriptor_only = 1;
5788 gfc_conv_expr (&rse, expr2);
5789 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5790 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5791 if (!INTEGER_CST_P (tmp))
5792 gfc_add_block_to_block (&lse.post, &rse.pre);
5793 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5798 /* Assign to a temporary descriptor and then copy that
5799 temporary to the pointer. */
5800 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5803 lse.direct_byref = 1;
5804 gfc_conv_expr_descriptor (&lse, expr2, rss);
5805 strlen_rhs = lse.string_length;
5806 gfc_add_modify (&lse.pre, desc, tmp);
5809 gfc_add_block_to_block (&block, &lse.pre);
5811 gfc_add_block_to_block (&block, &rse.pre);
5813 /* If we do bounds remapping, update LHS descriptor accordingly. */
5817 gcc_assert (remap->u.ar.dimen == expr1->rank);
5821 /* Do rank remapping. We already have the RHS's descriptor
5822 converted in rse and now have to build the correct LHS
5823 descriptor for it. */
5827 tree lbound, ubound;
5830 dtype = gfc_conv_descriptor_dtype (desc);
5831 tmp = gfc_get_dtype (TREE_TYPE (desc));
5832 gfc_add_modify (&block, dtype, tmp);
5834 /* Copy data pointer. */
5835 data = gfc_conv_descriptor_data_get (rse.expr);
5836 gfc_conv_descriptor_data_set (&block, desc, data);
5838 /* Copy offset but adjust it such that it would correspond
5839 to a lbound of zero. */
5840 offs = gfc_conv_descriptor_offset_get (rse.expr);
5841 for (dim = 0; dim < expr2->rank; ++dim)
5843 stride = gfc_conv_descriptor_stride_get (rse.expr,
5845 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5847 tmp = fold_build2_loc (input_location, MULT_EXPR,
5848 gfc_array_index_type, stride, lbound);
5849 offs = fold_build2_loc (input_location, PLUS_EXPR,
5850 gfc_array_index_type, offs, tmp);
5852 gfc_conv_descriptor_offset_set (&block, desc, offs);
5854 /* Set the bounds as declared for the LHS and calculate strides as
5855 well as another offset update accordingly. */
5856 stride = gfc_conv_descriptor_stride_get (rse.expr,
5858 for (dim = 0; dim < expr1->rank; ++dim)
5863 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5865 /* Convert declared bounds. */
5866 gfc_init_se (&lower_se, NULL);
5867 gfc_init_se (&upper_se, NULL);
5868 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5869 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5871 gfc_add_block_to_block (&block, &lower_se.pre);
5872 gfc_add_block_to_block (&block, &upper_se.pre);
5874 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5875 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5877 lbound = gfc_evaluate_now (lbound, &block);
5878 ubound = gfc_evaluate_now (ubound, &block);
5880 gfc_add_block_to_block (&block, &lower_se.post);
5881 gfc_add_block_to_block (&block, &upper_se.post);
5883 /* Set bounds in descriptor. */
5884 gfc_conv_descriptor_lbound_set (&block, desc,
5885 gfc_rank_cst[dim], lbound);
5886 gfc_conv_descriptor_ubound_set (&block, desc,
5887 gfc_rank_cst[dim], ubound);
5890 stride = gfc_evaluate_now (stride, &block);
5891 gfc_conv_descriptor_stride_set (&block, desc,
5892 gfc_rank_cst[dim], stride);
5894 /* Update offset. */
5895 offs = gfc_conv_descriptor_offset_get (desc);
5896 tmp = fold_build2_loc (input_location, MULT_EXPR,
5897 gfc_array_index_type, lbound, stride);
5898 offs = fold_build2_loc (input_location, MINUS_EXPR,
5899 gfc_array_index_type, offs, tmp);
5900 offs = gfc_evaluate_now (offs, &block);
5901 gfc_conv_descriptor_offset_set (&block, desc, offs);
5903 /* Update stride. */
5904 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5905 stride = fold_build2_loc (input_location, MULT_EXPR,
5906 gfc_array_index_type, stride, tmp);
5911 /* Bounds remapping. Just shift the lower bounds. */
5913 gcc_assert (expr1->rank == expr2->rank);
5915 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5919 gcc_assert (remap->u.ar.start[dim]);
5920 gcc_assert (!remap->u.ar.end[dim]);
5921 gfc_init_se (&lbound_se, NULL);
5922 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5924 gfc_add_block_to_block (&block, &lbound_se.pre);
5925 gfc_conv_shift_descriptor_lbound (&block, desc,
5926 dim, lbound_se.expr);
5927 gfc_add_block_to_block (&block, &lbound_se.post);
5932 /* Check string lengths if applicable. The check is only really added
5933 to the output code if -fbounds-check is enabled. */
5934 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5936 gcc_assert (expr2->ts.type == BT_CHARACTER);
5937 gcc_assert (strlen_lhs && strlen_rhs);
5938 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5939 strlen_lhs, strlen_rhs, &block);
5942 /* If rank remapping was done, check with -fcheck=bounds that
5943 the target is at least as large as the pointer. */
5944 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5950 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5951 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5953 lsize = gfc_evaluate_now (lsize, &block);
5954 rsize = gfc_evaluate_now (rsize, &block);
5955 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5958 msg = _("Target of rank remapping is too small (%ld < %ld)");
5959 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5963 gfc_add_block_to_block (&block, &lse.post);
5965 gfc_add_block_to_block (&block, &rse.post);
5968 return gfc_finish_block (&block);
5972 /* Makes sure se is suitable for passing as a function string parameter. */
5973 /* TODO: Need to check all callers of this function. It may be abused. */
5976 gfc_conv_string_parameter (gfc_se * se)
5980 if (TREE_CODE (se->expr) == STRING_CST)
5982 type = TREE_TYPE (TREE_TYPE (se->expr));
5983 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5987 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5989 if (TREE_CODE (se->expr) != INDIRECT_REF)
5991 type = TREE_TYPE (se->expr);
5992 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5996 type = gfc_get_character_type_len (gfc_default_character_kind,
5998 type = build_pointer_type (type);
5999 se->expr = gfc_build_addr_expr (type, se->expr);
6003 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
6007 /* Generate code for assignment of scalar variables. Includes character
6008 strings and derived types with allocatable components.
6009 If you know that the LHS has no allocations, set dealloc to false. */
6012 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
6013 bool l_is_temp, bool r_is_var, bool dealloc)
6019 gfc_init_block (&block);
6021 if (ts.type == BT_CHARACTER)
6026 if (lse->string_length != NULL_TREE)
6028 gfc_conv_string_parameter (lse);
6029 gfc_add_block_to_block (&block, &lse->pre);
6030 llen = lse->string_length;
6033 if (rse->string_length != NULL_TREE)
6035 gcc_assert (rse->string_length != NULL_TREE);
6036 gfc_conv_string_parameter (rse);
6037 gfc_add_block_to_block (&block, &rse->pre);
6038 rlen = rse->string_length;
6041 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
6042 rse->expr, ts.kind);
6044 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
6048 /* Are the rhs and the lhs the same? */
6051 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6052 gfc_build_addr_expr (NULL_TREE, lse->expr),
6053 gfc_build_addr_expr (NULL_TREE, rse->expr));
6054 cond = gfc_evaluate_now (cond, &lse->pre);
6057 /* Deallocate the lhs allocated components as long as it is not
6058 the same as the rhs. This must be done following the assignment
6059 to prevent deallocating data that could be used in the rhs
6061 if (!l_is_temp && dealloc)
6063 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
6064 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
6066 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
6068 gfc_add_expr_to_block (&lse->post, tmp);
6071 gfc_add_block_to_block (&block, &rse->pre);
6072 gfc_add_block_to_block (&block, &lse->pre);
6074 gfc_add_modify (&block, lse->expr,
6075 fold_convert (TREE_TYPE (lse->expr), rse->expr));
6077 /* Do a deep copy if the rhs is a variable, if it is not the
6081 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
6082 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
6084 gfc_add_expr_to_block (&block, tmp);
6087 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
6089 gfc_add_block_to_block (&block, &lse->pre);
6090 gfc_add_block_to_block (&block, &rse->pre);
6091 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
6092 TREE_TYPE (lse->expr), rse->expr);
6093 gfc_add_modify (&block, lse->expr, tmp);
6097 gfc_add_block_to_block (&block, &lse->pre);
6098 gfc_add_block_to_block (&block, &rse->pre);
6100 gfc_add_modify (&block, lse->expr,
6101 fold_convert (TREE_TYPE (lse->expr), rse->expr));
6104 gfc_add_block_to_block (&block, &lse->post);
6105 gfc_add_block_to_block (&block, &rse->post);
6107 return gfc_finish_block (&block);
6111 /* There are quite a lot of restrictions on the optimisation in using an
6112 array function assign without a temporary. */
6115 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
6118 bool seen_array_ref;
6120 gfc_symbol *sym = expr1->symtree->n.sym;
6122 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6123 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
6126 /* Elemental functions are scalarized so that they don't need a
6127 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6128 they would need special treatment in gfc_trans_arrayfunc_assign. */
6129 if (expr2->value.function.esym != NULL
6130 && expr2->value.function.esym->attr.elemental)
6133 /* Need a temporary if rhs is not FULL or a contiguous section. */
6134 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
6137 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6138 if (gfc_ref_needs_temporary_p (expr1->ref))
6141 /* Functions returning pointers or allocatables need temporaries. */
6142 c = expr2->value.function.esym
6143 ? (expr2->value.function.esym->attr.pointer
6144 || expr2->value.function.esym->attr.allocatable)
6145 : (expr2->symtree->n.sym->attr.pointer
6146 || expr2->symtree->n.sym->attr.allocatable);
6150 /* Character array functions need temporaries unless the
6151 character lengths are the same. */
6152 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
6154 if (expr1->ts.u.cl->length == NULL
6155 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6158 if (expr2->ts.u.cl->length == NULL
6159 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6162 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
6163 expr2->ts.u.cl->length->value.integer) != 0)
6167 /* Check that no LHS component references appear during an array
6168 reference. This is needed because we do not have the means to
6169 span any arbitrary stride with an array descriptor. This check
6170 is not needed for the rhs because the function result has to be
6172 seen_array_ref = false;
6173 for (ref = expr1->ref; ref; ref = ref->next)
6175 if (ref->type == REF_ARRAY)
6176 seen_array_ref= true;
6177 else if (ref->type == REF_COMPONENT && seen_array_ref)
6181 /* Check for a dependency. */
6182 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
6183 expr2->value.function.esym,
6184 expr2->value.function.actual,
6188 /* If we have reached here with an intrinsic function, we do not
6189 need a temporary except in the particular case that reallocation
6190 on assignment is active and the lhs is allocatable and a target. */
6191 if (expr2->value.function.isym)
6192 return (gfc_option.flag_realloc_lhs
6193 && sym->attr.allocatable
6194 && sym->attr.target);
6196 /* If the LHS is a dummy, we need a temporary if it is not
6198 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
6201 /* If the lhs has been host_associated, is in common, a pointer or is
6202 a target and the function is not using a RESULT variable, aliasing
6203 can occur and a temporary is needed. */
6204 if ((sym->attr.host_assoc
6205 || sym->attr.in_common
6206 || sym->attr.pointer
6207 || sym->attr.cray_pointee
6208 || sym->attr.target)
6209 && expr2->symtree != NULL
6210 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
6213 /* A PURE function can unconditionally be called without a temporary. */
6214 if (expr2->value.function.esym != NULL
6215 && expr2->value.function.esym->attr.pure)
6218 /* Implicit_pure functions are those which could legally be declared
6220 if (expr2->value.function.esym != NULL
6221 && expr2->value.function.esym->attr.implicit_pure)
6224 if (!sym->attr.use_assoc
6225 && !sym->attr.in_common
6226 && !sym->attr.pointer
6227 && !sym->attr.target
6228 && !sym->attr.cray_pointee
6229 && expr2->value.function.esym)
6231 /* A temporary is not needed if the function is not contained and
6232 the variable is local or host associated and not a pointer or
6234 if (!expr2->value.function.esym->attr.contained)
6237 /* A temporary is not needed if the lhs has never been host
6238 associated and the procedure is contained. */
6239 else if (!sym->attr.host_assoc)
6242 /* A temporary is not needed if the variable is local and not
6243 a pointer, a target or a result. */
6245 && expr2->value.function.esym->ns == sym->ns->parent)
6249 /* Default to temporary use. */
6254 /* Provide the loop info so that the lhs descriptor can be built for
6255 reallocatable assignments from extrinsic function calls. */
6258 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
6261 /* Signal that the function call should not be made by
6262 gfc_conv_loop_setup. */
6263 se->ss->is_alloc_lhs = 1;
6264 gfc_init_loopinfo (loop);
6265 gfc_add_ss_to_loop (loop, *ss);
6266 gfc_add_ss_to_loop (loop, se->ss);
6267 gfc_conv_ss_startstride (loop);
6268 gfc_conv_loop_setup (loop, where);
6269 gfc_copy_loopinfo_to_se (se, loop);
6270 gfc_add_block_to_block (&se->pre, &loop->pre);
6271 gfc_add_block_to_block (&se->pre, &loop->post);
6272 se->ss->is_alloc_lhs = 0;
6276 /* For assignment to a reallocatable lhs from intrinsic functions,
6277 replace the se.expr (ie. the result) with a temporary descriptor.
6278 Null the data field so that the library allocates space for the
6279 result. Free the data of the original descriptor after the function,
6280 in case it appears in an argument expression and transfer the
6281 result to the original descriptor. */
6284 fcncall_realloc_result (gfc_se *se, int rank)
6293 /* Use the allocation done by the library. Substitute the lhs
6294 descriptor with a copy, whose data field is nulled.*/
6295 desc = build_fold_indirect_ref_loc (input_location, se->expr);
6297 /* Unallocated, the descriptor does not have a dtype. */
6298 tmp = gfc_conv_descriptor_dtype (desc);
6299 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
6301 res_desc = gfc_evaluate_now (desc, &se->pre);
6302 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
6303 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
6305 /* Free the lhs after the function call and copy the result data to
6306 the lhs descriptor. */
6307 tmp = gfc_conv_descriptor_data_get (desc);
6308 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
6309 boolean_type_node, tmp,
6310 build_int_cst (TREE_TYPE (tmp), 0));
6311 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
6312 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
6313 gfc_add_expr_to_block (&se->post, tmp);
6315 tmp = gfc_conv_descriptor_data_get (res_desc);
6316 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
6318 /* Check that the shapes are the same between lhs and expression. */
6319 for (n = 0 ; n < rank; n++)
6322 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
6323 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
6324 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6325 gfc_array_index_type, tmp, tmp1);
6326 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
6327 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6328 gfc_array_index_type, tmp, tmp1);
6329 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
6330 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6331 gfc_array_index_type, tmp, tmp1);
6332 tmp = fold_build2_loc (input_location, NE_EXPR,
6333 boolean_type_node, tmp,
6334 gfc_index_zero_node);
6335 tmp = gfc_evaluate_now (tmp, &se->post);
6336 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6337 boolean_type_node, tmp,
6341 /* 'zero_cond' being true is equal to lhs not being allocated or the
6342 shapes being different. */
6343 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
6345 /* Now reset the bounds returned from the function call to bounds based
6346 on the lhs lbounds, except where the lhs is not allocated or the shapes
6347 of 'variable and 'expr' are different. Set the offset accordingly. */
6348 offset = gfc_index_zero_node;
6349 for (n = 0 ; n < rank; n++)
6353 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
6354 lbound = fold_build3_loc (input_location, COND_EXPR,
6355 gfc_array_index_type, zero_cond,
6356 gfc_index_one_node, lbound);
6357 lbound = gfc_evaluate_now (lbound, &se->post);
6359 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
6360 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6361 gfc_array_index_type, tmp, lbound);
6362 gfc_conv_descriptor_lbound_set (&se->post, desc,
6363 gfc_rank_cst[n], lbound);
6364 gfc_conv_descriptor_ubound_set (&se->post, desc,
6365 gfc_rank_cst[n], tmp);
6367 /* Accumulate the offset. */
6368 tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[n]);
6369 tmp = fold_build2_loc (input_location, MULT_EXPR,
6370 gfc_array_index_type,
6372 offset = fold_build2_loc (input_location, MINUS_EXPR,
6373 gfc_array_index_type,
6375 offset = gfc_evaluate_now (offset, &se->post);
6379 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
6384 /* Try to translate array(:) = func (...), where func is a transformational
6385 array function, without using a temporary. Returns NULL if this isn't the
6389 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
6393 gfc_component *comp = NULL;
6396 if (arrayfunc_assign_needs_temporary (expr1, expr2))
6399 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
6401 gcc_assert (expr2->value.function.isym
6402 || (gfc_is_proc_ptr_comp (expr2, &comp)
6403 && comp && comp->attr.dimension)
6404 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
6405 && expr2->value.function.esym->result->attr.dimension));
6407 ss = gfc_walk_expr (expr1);
6408 gcc_assert (ss != gfc_ss_terminator);
6409 gfc_init_se (&se, NULL);
6410 gfc_start_block (&se.pre);
6411 se.want_pointer = 1;
6413 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
6415 if (expr1->ts.type == BT_DERIVED
6416 && expr1->ts.u.derived->attr.alloc_comp)
6419 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
6421 gfc_add_expr_to_block (&se.pre, tmp);
6424 se.direct_byref = 1;
6425 se.ss = gfc_walk_expr (expr2);
6426 gcc_assert (se.ss != gfc_ss_terminator);
6428 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
6429 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
6430 Clearly, this cannot be done for an allocatable function result, since
6431 the shape of the result is unknown and, in any case, the function must
6432 correctly take care of the reallocation internally. For intrinsic
6433 calls, the array data is freed and the library takes care of allocation.
6434 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
6436 if (gfc_option.flag_realloc_lhs
6437 && gfc_is_reallocatable_lhs (expr1)
6438 && !gfc_expr_attr (expr1).codimension
6439 && !gfc_is_coindexed (expr1)
6440 && !(expr2->value.function.esym
6441 && expr2->value.function.esym->result->attr.allocatable))
6443 if (!expr2->value.function.isym)
6445 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
6446 ss->is_alloc_lhs = 1;
6449 fcncall_realloc_result (&se, expr1->rank);
6452 gfc_conv_function_expr (&se, expr2);
6453 gfc_add_block_to_block (&se.pre, &se.post);
6455 return gfc_finish_block (&se.pre);
6459 /* Try to efficiently translate array(:) = 0. Return NULL if this
6463 gfc_trans_zero_assign (gfc_expr * expr)
6465 tree dest, len, type;
6469 sym = expr->symtree->n.sym;
6470 dest = gfc_get_symbol_decl (sym);
6472 type = TREE_TYPE (dest);
6473 if (POINTER_TYPE_P (type))
6474 type = TREE_TYPE (type);
6475 if (!GFC_ARRAY_TYPE_P (type))
6478 /* Determine the length of the array. */
6479 len = GFC_TYPE_ARRAY_SIZE (type);
6480 if (!len || TREE_CODE (len) != INTEGER_CST)
6483 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6484 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
6485 fold_convert (gfc_array_index_type, tmp));
6487 /* If we are zeroing a local array avoid taking its address by emitting
6489 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
6490 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
6491 dest, build_constructor (TREE_TYPE (dest), NULL));
6493 /* Convert arguments to the correct types. */
6494 dest = fold_convert (pvoid_type_node, dest);
6495 len = fold_convert (size_type_node, len);
6497 /* Construct call to __builtin_memset. */
6498 tmp = build_call_expr_loc (input_location,
6499 builtin_decl_explicit (BUILT_IN_MEMSET),
6500 3, dest, integer_zero_node, len);
6501 return fold_convert (void_type_node, tmp);
6505 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
6506 that constructs the call to __builtin_memcpy. */
6509 gfc_build_memcpy_call (tree dst, tree src, tree len)
6513 /* Convert arguments to the correct types. */
6514 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
6515 dst = gfc_build_addr_expr (pvoid_type_node, dst);
6517 dst = fold_convert (pvoid_type_node, dst);
6519 if (!POINTER_TYPE_P (TREE_TYPE (src)))
6520 src = gfc_build_addr_expr (pvoid_type_node, src);
6522 src = fold_convert (pvoid_type_node, src);
6524 len = fold_convert (size_type_node, len);
6526 /* Construct call to __builtin_memcpy. */
6527 tmp = build_call_expr_loc (input_location,
6528 builtin_decl_explicit (BUILT_IN_MEMCPY),
6530 return fold_convert (void_type_node, tmp);
6534 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
6535 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
6536 source/rhs, both are gfc_full_array_ref_p which have been checked for
6540 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
6542 tree dst, dlen, dtype;
6543 tree src, slen, stype;
6546 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
6547 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
6549 dtype = TREE_TYPE (dst);
6550 if (POINTER_TYPE_P (dtype))
6551 dtype = TREE_TYPE (dtype);
6552 stype = TREE_TYPE (src);
6553 if (POINTER_TYPE_P (stype))
6554 stype = TREE_TYPE (stype);
6556 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
6559 /* Determine the lengths of the arrays. */
6560 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
6561 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
6563 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
6564 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6565 dlen, fold_convert (gfc_array_index_type, tmp));
6567 slen = GFC_TYPE_ARRAY_SIZE (stype);
6568 if (!slen || TREE_CODE (slen) != INTEGER_CST)
6570 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
6571 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6572 slen, fold_convert (gfc_array_index_type, tmp));
6574 /* Sanity check that they are the same. This should always be
6575 the case, as we should already have checked for conformance. */
6576 if (!tree_int_cst_equal (slen, dlen))
6579 return gfc_build_memcpy_call (dst, src, dlen);
6583 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
6584 this can't be done. EXPR1 is the destination/lhs for which
6585 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
6588 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
6590 unsigned HOST_WIDE_INT nelem;
6596 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
6600 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
6601 dtype = TREE_TYPE (dst);
6602 if (POINTER_TYPE_P (dtype))
6603 dtype = TREE_TYPE (dtype);
6604 if (!GFC_ARRAY_TYPE_P (dtype))
6607 /* Determine the lengths of the array. */
6608 len = GFC_TYPE_ARRAY_SIZE (dtype);
6609 if (!len || TREE_CODE (len) != INTEGER_CST)
6612 /* Confirm that the constructor is the same size. */
6613 if (compare_tree_int (len, nelem) != 0)
6616 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
6617 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
6618 fold_convert (gfc_array_index_type, tmp));
6620 stype = gfc_typenode_for_spec (&expr2->ts);
6621 src = gfc_build_constant_array_constructor (expr2, stype);
6623 stype = TREE_TYPE (src);
6624 if (POINTER_TYPE_P (stype))
6625 stype = TREE_TYPE (stype);
6627 return gfc_build_memcpy_call (dst, src, len);
6631 /* Tells whether the expression is to be treated as a variable reference. */
6634 expr_is_variable (gfc_expr *expr)
6638 if (expr->expr_type == EXPR_VARIABLE)
6641 arg = gfc_get_noncopying_intrinsic_argument (expr);
6644 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6645 return expr_is_variable (arg);
6652 /* Is the lhs OK for automatic reallocation? */
6655 is_scalar_reallocatable_lhs (gfc_expr *expr)
6659 /* An allocatable variable with no reference. */
6660 if (expr->symtree->n.sym->attr.allocatable
6664 /* All that can be left are allocatable components. */
6665 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6666 && expr->symtree->n.sym->ts.type != BT_CLASS)
6667 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6670 /* Find an allocatable component ref last. */
6671 for (ref = expr->ref; ref; ref = ref->next)
6672 if (ref->type == REF_COMPONENT
6674 && ref->u.c.component->attr.allocatable)
6681 /* Allocate or reallocate scalar lhs, as necessary. */
6684 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6698 if (!expr1 || expr1->rank)
6701 if (!expr2 || expr2->rank)
6704 /* Since this is a scalar lhs, we can afford to do this. That is,
6705 there is no risk of side effects being repeated. */
6706 gfc_init_se (&lse, NULL);
6707 lse.want_pointer = 1;
6708 gfc_conv_expr (&lse, expr1);
6710 jump_label1 = gfc_build_label_decl (NULL_TREE);
6711 jump_label2 = gfc_build_label_decl (NULL_TREE);
6713 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6714 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6715 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6717 tmp = build3_v (COND_EXPR, cond,
6718 build1_v (GOTO_EXPR, jump_label1),
6719 build_empty_stmt (input_location));
6720 gfc_add_expr_to_block (block, tmp);
6722 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6724 /* Use the rhs string length and the lhs element size. */
6725 size = string_length;
6726 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6727 tmp = TYPE_SIZE_UNIT (tmp);
6728 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6729 TREE_TYPE (tmp), tmp,
6730 fold_convert (TREE_TYPE (tmp), size));
6734 /* Otherwise use the length in bytes of the rhs. */
6735 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6736 size_in_bytes = size;
6739 if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
6741 tmp = build_call_expr_loc (input_location,
6742 builtin_decl_explicit (BUILT_IN_CALLOC),
6743 2, build_one_cst (size_type_node),
6745 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6746 gfc_add_modify (block, lse.expr, tmp);
6750 tmp = build_call_expr_loc (input_location,
6751 builtin_decl_explicit (BUILT_IN_MALLOC),
6753 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6754 gfc_add_modify (block, lse.expr, tmp);
6757 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6759 /* Deferred characters need checking for lhs and rhs string
6760 length. Other deferred parameter variables will have to
6762 tmp = build1_v (GOTO_EXPR, jump_label2);
6763 gfc_add_expr_to_block (block, tmp);
6765 tmp = build1_v (LABEL_EXPR, jump_label1);
6766 gfc_add_expr_to_block (block, tmp);
6768 /* For a deferred length character, reallocate if lengths of lhs and
6769 rhs are different. */
6770 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6772 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6773 expr1->ts.u.cl->backend_decl, size);
6774 /* Jump past the realloc if the lengths are the same. */
6775 tmp = build3_v (COND_EXPR, cond,
6776 build1_v (GOTO_EXPR, jump_label2),
6777 build_empty_stmt (input_location));
6778 gfc_add_expr_to_block (block, tmp);
6779 tmp = build_call_expr_loc (input_location,
6780 builtin_decl_explicit (BUILT_IN_REALLOC),
6781 2, fold_convert (pvoid_type_node, lse.expr),
6783 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6784 gfc_add_modify (block, lse.expr, tmp);
6785 tmp = build1_v (LABEL_EXPR, jump_label2);
6786 gfc_add_expr_to_block (block, tmp);
6788 /* Update the lhs character length. */
6789 size = string_length;
6790 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6795 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6796 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6797 init_flag indicates initialization expressions and dealloc that no
6798 deallocate prior assignment is needed (if in doubt, set true). */
6801 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6807 gfc_ss *lss_section;
6814 bool scalar_to_array;
6819 /* Assignment of the form lhs = rhs. */
6820 gfc_start_block (&block);
6822 gfc_init_se (&lse, NULL);
6823 gfc_init_se (&rse, NULL);
6826 lss = gfc_walk_expr (expr1);
6827 if (gfc_is_reallocatable_lhs (expr1)
6828 && !(expr2->expr_type == EXPR_FUNCTION
6829 && expr2->value.function.isym != NULL))
6830 lss->is_alloc_lhs = 1;
6832 if (lss != gfc_ss_terminator)
6834 /* The assignment needs scalarization. */
6837 /* Find a non-scalar SS from the lhs. */
6838 while (lss_section != gfc_ss_terminator
6839 && lss_section->info->type != GFC_SS_SECTION)
6840 lss_section = lss_section->next;
6842 gcc_assert (lss_section != gfc_ss_terminator);
6844 /* Initialize the scalarizer. */
6845 gfc_init_loopinfo (&loop);
6848 rss = gfc_walk_expr (expr2);
6849 if (rss == gfc_ss_terminator)
6850 /* The rhs is scalar. Add a ss for the expression. */
6851 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6853 /* Associate the SS with the loop. */
6854 gfc_add_ss_to_loop (&loop, lss);
6855 gfc_add_ss_to_loop (&loop, rss);
6857 /* Calculate the bounds of the scalarization. */
6858 gfc_conv_ss_startstride (&loop);
6859 /* Enable loop reversal. */
6860 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6861 loop.reverse[n] = GFC_ENABLE_REVERSE;
6862 /* Resolve any data dependencies in the statement. */
6863 gfc_conv_resolve_dependencies (&loop, lss, rss);
6864 /* Setup the scalarizing loops. */
6865 gfc_conv_loop_setup (&loop, &expr2->where);
6867 /* Setup the gfc_se structures. */
6868 gfc_copy_loopinfo_to_se (&lse, &loop);
6869 gfc_copy_loopinfo_to_se (&rse, &loop);
6872 gfc_mark_ss_chain_used (rss, 1);
6873 if (loop.temp_ss == NULL)
6876 gfc_mark_ss_chain_used (lss, 1);
6880 lse.ss = loop.temp_ss;
6881 gfc_mark_ss_chain_used (lss, 3);
6882 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6885 /* Allow the scalarizer to workshare array assignments. */
6886 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6887 ompws_flags |= OMPWS_SCALARIZER_WS;
6889 /* Start the scalarized loop body. */
6890 gfc_start_scalarized_body (&loop, &body);
6893 gfc_init_block (&body);
6895 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6897 /* Translate the expression. */
6898 gfc_conv_expr (&rse, expr2);
6900 /* Stabilize a string length for temporaries. */
6901 if (expr2->ts.type == BT_CHARACTER)
6902 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6904 string_length = NULL_TREE;
6908 gfc_conv_tmp_array_ref (&lse);
6909 if (expr2->ts.type == BT_CHARACTER)
6910 lse.string_length = string_length;
6913 gfc_conv_expr (&lse, expr1);
6915 /* Assignments of scalar derived types with allocatable components
6916 to arrays must be done with a deep copy and the rhs temporary
6917 must have its components deallocated afterwards. */
6918 scalar_to_array = (expr2->ts.type == BT_DERIVED
6919 && expr2->ts.u.derived->attr.alloc_comp
6920 && !expr_is_variable (expr2)
6921 && !gfc_is_constant_expr (expr2)
6922 && expr1->rank && !expr2->rank);
6923 if (scalar_to_array && dealloc)
6925 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6926 gfc_add_expr_to_block (&loop.post, tmp);
6929 /* For a deferred character length function, the function call must
6930 happen before the (re)allocation of the lhs, otherwise the character
6931 length of the result is not known. */
6932 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6933 || (expr2->expr_type == EXPR_COMPCALL)
6934 || (expr2->expr_type == EXPR_PPC))
6935 && expr2->ts.deferred);
6936 if (gfc_option.flag_realloc_lhs
6937 && expr2->ts.type == BT_CHARACTER
6938 && (def_clen_func || expr2->expr_type == EXPR_OP)
6939 && expr1->ts.deferred)
6940 gfc_add_block_to_block (&block, &rse.pre);
6942 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6943 l_is_temp || init_flag,
6944 expr_is_variable (expr2) || scalar_to_array
6945 || expr2->expr_type == EXPR_ARRAY, dealloc);
6946 gfc_add_expr_to_block (&body, tmp);
6948 if (lss == gfc_ss_terminator)
6950 /* F2003: Add the code for reallocation on assignment. */
6951 if (gfc_option.flag_realloc_lhs
6952 && is_scalar_reallocatable_lhs (expr1))
6953 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6956 /* Use the scalar assignment as is. */
6957 gfc_add_block_to_block (&block, &body);
6961 gcc_assert (lse.ss == gfc_ss_terminator
6962 && rse.ss == gfc_ss_terminator);
6966 gfc_trans_scalarized_loop_boundary (&loop, &body);
6968 /* We need to copy the temporary to the actual lhs. */
6969 gfc_init_se (&lse, NULL);
6970 gfc_init_se (&rse, NULL);
6971 gfc_copy_loopinfo_to_se (&lse, &loop);
6972 gfc_copy_loopinfo_to_se (&rse, &loop);
6974 rse.ss = loop.temp_ss;
6977 gfc_conv_tmp_array_ref (&rse);
6978 gfc_conv_expr (&lse, expr1);
6980 gcc_assert (lse.ss == gfc_ss_terminator
6981 && rse.ss == gfc_ss_terminator);
6983 if (expr2->ts.type == BT_CHARACTER)
6984 rse.string_length = string_length;
6986 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6987 false, false, dealloc);
6988 gfc_add_expr_to_block (&body, tmp);
6991 /* F2003: Allocate or reallocate lhs of allocatable array. */
6992 if (gfc_option.flag_realloc_lhs
6993 && gfc_is_reallocatable_lhs (expr1)
6994 && !gfc_expr_attr (expr1).codimension
6995 && !gfc_is_coindexed (expr1))
6997 ompws_flags &= ~OMPWS_SCALARIZER_WS;
6998 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6999 if (tmp != NULL_TREE)
7000 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
7003 /* Generate the copying loops. */
7004 gfc_trans_scalarizing_loops (&loop, &body);
7006 /* Wrap the whole thing up. */
7007 gfc_add_block_to_block (&block, &loop.pre);
7008 gfc_add_block_to_block (&block, &loop.post);
7010 gfc_cleanup_loop (&loop);
7013 return gfc_finish_block (&block);
7017 /* Check whether EXPR is a copyable array. */
7020 copyable_array_p (gfc_expr * expr)
7022 if (expr->expr_type != EXPR_VARIABLE)
7025 /* First check it's an array. */
7026 if (expr->rank < 1 || !expr->ref || expr->ref->next)
7029 if (!gfc_full_array_ref_p (expr->ref, NULL))
7032 /* Next check that it's of a simple enough type. */
7033 switch (expr->ts.type)
7045 return !expr->ts.u.derived->attr.alloc_comp;
7054 /* Translate an assignment. */
7057 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
7062 /* Special case a single function returning an array. */
7063 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
7065 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
7070 /* Special case assigning an array to zero. */
7071 if (copyable_array_p (expr1)
7072 && is_zero_initializer_p (expr2))
7074 tmp = gfc_trans_zero_assign (expr1);
7079 /* Special case copying one array to another. */
7080 if (copyable_array_p (expr1)
7081 && copyable_array_p (expr2)
7082 && gfc_compare_types (&expr1->ts, &expr2->ts)
7083 && !gfc_check_dependency (expr1, expr2, 0))
7085 tmp = gfc_trans_array_copy (expr1, expr2);
7090 /* Special case initializing an array from a constant array constructor. */
7091 if (copyable_array_p (expr1)
7092 && expr2->expr_type == EXPR_ARRAY
7093 && gfc_compare_types (&expr1->ts, &expr2->ts))
7095 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
7100 /* Fallback to the scalarizer to generate explicit loops. */
7101 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
7105 gfc_trans_init_assign (gfc_code * code)
7107 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
7111 gfc_trans_assign (gfc_code * code)
7113 return gfc_trans_assignment (code->expr1, code->expr2, false, true);