1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
56 dest->loop = src->loop;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se * se, gfc_se * parent)
69 memset (se, 0, sizeof (gfc_se));
70 gfc_init_block (&se->pre);
71 gfc_init_block (&se->post);
76 gfc_copy_se_loopvars (se, parent);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se * se)
89 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se * se)
113 if (CONSTANT_CLASS_P (se->expr))
116 /* We need a temporary for this result. */
117 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118 gfc_add_modify (&se->pre, var, se->expr);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol * sym)
131 gcc_assert (sym->attr.dummy);
133 decl = gfc_get_symbol_decl (sym);
134 if (TREE_CODE (decl) != PARM_DECL)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
142 return fold_build2 (NE_EXPR, boolean_type_node, decl,
143 fold_convert (TREE_TYPE (decl), null_pointer_node));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
159 /* Create a temporary and convert it to the correct type. */
160 tmp = gfc_get_int_type (kind);
161 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
164 /* Test for a NULL value. */
165 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
166 fold_convert (TREE_TYPE (tmp), integer_one_node));
167 tmp = gfc_evaluate_now (tmp, &se->pre);
168 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
172 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
173 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
174 tmp = gfc_evaluate_now (tmp, &se->pre);
178 if (ts.type == BT_CHARACTER)
180 tmp = build_int_cst (gfc_charlen_type_node, 0);
181 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
182 present, se->string_length, tmp);
183 tmp = gfc_evaluate_now (tmp, &se->pre);
184 se->string_length = tmp;
190 /* Get the character length of an expression, looking through gfc_refs
194 gfc_get_expr_charlen (gfc_expr *e)
199 gcc_assert (e->expr_type == EXPR_VARIABLE
200 && e->ts.type == BT_CHARACTER);
202 length = NULL; /* To silence compiler warning. */
204 if (is_subref_array (e) && e->ts.u.cl->length)
207 gfc_init_se (&tmpse, NULL);
208 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
209 e->ts.u.cl->backend_decl = tmpse.expr;
213 /* First candidate: if the variable is of type CHARACTER, the
214 expression's length could be the length of the character
216 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
217 length = e->symtree->n.sym->ts.u.cl->backend_decl;
219 /* Look through the reference chain for component references. */
220 for (r = e->ref; r; r = r->next)
225 if (r->u.c.component->ts.type == BT_CHARACTER)
226 length = r->u.c.component->ts.u.cl->backend_decl;
234 /* We should never got substring references here. These will be
235 broken down by the scalarizer. */
241 gcc_assert (length != NULL);
246 /* For each character array constructor subexpression without a ts.u.cl->length,
247 replace it by its first element (if there aren't any elements, the length
248 should already be set to zero). */
251 flatten_array_ctors_without_strlen (gfc_expr* e)
253 gfc_actual_arglist* arg;
259 switch (e->expr_type)
263 flatten_array_ctors_without_strlen (e->value.op.op1);
264 flatten_array_ctors_without_strlen (e->value.op.op2);
268 /* TODO: Implement as with EXPR_FUNCTION when needed. */
272 for (arg = e->value.function.actual; arg; arg = arg->next)
273 flatten_array_ctors_without_strlen (arg->expr);
278 /* We've found what we're looking for. */
279 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
282 gcc_assert (e->value.constructor);
284 new_expr = e->value.constructor->expr;
285 e->value.constructor->expr = NULL;
287 flatten_array_ctors_without_strlen (new_expr);
288 gfc_replace_expr (e, new_expr);
292 /* Otherwise, fall through to handle constructor elements. */
294 for (c = e->value.constructor; c; c = c->next)
295 flatten_array_ctors_without_strlen (c->expr);
305 /* Generate code to initialize a string length variable. Returns the
306 value. For array constructors, cl->length might be NULL and in this case,
307 the first element of the constructor is needed. expr is the original
308 expression so we can access it but can be NULL if this is not needed. */
311 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
315 gfc_init_se (&se, NULL);
317 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
318 "flatten" array constructors by taking their first element; all elements
319 should be the same length or a cl->length should be present. */
325 expr_flat = gfc_copy_expr (expr);
326 flatten_array_ctors_without_strlen (expr_flat);
327 gfc_resolve_expr (expr_flat);
329 gfc_conv_expr (&se, expr_flat);
330 gfc_add_block_to_block (pblock, &se.pre);
331 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
333 gfc_free_expr (expr_flat);
337 /* Convert cl->length. */
339 gcc_assert (cl->length);
341 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
342 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
343 build_int_cst (gfc_charlen_type_node, 0));
344 gfc_add_block_to_block (pblock, &se.pre);
346 if (cl->backend_decl)
347 gfc_add_modify (pblock, cl->backend_decl, se.expr);
349 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
354 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
355 const char *name, locus *where)
365 type = gfc_get_character_type (kind, ref->u.ss.length);
366 type = build_pointer_type (type);
369 gfc_init_se (&start, se);
370 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
371 gfc_add_block_to_block (&se->pre, &start.pre);
373 if (integer_onep (start.expr))
374 gfc_conv_string_parameter (se);
377 /* Avoid multiple evaluation of substring start. */
378 if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
379 start.expr = gfc_evaluate_now (start.expr, &se->pre);
381 /* Change the start of the string. */
382 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
385 tmp = build_fold_indirect_ref_loc (input_location,
387 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
388 se->expr = gfc_build_addr_expr (type, tmp);
391 /* Length = end + 1 - start. */
392 gfc_init_se (&end, se);
393 if (ref->u.ss.end == NULL)
394 end.expr = se->string_length;
397 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
398 gfc_add_block_to_block (&se->pre, &end.pre);
400 if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
401 end.expr = gfc_evaluate_now (end.expr, &se->pre);
403 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
405 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
406 start.expr, end.expr);
408 /* Check lower bound. */
409 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
410 build_int_cst (gfc_charlen_type_node, 1));
411 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
414 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
415 "is less than one", name);
417 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
419 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
420 fold_convert (long_integer_type_node,
424 /* Check upper bound. */
425 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
427 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
430 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
431 "exceeds string length (%%ld)", name);
433 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
434 "exceeds string length (%%ld)");
435 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
436 fold_convert (long_integer_type_node, end.expr),
437 fold_convert (long_integer_type_node,
442 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
443 build_int_cst (gfc_charlen_type_node, 1),
445 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
446 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
447 build_int_cst (gfc_charlen_type_node, 0));
448 se->string_length = tmp;
452 /* Convert a derived type component reference. */
455 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
462 c = ref->u.c.component;
464 gcc_assert (c->backend_decl);
466 field = c->backend_decl;
467 gcc_assert (TREE_CODE (field) == FIELD_DECL);
469 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
473 if (c->ts.type == BT_CHARACTER)
475 tmp = c->ts.u.cl->backend_decl;
476 /* Components must always be constant length. */
477 gcc_assert (tmp && INTEGER_CST_P (tmp));
478 se->string_length = tmp;
481 if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
482 || c->attr.proc_pointer)
483 se->expr = build_fold_indirect_ref_loc (input_location,
488 /* This function deals with component references to components of the
489 parent type for derived type extensons. */
491 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
499 c = ref->u.c.component;
501 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
502 parent.type = REF_COMPONENT;
505 parent.u.c.component = dt->components;
507 if (dt->attr.extension && dt->components)
509 /* Return if the component is not in the parent type. */
510 for (cmp = dt->components->next; cmp; cmp = cmp->next)
511 if (strcmp (c->name, cmp->name) == 0)
514 /* Otherwise build the reference and call self. */
515 gfc_conv_component_ref (se, &parent);
516 parent.u.c.sym = dt->components->ts.u.derived;
517 parent.u.c.component = c;
518 conv_parent_component_references (se, &parent);
522 /* Return the contents of a variable. Also handles reference/pointer
523 variables (all Fortran pointer references are implicit). */
526 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
533 bool alternate_entry;
536 sym = expr->symtree->n.sym;
539 /* Check that something hasn't gone horribly wrong. */
540 gcc_assert (se->ss != gfc_ss_terminator);
541 gcc_assert (se->ss->expr == expr);
543 /* A scalarized term. We already know the descriptor. */
544 se->expr = se->ss->data.info.descriptor;
545 se->string_length = se->ss->string_length;
546 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
547 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
552 tree se_expr = NULL_TREE;
554 se->expr = gfc_get_symbol_decl (sym);
556 /* Deal with references to a parent results or entries by storing
557 the current_function_decl and moving to the parent_decl. */
558 return_value = sym->attr.function && sym->result == sym;
559 alternate_entry = sym->attr.function && sym->attr.entry
560 && sym->result == sym;
561 entry_master = sym->attr.result
562 && sym->ns->proc_name->attr.entry_master
563 && !gfc_return_by_reference (sym->ns->proc_name);
564 parent_decl = DECL_CONTEXT (current_function_decl);
566 if ((se->expr == parent_decl && return_value)
567 || (sym->ns && sym->ns->proc_name
569 && sym->ns->proc_name->backend_decl == parent_decl
570 && (alternate_entry || entry_master)))
575 /* Special case for assigning the return value of a function.
576 Self recursive functions must have an explicit return value. */
577 if (return_value && (se->expr == current_function_decl || parent_flag))
578 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
580 /* Similarly for alternate entry points. */
581 else if (alternate_entry
582 && (sym->ns->proc_name->backend_decl == current_function_decl
585 gfc_entry_list *el = NULL;
587 for (el = sym->ns->entries; el; el = el->next)
590 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
595 else if (entry_master
596 && (sym->ns->proc_name->backend_decl == current_function_decl
598 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
603 /* Procedure actual arguments. */
604 else if (sym->attr.flavor == FL_PROCEDURE
605 && se->expr != current_function_decl)
607 if (!sym->attr.dummy && !sym->attr.proc_pointer)
609 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
610 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
616 /* Dereference the expression, where needed. Since characters
617 are entirely different from other types, they are treated
619 if (sym->ts.type == BT_CHARACTER)
621 /* Dereference character pointer dummy arguments
623 if ((sym->attr.pointer || sym->attr.allocatable)
625 || sym->attr.function
626 || sym->attr.result))
627 se->expr = build_fold_indirect_ref_loc (input_location,
631 else if (!sym->attr.value)
633 /* Dereference non-character scalar dummy arguments. */
634 if (sym->attr.dummy && !sym->attr.dimension)
635 se->expr = build_fold_indirect_ref_loc (input_location,
638 /* Dereference scalar hidden result. */
639 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
640 && (sym->attr.function || sym->attr.result)
641 && !sym->attr.dimension && !sym->attr.pointer
642 && !sym->attr.always_explicit)
643 se->expr = build_fold_indirect_ref_loc (input_location,
646 /* Dereference non-character pointer variables.
647 These must be dummies, results, or scalars. */
648 if ((sym->attr.pointer || sym->attr.allocatable)
650 || sym->attr.function
652 || !sym->attr.dimension))
653 se->expr = build_fold_indirect_ref_loc (input_location,
660 /* For character variables, also get the length. */
661 if (sym->ts.type == BT_CHARACTER)
663 /* If the character length of an entry isn't set, get the length from
664 the master function instead. */
665 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
666 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
668 se->string_length = sym->ts.u.cl->backend_decl;
669 gcc_assert (se->string_length);
677 /* Return the descriptor if that's what we want and this is an array
678 section reference. */
679 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
681 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
682 /* Return the descriptor for array pointers and allocations. */
684 && ref->next == NULL && (se->descriptor_only))
687 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
688 /* Return a pointer to an element. */
692 if (ref->u.c.sym->attr.extension)
693 conv_parent_component_references (se, ref);
695 gfc_conv_component_ref (se, ref);
699 gfc_conv_substring (se, ref, expr->ts.kind,
700 expr->symtree->name, &expr->where);
709 /* Pointer assignment, allocation or pass by reference. Arrays are handled
711 if (se->want_pointer)
713 if (expr->ts.type == BT_CHARACTER)
714 gfc_conv_string_parameter (se);
716 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
721 /* Unary ops are easy... Or they would be if ! was a valid op. */
724 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
729 gcc_assert (expr->ts.type != BT_CHARACTER);
730 /* Initialize the operand. */
731 gfc_init_se (&operand, se);
732 gfc_conv_expr_val (&operand, expr->value.op.op1);
733 gfc_add_block_to_block (&se->pre, &operand.pre);
735 type = gfc_typenode_for_spec (&expr->ts);
737 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
738 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
739 All other unary operators have an equivalent GIMPLE unary operator. */
740 if (code == TRUTH_NOT_EXPR)
741 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
742 build_int_cst (type, 0));
744 se->expr = fold_build1 (code, type, operand.expr);
748 /* Expand power operator to optimal multiplications when a value is raised
749 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
750 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
751 Programming", 3rd Edition, 1998. */
753 /* This code is mostly duplicated from expand_powi in the backend.
754 We establish the "optimal power tree" lookup table with the defined size.
755 The items in the table are the exponents used to calculate the index
756 exponents. Any integer n less than the value can get an "addition chain",
757 with the first node being one. */
758 #define POWI_TABLE_SIZE 256
760 /* The table is from builtins.c. */
761 static const unsigned char powi_table[POWI_TABLE_SIZE] =
763 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
764 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
765 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
766 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
767 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
768 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
769 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
770 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
771 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
772 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
773 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
774 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
775 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
776 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
777 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
778 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
779 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
780 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
781 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
782 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
783 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
784 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
785 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
786 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
787 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
788 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
789 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
790 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
791 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
792 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
793 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
794 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
797 /* If n is larger than lookup table's max index, we use the "window
799 #define POWI_WINDOW_SIZE 3
801 /* Recursive function to expand the power operator. The temporary
802 values are put in tmpvar. The function returns tmpvar[1] ** n. */
804 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
811 if (n < POWI_TABLE_SIZE)
816 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
817 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
821 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
822 op0 = gfc_conv_powi (se, n - digit, tmpvar);
823 op1 = gfc_conv_powi (se, digit, tmpvar);
827 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
831 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
832 tmp = gfc_evaluate_now (tmp, &se->pre);
834 if (n < POWI_TABLE_SIZE)
841 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
842 return 1. Else return 0 and a call to runtime library functions
843 will have to be built. */
845 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
850 tree vartmp[POWI_TABLE_SIZE];
852 unsigned HOST_WIDE_INT n;
855 /* If exponent is too large, we won't expand it anyway, so don't bother
856 with large integer values. */
857 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
860 m = double_int_to_shwi (TREE_INT_CST (rhs));
861 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
862 of the asymmetric range of the integer type. */
863 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
865 type = TREE_TYPE (lhs);
866 sgn = tree_int_cst_sgn (rhs);
868 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
869 || optimize_size) && (m > 2 || m < -1))
875 se->expr = gfc_build_const (type, integer_one_node);
879 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
880 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
882 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
883 lhs, build_int_cst (TREE_TYPE (lhs), -1));
884 cond = fold_build2 (EQ_EXPR, boolean_type_node,
885 lhs, build_int_cst (TREE_TYPE (lhs), 1));
888 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
891 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
892 se->expr = fold_build3 (COND_EXPR, type,
893 tmp, build_int_cst (type, 1),
894 build_int_cst (type, 0));
898 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
899 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
900 build_int_cst (type, 0));
901 se->expr = fold_build3 (COND_EXPR, type,
902 cond, build_int_cst (type, 1), tmp);
906 memset (vartmp, 0, sizeof (vartmp));
910 tmp = gfc_build_const (type, integer_one_node);
911 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
914 se->expr = gfc_conv_powi (se, n, vartmp);
920 /* Power op (**). Constant integer exponent has special handling. */
923 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
925 tree gfc_int4_type_node;
932 gfc_init_se (&lse, se);
933 gfc_conv_expr_val (&lse, expr->value.op.op1);
934 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
935 gfc_add_block_to_block (&se->pre, &lse.pre);
937 gfc_init_se (&rse, se);
938 gfc_conv_expr_val (&rse, expr->value.op.op2);
939 gfc_add_block_to_block (&se->pre, &rse.pre);
941 if (expr->value.op.op2->ts.type == BT_INTEGER
942 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
943 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
946 gfc_int4_type_node = gfc_get_int_type (4);
948 kind = expr->value.op.op1->ts.kind;
949 switch (expr->value.op.op2->ts.type)
952 ikind = expr->value.op.op2->ts.kind;
957 rse.expr = convert (gfc_int4_type_node, rse.expr);
979 if (expr->value.op.op1->ts.type == BT_INTEGER)
980 lse.expr = convert (gfc_int4_type_node, lse.expr);
1005 switch (expr->value.op.op1->ts.type)
1008 if (kind == 3) /* Case 16 was not handled properly above. */
1010 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1014 /* Use builtins for real ** int4. */
1020 fndecl = built_in_decls[BUILT_IN_POWIF];
1024 fndecl = built_in_decls[BUILT_IN_POWI];
1029 fndecl = built_in_decls[BUILT_IN_POWIL];
1037 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1041 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1053 fndecl = built_in_decls[BUILT_IN_POWF];
1056 fndecl = built_in_decls[BUILT_IN_POW];
1060 fndecl = built_in_decls[BUILT_IN_POWL];
1071 fndecl = built_in_decls[BUILT_IN_CPOWF];
1074 fndecl = built_in_decls[BUILT_IN_CPOW];
1078 fndecl = built_in_decls[BUILT_IN_CPOWL];
1090 se->expr = build_call_expr_loc (input_location,
1091 fndecl, 2, lse.expr, rse.expr);
1095 /* Generate code to allocate a string temporary. */
1098 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1103 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
1105 if (gfc_can_put_var_on_stack (len))
1107 /* Create a temporary variable to hold the result. */
1108 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1109 build_int_cst (gfc_charlen_type_node, 1));
1110 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1112 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1113 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1115 tmp = build_array_type (TREE_TYPE (type), tmp);
1117 var = gfc_create_var (tmp, "str");
1118 var = gfc_build_addr_expr (type, var);
1122 /* Allocate a temporary to hold the result. */
1123 var = gfc_create_var (type, "pstr");
1124 tmp = gfc_call_malloc (&se->pre, type,
1125 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1126 fold_convert (TREE_TYPE (len),
1127 TYPE_SIZE (type))));
1128 gfc_add_modify (&se->pre, var, tmp);
1130 /* Free the temporary afterwards. */
1131 tmp = gfc_call_free (convert (pvoid_type_node, var));
1132 gfc_add_expr_to_block (&se->post, tmp);
1139 /* Handle a string concatenation operation. A temporary will be allocated to
1143 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1146 tree len, type, var, tmp, fndecl;
1148 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1149 && expr->value.op.op2->ts.type == BT_CHARACTER);
1150 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1152 gfc_init_se (&lse, se);
1153 gfc_conv_expr (&lse, expr->value.op.op1);
1154 gfc_conv_string_parameter (&lse);
1155 gfc_init_se (&rse, se);
1156 gfc_conv_expr (&rse, expr->value.op.op2);
1157 gfc_conv_string_parameter (&rse);
1159 gfc_add_block_to_block (&se->pre, &lse.pre);
1160 gfc_add_block_to_block (&se->pre, &rse.pre);
1162 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1163 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1164 if (len == NULL_TREE)
1166 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1167 lse.string_length, rse.string_length);
1170 type = build_pointer_type (type);
1172 var = gfc_conv_string_tmp (se, type, len);
1174 /* Do the actual concatenation. */
1175 if (expr->ts.kind == 1)
1176 fndecl = gfor_fndecl_concat_string;
1177 else if (expr->ts.kind == 4)
1178 fndecl = gfor_fndecl_concat_string_char4;
1182 tmp = build_call_expr_loc (input_location,
1183 fndecl, 6, len, var, lse.string_length, lse.expr,
1184 rse.string_length, rse.expr);
1185 gfc_add_expr_to_block (&se->pre, tmp);
1187 /* Add the cleanup for the operands. */
1188 gfc_add_block_to_block (&se->pre, &rse.post);
1189 gfc_add_block_to_block (&se->pre, &lse.post);
1192 se->string_length = len;
1195 /* Translates an op expression. Common (binary) cases are handled by this
1196 function, others are passed on. Recursion is used in either case.
1197 We use the fact that (op1.ts == op2.ts) (except for the power
1199 Operators need no special handling for scalarized expressions as long as
1200 they call gfc_conv_simple_val to get their operands.
1201 Character strings get special handling. */
1204 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1206 enum tree_code code;
1215 switch (expr->value.op.op)
1217 case INTRINSIC_PARENTHESES:
1218 if (expr->ts.type == BT_REAL
1219 || expr->ts.type == BT_COMPLEX)
1221 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1222 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1227 case INTRINSIC_UPLUS:
1228 gfc_conv_expr (se, expr->value.op.op1);
1231 case INTRINSIC_UMINUS:
1232 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1236 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1239 case INTRINSIC_PLUS:
1243 case INTRINSIC_MINUS:
1247 case INTRINSIC_TIMES:
1251 case INTRINSIC_DIVIDE:
1252 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1253 an integer, we must round towards zero, so we use a
1255 if (expr->ts.type == BT_INTEGER)
1256 code = TRUNC_DIV_EXPR;
1261 case INTRINSIC_POWER:
1262 gfc_conv_power_op (se, expr);
1265 case INTRINSIC_CONCAT:
1266 gfc_conv_concat_op (se, expr);
1270 code = TRUTH_ANDIF_EXPR;
1275 code = TRUTH_ORIF_EXPR;
1279 /* EQV and NEQV only work on logicals, but since we represent them
1280 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1282 case INTRINSIC_EQ_OS:
1290 case INTRINSIC_NE_OS:
1291 case INTRINSIC_NEQV:
1298 case INTRINSIC_GT_OS:
1305 case INTRINSIC_GE_OS:
1312 case INTRINSIC_LT_OS:
1319 case INTRINSIC_LE_OS:
1325 case INTRINSIC_USER:
1326 case INTRINSIC_ASSIGN:
1327 /* These should be converted into function calls by the frontend. */
1331 fatal_error ("Unknown intrinsic op");
1335 /* The only exception to this is **, which is handled separately anyway. */
1336 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1338 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1342 gfc_init_se (&lse, se);
1343 gfc_conv_expr (&lse, expr->value.op.op1);
1344 gfc_add_block_to_block (&se->pre, &lse.pre);
1347 gfc_init_se (&rse, se);
1348 gfc_conv_expr (&rse, expr->value.op.op2);
1349 gfc_add_block_to_block (&se->pre, &rse.pre);
1353 gfc_conv_string_parameter (&lse);
1354 gfc_conv_string_parameter (&rse);
1356 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1357 rse.string_length, rse.expr,
1358 expr->value.op.op1->ts.kind);
1359 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1360 gfc_add_block_to_block (&lse.post, &rse.post);
1363 type = gfc_typenode_for_spec (&expr->ts);
1367 /* The result of logical ops is always boolean_type_node. */
1368 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1369 se->expr = convert (type, tmp);
1372 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1374 /* Add the post blocks. */
1375 gfc_add_block_to_block (&se->post, &rse.post);
1376 gfc_add_block_to_block (&se->post, &lse.post);
1379 /* If a string's length is one, we convert it to a single character. */
1382 string_to_single_character (tree len, tree str, int kind)
1384 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1386 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1387 && TREE_INT_CST_HIGH (len) == 0)
1389 str = fold_convert (gfc_get_pchar_type (kind), str);
1390 return build_fold_indirect_ref_loc (input_location,
1399 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1402 if (sym->backend_decl)
1404 /* This becomes the nominal_type in
1405 function.c:assign_parm_find_data_types. */
1406 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1407 /* This becomes the passed_type in
1408 function.c:assign_parm_find_data_types. C promotes char to
1409 integer for argument passing. */
1410 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1412 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1417 /* If we have a constant character expression, make it into an
1419 if ((*expr)->expr_type == EXPR_CONSTANT)
1424 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1425 if ((*expr)->ts.kind != gfc_c_int_kind)
1427 /* The expr needs to be compatible with a C int. If the
1428 conversion fails, then the 2 causes an ICE. */
1429 ts.type = BT_INTEGER;
1430 ts.kind = gfc_c_int_kind;
1431 gfc_convert_type (*expr, &ts, 2);
1434 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1436 if ((*expr)->ref == NULL)
1438 se->expr = string_to_single_character
1439 (build_int_cst (integer_type_node, 1),
1440 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1442 ((*expr)->symtree->n.sym)),
1447 gfc_conv_variable (se, *expr);
1448 se->expr = string_to_single_character
1449 (build_int_cst (integer_type_node, 1),
1450 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1459 /* Compare two strings. If they are all single characters, the result is the
1460 subtraction of them. Otherwise, we build a library call. */
1463 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1469 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1470 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1472 sc1 = string_to_single_character (len1, str1, kind);
1473 sc2 = string_to_single_character (len2, str2, kind);
1475 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1477 /* Deal with single character specially. */
1478 sc1 = fold_convert (integer_type_node, sc1);
1479 sc2 = fold_convert (integer_type_node, sc2);
1480 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1484 /* Build a call for the comparison. */
1488 fndecl = gfor_fndecl_compare_string;
1490 fndecl = gfor_fndecl_compare_string_char4;
1494 tmp = build_call_expr_loc (input_location,
1495 fndecl, 4, len1, str1, len2, str2);
1502 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1506 if (gfc_is_proc_ptr_comp (expr, NULL))
1507 tmp = gfc_get_proc_ptr_comp (se, expr);
1508 else if (sym->attr.dummy)
1510 tmp = gfc_get_symbol_decl (sym);
1511 if (sym->attr.proc_pointer)
1512 tmp = build_fold_indirect_ref_loc (input_location,
1514 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1515 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1519 if (!sym->backend_decl)
1520 sym->backend_decl = gfc_get_extern_function_decl (sym);
1522 tmp = sym->backend_decl;
1524 if (sym->attr.cray_pointee)
1526 /* TODO - make the cray pointee a pointer to a procedure,
1527 assign the pointer to it and use it for the call. This
1529 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1530 gfc_get_symbol_decl (sym->cp_pointer));
1531 tmp = gfc_evaluate_now (tmp, &se->pre);
1534 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1536 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1537 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1544 /* Initialize MAPPING. */
1547 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1549 mapping->syms = NULL;
1550 mapping->charlens = NULL;
1554 /* Free all memory held by MAPPING (but not MAPPING itself). */
1557 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1559 gfc_interface_sym_mapping *sym;
1560 gfc_interface_sym_mapping *nextsym;
1562 gfc_charlen *nextcl;
1564 for (sym = mapping->syms; sym; sym = nextsym)
1566 nextsym = sym->next;
1567 sym->new_sym->n.sym->formal = NULL;
1568 gfc_free_symbol (sym->new_sym->n.sym);
1569 gfc_free_expr (sym->expr);
1570 gfc_free (sym->new_sym);
1573 for (cl = mapping->charlens; cl; cl = nextcl)
1576 gfc_free_expr (cl->length);
1582 /* Return a copy of gfc_charlen CL. Add the returned structure to
1583 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1585 static gfc_charlen *
1586 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1589 gfc_charlen *new_charlen;
1591 new_charlen = gfc_get_charlen ();
1592 new_charlen->next = mapping->charlens;
1593 new_charlen->length = gfc_copy_expr (cl->length);
1595 mapping->charlens = new_charlen;
1600 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1601 array variable that can be used as the actual argument for dummy
1602 argument SYM. Add any initialization code to BLOCK. PACKED is as
1603 for gfc_get_nodesc_array_type and DATA points to the first element
1604 in the passed array. */
1607 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1608 gfc_packed packed, tree data)
1613 type = gfc_typenode_for_spec (&sym->ts);
1614 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1616 var = gfc_create_var (type, "ifm");
1617 gfc_add_modify (block, var, fold_convert (type, data));
1623 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1624 and offset of descriptorless array type TYPE given that it has the same
1625 size as DESC. Add any set-up code to BLOCK. */
1628 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1635 offset = gfc_index_zero_node;
1636 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1638 dim = gfc_rank_cst[n];
1639 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1640 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1642 GFC_TYPE_ARRAY_LBOUND (type, n)
1643 = gfc_conv_descriptor_lbound_get (desc, dim);
1644 GFC_TYPE_ARRAY_UBOUND (type, n)
1645 = gfc_conv_descriptor_ubound_get (desc, dim);
1647 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1649 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1650 gfc_conv_descriptor_ubound_get (desc, dim),
1651 gfc_conv_descriptor_lbound_get (desc, dim));
1652 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1653 GFC_TYPE_ARRAY_LBOUND (type, n),
1655 tmp = gfc_evaluate_now (tmp, block);
1656 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1658 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1659 GFC_TYPE_ARRAY_LBOUND (type, n),
1660 GFC_TYPE_ARRAY_STRIDE (type, n));
1661 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1663 offset = gfc_evaluate_now (offset, block);
1664 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1668 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1669 in SE. The caller may still use se->expr and se->string_length after
1670 calling this function. */
1673 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1674 gfc_symbol * sym, gfc_se * se,
1677 gfc_interface_sym_mapping *sm;
1681 gfc_symbol *new_sym;
1683 gfc_symtree *new_symtree;
1685 /* Create a new symbol to represent the actual argument. */
1686 new_sym = gfc_new_symbol (sym->name, NULL);
1687 new_sym->ts = sym->ts;
1688 new_sym->as = gfc_copy_array_spec (sym->as);
1689 new_sym->attr.referenced = 1;
1690 new_sym->attr.dimension = sym->attr.dimension;
1691 new_sym->attr.pointer = sym->attr.pointer;
1692 new_sym->attr.allocatable = sym->attr.allocatable;
1693 new_sym->attr.flavor = sym->attr.flavor;
1694 new_sym->attr.function = sym->attr.function;
1696 /* Ensure that the interface is available and that
1697 descriptors are passed for array actual arguments. */
1698 if (sym->attr.flavor == FL_PROCEDURE)
1700 new_sym->formal = expr->symtree->n.sym->formal;
1701 new_sym->attr.always_explicit
1702 = expr->symtree->n.sym->attr.always_explicit;
1705 /* Create a fake symtree for it. */
1707 new_symtree = gfc_new_symtree (&root, sym->name);
1708 new_symtree->n.sym = new_sym;
1709 gcc_assert (new_symtree == root);
1711 /* Create a dummy->actual mapping. */
1712 sm = XCNEW (gfc_interface_sym_mapping);
1713 sm->next = mapping->syms;
1715 sm->new_sym = new_symtree;
1716 sm->expr = gfc_copy_expr (expr);
1719 /* Stabilize the argument's value. */
1720 if (!sym->attr.function && se)
1721 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1723 if (sym->ts.type == BT_CHARACTER)
1725 /* Create a copy of the dummy argument's length. */
1726 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1727 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1729 /* If the length is specified as "*", record the length that
1730 the caller is passing. We should use the callee's length
1731 in all other cases. */
1732 if (!new_sym->ts.u.cl->length && se)
1734 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1735 new_sym->ts.u.cl->backend_decl = se->string_length;
1742 /* Use the passed value as-is if the argument is a function. */
1743 if (sym->attr.flavor == FL_PROCEDURE)
1746 /* If the argument is either a string or a pointer to a string,
1747 convert it to a boundless character type. */
1748 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1750 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1751 tmp = build_pointer_type (tmp);
1752 if (sym->attr.pointer)
1753 value = build_fold_indirect_ref_loc (input_location,
1757 value = fold_convert (tmp, value);
1760 /* If the argument is a scalar, a pointer to an array or an allocatable,
1762 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1763 value = build_fold_indirect_ref_loc (input_location,
1766 /* For character(*), use the actual argument's descriptor. */
1767 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1768 value = build_fold_indirect_ref_loc (input_location,
1771 /* If the argument is an array descriptor, use it to determine
1772 information about the actual argument's shape. */
1773 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1774 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1776 /* Get the actual argument's descriptor. */
1777 desc = build_fold_indirect_ref_loc (input_location,
1780 /* Create the replacement variable. */
1781 tmp = gfc_conv_descriptor_data_get (desc);
1782 value = gfc_get_interface_mapping_array (&se->pre, sym,
1785 /* Use DESC to work out the upper bounds, strides and offset. */
1786 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1789 /* Otherwise we have a packed array. */
1790 value = gfc_get_interface_mapping_array (&se->pre, sym,
1791 PACKED_FULL, se->expr);
1793 new_sym->backend_decl = value;
1797 /* Called once all dummy argument mappings have been added to MAPPING,
1798 but before the mapping is used to evaluate expressions. Pre-evaluate
1799 the length of each argument, adding any initialization code to PRE and
1800 any finalization code to POST. */
1803 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1804 stmtblock_t * pre, stmtblock_t * post)
1806 gfc_interface_sym_mapping *sym;
1810 for (sym = mapping->syms; sym; sym = sym->next)
1811 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1812 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1814 expr = sym->new_sym->n.sym->ts.u.cl->length;
1815 gfc_apply_interface_mapping_to_expr (mapping, expr);
1816 gfc_init_se (&se, NULL);
1817 gfc_conv_expr (&se, expr);
1818 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1819 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1820 gfc_add_block_to_block (pre, &se.pre);
1821 gfc_add_block_to_block (post, &se.post);
1823 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1828 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1832 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1833 gfc_constructor * c)
1835 for (; c; c = c->next)
1837 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1840 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1841 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1842 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1848 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1852 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1857 for (; ref; ref = ref->next)
1861 for (n = 0; n < ref->u.ar.dimen; n++)
1863 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1864 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1865 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1867 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1874 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1875 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1881 /* Convert intrinsic function calls into result expressions. */
1884 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1892 arg1 = expr->value.function.actual->expr;
1893 if (expr->value.function.actual->next)
1894 arg2 = expr->value.function.actual->next->expr;
1898 sym = arg1->symtree->n.sym;
1900 if (sym->attr.dummy)
1905 switch (expr->value.function.isym->id)
1908 /* TODO figure out why this condition is necessary. */
1909 if (sym->attr.function
1910 && (arg1->ts.u.cl->length == NULL
1911 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
1912 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
1915 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
1922 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1924 dup = mpz_get_si (arg2->value.integer);
1929 dup = sym->as->rank;
1933 for (; d < dup; d++)
1937 if (!sym->as->upper[d] || !sym->as->lower[d])
1939 gfc_free_expr (new_expr);
1943 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1944 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1946 new_expr = gfc_multiply (new_expr, tmp);
1952 case GFC_ISYM_LBOUND:
1953 case GFC_ISYM_UBOUND:
1954 /* TODO These implementations of lbound and ubound do not limit if
1955 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1960 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1961 d = mpz_get_si (arg2->value.integer) - 1;
1963 /* TODO: If the need arises, this could produce an array of
1967 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1969 if (sym->as->lower[d])
1970 new_expr = gfc_copy_expr (sym->as->lower[d]);
1974 if (sym->as->upper[d])
1975 new_expr = gfc_copy_expr (sym->as->upper[d]);
1983 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
1987 gfc_replace_expr (expr, new_expr);
1993 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
1994 gfc_interface_mapping * mapping)
1996 gfc_formal_arglist *f;
1997 gfc_actual_arglist *actual;
1999 actual = expr->value.function.actual;
2000 f = map_expr->symtree->n.sym->formal;
2002 for (; f && actual; f = f->next, actual = actual->next)
2007 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2010 if (map_expr->symtree->n.sym->attr.dimension)
2015 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2017 for (d = 0; d < as->rank; d++)
2019 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2020 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2023 expr->value.function.esym->as = as;
2026 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2028 expr->value.function.esym->ts.u.cl->length
2029 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2031 gfc_apply_interface_mapping_to_expr (mapping,
2032 expr->value.function.esym->ts.u.cl->length);
2037 /* EXPR is a copy of an expression that appeared in the interface
2038 associated with MAPPING. Walk it recursively looking for references to
2039 dummy arguments that MAPPING maps to actual arguments. Replace each such
2040 reference with a reference to the associated actual argument. */
2043 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2046 gfc_interface_sym_mapping *sym;
2047 gfc_actual_arglist *actual;
2052 /* Copying an expression does not copy its length, so do that here. */
2053 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2055 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2056 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2059 /* Apply the mapping to any references. */
2060 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2062 /* ...and to the expression's symbol, if it has one. */
2063 /* TODO Find out why the condition on expr->symtree had to be moved into
2064 the loop rather than being outside it, as originally. */
2065 for (sym = mapping->syms; sym; sym = sym->next)
2066 if (expr->symtree && sym->old == expr->symtree->n.sym)
2068 if (sym->new_sym->n.sym->backend_decl)
2069 expr->symtree = sym->new_sym;
2071 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2074 /* ...and to subexpressions in expr->value. */
2075 switch (expr->expr_type)
2080 case EXPR_SUBSTRING:
2084 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2085 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2089 for (actual = expr->value.function.actual; actual; actual = actual->next)
2090 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2092 if (expr->value.function.esym == NULL
2093 && expr->value.function.isym != NULL
2094 && expr->value.function.actual->expr->symtree
2095 && gfc_map_intrinsic_function (expr, mapping))
2098 for (sym = mapping->syms; sym; sym = sym->next)
2099 if (sym->old == expr->value.function.esym)
2101 expr->value.function.esym = sym->new_sym->n.sym;
2102 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2103 expr->value.function.esym->result = sym->new_sym->n.sym;
2108 case EXPR_STRUCTURE:
2109 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2122 /* Evaluate interface expression EXPR using MAPPING. Store the result
2126 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2127 gfc_se * se, gfc_expr * expr)
2129 expr = gfc_copy_expr (expr);
2130 gfc_apply_interface_mapping_to_expr (mapping, expr);
2131 gfc_conv_expr (se, expr);
2132 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2133 gfc_free_expr (expr);
2137 /* Returns a reference to a temporary array into which a component of
2138 an actual argument derived type array is copied and then returned
2139 after the function call. */
2141 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2142 int g77, sym_intent intent)
2158 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2160 gfc_init_se (&lse, NULL);
2161 gfc_init_se (&rse, NULL);
2163 /* Walk the argument expression. */
2164 rss = gfc_walk_expr (expr);
2166 gcc_assert (rss != gfc_ss_terminator);
2168 /* Initialize the scalarizer. */
2169 gfc_init_loopinfo (&loop);
2170 gfc_add_ss_to_loop (&loop, rss);
2172 /* Calculate the bounds of the scalarization. */
2173 gfc_conv_ss_startstride (&loop);
2175 /* Build an ss for the temporary. */
2176 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2177 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2179 base_type = gfc_typenode_for_spec (&expr->ts);
2180 if (GFC_ARRAY_TYPE_P (base_type)
2181 || GFC_DESCRIPTOR_TYPE_P (base_type))
2182 base_type = gfc_get_element_type (base_type);
2184 loop.temp_ss = gfc_get_ss ();;
2185 loop.temp_ss->type = GFC_SS_TEMP;
2186 loop.temp_ss->data.temp.type = base_type;
2188 if (expr->ts.type == BT_CHARACTER)
2189 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2191 loop.temp_ss->string_length = NULL;
2193 parmse->string_length = loop.temp_ss->string_length;
2194 loop.temp_ss->data.temp.dimen = loop.dimen;
2195 loop.temp_ss->next = gfc_ss_terminator;
2197 /* Associate the SS with the loop. */
2198 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2200 /* Setup the scalarizing loops. */
2201 gfc_conv_loop_setup (&loop, &expr->where);
2203 /* Pass the temporary descriptor back to the caller. */
2204 info = &loop.temp_ss->data.info;
2205 parmse->expr = info->descriptor;
2207 /* Setup the gfc_se structures. */
2208 gfc_copy_loopinfo_to_se (&lse, &loop);
2209 gfc_copy_loopinfo_to_se (&rse, &loop);
2212 lse.ss = loop.temp_ss;
2213 gfc_mark_ss_chain_used (rss, 1);
2214 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2216 /* Start the scalarized loop body. */
2217 gfc_start_scalarized_body (&loop, &body);
2219 /* Translate the expression. */
2220 gfc_conv_expr (&rse, expr);
2222 gfc_conv_tmp_array_ref (&lse);
2223 gfc_advance_se_ss_chain (&lse);
2225 if (intent != INTENT_OUT)
2227 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2228 gfc_add_expr_to_block (&body, tmp);
2229 gcc_assert (rse.ss == gfc_ss_terminator);
2230 gfc_trans_scalarizing_loops (&loop, &body);
2234 /* Make sure that the temporary declaration survives by merging
2235 all the loop declarations into the current context. */
2236 for (n = 0; n < loop.dimen; n++)
2238 gfc_merge_block_scope (&body);
2239 body = loop.code[loop.order[n]];
2241 gfc_merge_block_scope (&body);
2244 /* Add the post block after the second loop, so that any
2245 freeing of allocated memory is done at the right time. */
2246 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2248 /**********Copy the temporary back again.*********/
2250 gfc_init_se (&lse, NULL);
2251 gfc_init_se (&rse, NULL);
2253 /* Walk the argument expression. */
2254 lss = gfc_walk_expr (expr);
2255 rse.ss = loop.temp_ss;
2258 /* Initialize the scalarizer. */
2259 gfc_init_loopinfo (&loop2);
2260 gfc_add_ss_to_loop (&loop2, lss);
2262 /* Calculate the bounds of the scalarization. */
2263 gfc_conv_ss_startstride (&loop2);
2265 /* Setup the scalarizing loops. */
2266 gfc_conv_loop_setup (&loop2, &expr->where);
2268 gfc_copy_loopinfo_to_se (&lse, &loop2);
2269 gfc_copy_loopinfo_to_se (&rse, &loop2);
2271 gfc_mark_ss_chain_used (lss, 1);
2272 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2274 /* Declare the variable to hold the temporary offset and start the
2275 scalarized loop body. */
2276 offset = gfc_create_var (gfc_array_index_type, NULL);
2277 gfc_start_scalarized_body (&loop2, &body);
2279 /* Build the offsets for the temporary from the loop variables. The
2280 temporary array has lbounds of zero and strides of one in all
2281 dimensions, so this is very simple. The offset is only computed
2282 outside the innermost loop, so the overall transfer could be
2283 optimized further. */
2284 info = &rse.ss->data.info;
2286 tmp_index = gfc_index_zero_node;
2287 for (n = info->dimen - 1; n > 0; n--)
2290 tmp = rse.loop->loopvar[n];
2291 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2292 tmp, rse.loop->from[n]);
2293 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2296 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2297 rse.loop->to[n-1], rse.loop->from[n-1]);
2298 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2299 tmp_str, gfc_index_one_node);
2301 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2305 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2306 tmp_index, rse.loop->from[0]);
2307 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2309 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2310 rse.loop->loopvar[0], offset);
2312 /* Now use the offset for the reference. */
2313 tmp = build_fold_indirect_ref_loc (input_location,
2315 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2317 if (expr->ts.type == BT_CHARACTER)
2318 rse.string_length = expr->ts.u.cl->backend_decl;
2320 gfc_conv_expr (&lse, expr);
2322 gcc_assert (lse.ss == gfc_ss_terminator);
2324 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2325 gfc_add_expr_to_block (&body, tmp);
2327 /* Generate the copying loops. */
2328 gfc_trans_scalarizing_loops (&loop2, &body);
2330 /* Wrap the whole thing up by adding the second loop to the post-block
2331 and following it by the post-block of the first loop. In this way,
2332 if the temporary needs freeing, it is done after use! */
2333 if (intent != INTENT_IN)
2335 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2336 gfc_add_block_to_block (&parmse->post, &loop2.post);
2339 gfc_add_block_to_block (&parmse->post, &loop.post);
2341 gfc_cleanup_loop (&loop);
2342 gfc_cleanup_loop (&loop2);
2344 /* Pass the string length to the argument expression. */
2345 if (expr->ts.type == BT_CHARACTER)
2346 parmse->string_length = expr->ts.u.cl->backend_decl;
2348 /* We want either the address for the data or the address of the descriptor,
2349 depending on the mode of passing array arguments. */
2351 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2353 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2359 /* Generate the code for argument list functions. */
2362 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2364 /* Pass by value for g77 %VAL(arg), pass the address
2365 indirectly for %LOC, else by reference. Thus %REF
2366 is a "do-nothing" and %LOC is the same as an F95
2368 if (strncmp (name, "%VAL", 4) == 0)
2369 gfc_conv_expr (se, expr);
2370 else if (strncmp (name, "%LOC", 4) == 0)
2372 gfc_conv_expr_reference (se, expr);
2373 se->expr = gfc_build_addr_expr (NULL, se->expr);
2375 else if (strncmp (name, "%REF", 4) == 0)
2376 gfc_conv_expr_reference (se, expr);
2378 gfc_error ("Unknown argument list function at %L", &expr->where);
2382 /* Generate code for a procedure call. Note can return se->post != NULL.
2383 If se->direct_byref is set then se->expr contains the return parameter.
2384 Return nonzero, if the call has alternate specifiers.
2385 'expr' is only needed for procedure pointer components. */
2388 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2389 gfc_actual_arglist * arg, gfc_expr * expr,
2392 gfc_interface_mapping mapping;
2406 gfc_formal_arglist *formal;
2407 int has_alternate_specifier = 0;
2408 bool need_interface_mapping;
2415 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2416 gfc_component *comp = NULL;
2418 arglist = NULL_TREE;
2419 retargs = NULL_TREE;
2420 stringargs = NULL_TREE;
2425 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2427 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2429 if (arg->expr->rank == 0)
2430 gfc_conv_expr_reference (se, arg->expr);
2434 /* This is really the actual arg because no formal arglist is
2435 created for C_LOC. */
2436 fsym = arg->expr->symtree->n.sym;
2438 /* We should want it to do g77 calling convention. */
2440 && !(fsym->attr.pointer || fsym->attr.allocatable)
2441 && fsym->as->type != AS_ASSUMED_SHAPE;
2442 f = f || !sym->attr.always_explicit;
2444 argss = gfc_walk_expr (arg->expr);
2445 gfc_conv_array_parameter (se, arg->expr, argss, f,
2449 /* TODO -- the following two lines shouldn't be necessary, but
2450 they're removed a bug is exposed later in the codepath.
2451 This is workaround was thus introduced, but will have to be
2452 removed; please see PR 35150 for details about the issue. */
2453 se->expr = convert (pvoid_type_node, se->expr);
2454 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2458 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2460 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2461 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2462 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2463 gfc_conv_expr_reference (se, arg->expr);
2467 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2468 && arg->next->expr->rank == 0)
2469 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2471 /* Convert c_f_pointer if fptr is a scalar
2472 and convert c_f_procpointer. */
2476 gfc_init_se (&cptrse, NULL);
2477 gfc_conv_expr (&cptrse, arg->expr);
2478 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2479 gfc_add_block_to_block (&se->post, &cptrse.post);
2481 gfc_init_se (&fptrse, NULL);
2482 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2483 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2484 fptrse.want_pointer = 1;
2486 gfc_conv_expr (&fptrse, arg->next->expr);
2487 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2488 gfc_add_block_to_block (&se->post, &fptrse.post);
2490 if (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2491 tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
2493 tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
2494 se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
2495 fold_convert (tmp, cptrse.expr));
2499 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2504 /* Build the addr_expr for the first argument. The argument is
2505 already an *address* so we don't need to set want_pointer in
2507 gfc_init_se (&arg1se, NULL);
2508 gfc_conv_expr (&arg1se, arg->expr);
2509 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2510 gfc_add_block_to_block (&se->post, &arg1se.post);
2512 /* See if we were given two arguments. */
2513 if (arg->next == NULL)
2514 /* Only given one arg so generate a null and do a
2515 not-equal comparison against the first arg. */
2516 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2517 fold_convert (TREE_TYPE (arg1se.expr),
2518 null_pointer_node));
2524 /* Given two arguments so build the arg2se from second arg. */
2525 gfc_init_se (&arg2se, NULL);
2526 gfc_conv_expr (&arg2se, arg->next->expr);
2527 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2528 gfc_add_block_to_block (&se->post, &arg2se.post);
2530 /* Generate test to compare that the two args are equal. */
2531 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2532 arg1se.expr, arg2se.expr);
2533 /* Generate test to ensure that the first arg is not null. */
2534 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2535 arg1se.expr, null_pointer_node);
2537 /* Finally, the generated test must check that both arg1 is not
2538 NULL and that it is equal to the second arg. */
2539 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2540 not_null_expr, eq_expr);
2547 gfc_is_proc_ptr_comp (expr, &comp);
2551 if (!sym->attr.elemental)
2553 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2554 if (se->ss->useflags)
2556 gcc_assert ((!comp && gfc_return_by_reference (sym)
2557 && sym->result->attr.dimension)
2558 || (comp && comp->attr.dimension));
2559 gcc_assert (se->loop != NULL);
2561 /* Access the previously obtained result. */
2562 gfc_conv_tmp_array_ref (se);
2563 gfc_advance_se_ss_chain (se);
2567 info = &se->ss->data.info;
2572 gfc_init_block (&post);
2573 gfc_init_interface_mapping (&mapping);
2574 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2575 && sym->ts.u.cl->length
2576 && sym->ts.u.cl->length->expr_type
2578 || (comp && comp->attr.dimension)
2579 || (!comp && sym->attr.dimension));
2581 formal = comp->formal;
2583 formal = sym->formal;
2584 /* Evaluate the arguments. */
2585 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2588 fsym = formal ? formal->sym : NULL;
2589 parm_kind = MISSING;
2593 if (se->ignore_optional)
2595 /* Some intrinsics have already been resolved to the correct
2599 else if (arg->label)
2601 has_alternate_specifier = 1;
2606 /* Pass a NULL pointer for an absent arg. */
2607 gfc_init_se (&parmse, NULL);
2608 parmse.expr = null_pointer_node;
2609 if (arg->missing_arg_type == BT_CHARACTER)
2610 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2613 else if (se->ss && se->ss->useflags)
2615 /* An elemental function inside a scalarized loop. */
2616 gfc_init_se (&parmse, se);
2617 gfc_conv_expr_reference (&parmse, e);
2618 parm_kind = ELEMENTAL;
2622 /* A scalar or transformational function. */
2623 gfc_init_se (&parmse, NULL);
2624 argss = gfc_walk_expr (e);
2626 if (argss == gfc_ss_terminator)
2628 if (e->expr_type == EXPR_VARIABLE
2629 && e->symtree->n.sym->attr.cray_pointee
2630 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2632 /* The Cray pointer needs to be converted to a pointer to
2633 a type given by the expression. */
2634 gfc_conv_expr (&parmse, e);
2635 type = build_pointer_type (TREE_TYPE (parmse.expr));
2636 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2637 parmse.expr = convert (type, tmp);
2639 else if (fsym && fsym->attr.value)
2641 if (fsym->ts.type == BT_CHARACTER
2642 && fsym->ts.is_c_interop
2643 && fsym->ns->proc_name != NULL
2644 && fsym->ns->proc_name->attr.is_bind_c)
2647 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2648 if (parmse.expr == NULL)
2649 gfc_conv_expr (&parmse, e);
2652 gfc_conv_expr (&parmse, e);
2654 else if (arg->name && arg->name[0] == '%')
2655 /* Argument list functions %VAL, %LOC and %REF are signalled
2656 through arg->name. */
2657 conv_arglist_function (&parmse, arg->expr, arg->name);
2658 else if ((e->expr_type == EXPR_FUNCTION)
2659 && e->symtree->n.sym->attr.pointer
2660 && fsym && fsym->attr.target)
2662 gfc_conv_expr (&parmse, e);
2663 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2665 else if (e->expr_type == EXPR_FUNCTION
2666 && e->symtree->n.sym->result
2667 && e->symtree->n.sym->result->attr.proc_pointer)
2669 /* Functions returning procedure pointers. */
2670 gfc_conv_expr (&parmse, e);
2671 if (fsym && fsym->attr.proc_pointer)
2672 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2676 gfc_conv_expr_reference (&parmse, e);
2677 if (fsym && e->expr_type != EXPR_NULL
2678 && ((fsym->attr.pointer
2679 && fsym->attr.flavor != FL_PROCEDURE)
2680 || (fsym->attr.proc_pointer
2681 && !(e->expr_type == EXPR_VARIABLE
2682 && e->symtree->n.sym->attr.dummy))
2683 || gfc_is_proc_ptr_comp (e, NULL)))
2685 /* Scalar pointer dummy args require an extra level of
2686 indirection. The null pointer already contains
2687 this level of indirection. */
2688 parm_kind = SCALAR_POINTER;
2689 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2695 /* If the procedure requires an explicit interface, the actual
2696 argument is passed according to the corresponding formal
2697 argument. If the corresponding formal argument is a POINTER,
2698 ALLOCATABLE or assumed shape, we do not use g77's calling
2699 convention, and pass the address of the array descriptor
2700 instead. Otherwise we use g77's calling convention. */
2703 && !(fsym->attr.pointer || fsym->attr.allocatable)
2704 && fsym->as->type != AS_ASSUMED_SHAPE;
2705 f = f || !sym->attr.always_explicit;
2707 if (e->expr_type == EXPR_VARIABLE
2708 && is_subref_array (e))
2709 /* The actual argument is a component reference to an
2710 array of derived types. In this case, the argument
2711 is converted to a temporary, which is passed and then
2712 written back after the procedure call. */
2713 gfc_conv_subref_array_arg (&parmse, e, f,
2714 fsym ? fsym->attr.intent : INTENT_INOUT);
2716 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2719 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2720 allocated on entry, it must be deallocated. */
2721 if (fsym && fsym->attr.allocatable
2722 && fsym->attr.intent == INTENT_OUT)
2724 tmp = build_fold_indirect_ref_loc (input_location,
2726 tmp = gfc_trans_dealloc_allocated (tmp);
2727 gfc_add_expr_to_block (&se->pre, tmp);
2733 /* The case with fsym->attr.optional is that of a user subroutine
2734 with an interface indicating an optional argument. When we call
2735 an intrinsic subroutine, however, fsym is NULL, but we might still
2736 have an optional argument, so we proceed to the substitution
2738 if (e && (fsym == NULL || fsym->attr.optional))
2740 /* If an optional argument is itself an optional dummy argument,
2741 check its presence and substitute a null if absent. */
2742 if (e->expr_type == EXPR_VARIABLE
2743 && e->symtree->n.sym->attr.optional)
2744 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2745 e->representation.length);
2750 /* Obtain the character length of an assumed character length
2751 length procedure from the typespec. */
2752 if (fsym->ts.type == BT_CHARACTER
2753 && parmse.string_length == NULL_TREE
2754 && e->ts.type == BT_PROCEDURE
2755 && e->symtree->n.sym->ts.type == BT_CHARACTER
2756 && e->symtree->n.sym->ts.u.cl->length != NULL
2757 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2759 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
2760 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
2764 if (fsym && need_interface_mapping && e)
2765 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2767 gfc_add_block_to_block (&se->pre, &parmse.pre);
2768 gfc_add_block_to_block (&post, &parmse.post);
2770 /* Allocated allocatable components of derived types must be
2771 deallocated for non-variable scalars. Non-variable arrays are
2772 dealt with in trans-array.c(gfc_conv_array_parameter). */
2773 if (e && e->ts.type == BT_DERIVED
2774 && e->ts.u.derived->attr.alloc_comp
2775 && !(e->symtree && e->symtree->n.sym->attr.pointer)
2776 && (e->expr_type != EXPR_VARIABLE && !e->rank))
2779 tmp = build_fold_indirect_ref_loc (input_location,
2781 parm_rank = e->rank;
2789 case (SCALAR_POINTER):
2790 tmp = build_fold_indirect_ref_loc (input_location,
2795 if (e->expr_type == EXPR_OP
2796 && e->value.op.op == INTRINSIC_PARENTHESES
2797 && e->value.op.op1->expr_type == EXPR_VARIABLE)
2800 local_tmp = gfc_evaluate_now (tmp, &se->pre);
2801 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
2802 gfc_add_expr_to_block (&se->post, local_tmp);
2805 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
2807 gfc_add_expr_to_block (&se->post, tmp);
2810 /* Add argument checking of passing an unallocated/NULL actual to
2811 a nonallocatable/nonpointer dummy. */
2813 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
2815 symbol_attribute *attr;
2819 if (e->expr_type == EXPR_VARIABLE)
2820 attr = &e->symtree->n.sym->attr;
2821 else if (e->expr_type == EXPR_FUNCTION)
2823 /* For intrinsic functions, the gfc_attr are not available. */
2824 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
2825 goto end_pointer_check;
2827 if (e->symtree->n.sym->attr.generic)
2828 attr = &e->value.function.esym->attr;
2830 attr = &e->symtree->n.sym->result->attr;
2833 goto end_pointer_check;
2837 /* If the actual argument is an optional pointer/allocatable and
2838 the formal argument takes an nonpointer optional value,
2839 it is invalid to pass a non-present argument on, even
2840 though there is no technical reason for this in gfortran.
2841 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
2842 tree present, nullptr, type;
2844 if (attr->allocatable
2845 && (fsym == NULL || !fsym->attr.allocatable))
2846 asprintf (&msg, "Allocatable actual argument '%s' is not "
2847 "allocated or not present", e->symtree->n.sym->name);
2848 else if (attr->pointer
2849 && (fsym == NULL || !fsym->attr.pointer))
2850 asprintf (&msg, "Pointer actual argument '%s' is not "
2851 "associated or not present",
2852 e->symtree->n.sym->name);
2853 else if (attr->proc_pointer
2854 && (fsym == NULL || !fsym->attr.proc_pointer))
2855 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
2856 "associated or not present",
2857 e->symtree->n.sym->name);
2859 goto end_pointer_check;
2861 present = gfc_conv_expr_present (e->symtree->n.sym);
2862 type = TREE_TYPE (present);
2863 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
2864 fold_convert (type, null_pointer_node));
2865 type = TREE_TYPE (parmse.expr);
2866 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
2867 fold_convert (type, null_pointer_node));
2868 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
2873 if (attr->allocatable
2874 && (fsym == NULL || !fsym->attr.allocatable))
2875 asprintf (&msg, "Allocatable actual argument '%s' is not "
2876 "allocated", e->symtree->n.sym->name);
2877 else if (attr->pointer
2878 && (fsym == NULL || !fsym->attr.pointer))
2879 asprintf (&msg, "Pointer actual argument '%s' is not "
2880 "associated", e->symtree->n.sym->name);
2881 else if (attr->proc_pointer
2882 && (fsym == NULL || !fsym->attr.proc_pointer))
2883 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
2884 "associated", e->symtree->n.sym->name);
2886 goto end_pointer_check;
2889 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
2890 fold_convert (TREE_TYPE (parmse.expr),
2891 null_pointer_node));
2894 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
2901 /* Character strings are passed as two parameters, a length and a
2902 pointer - except for Bind(c) which only passes the pointer. */
2903 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2904 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2906 arglist = gfc_chainon_list (arglist, parmse.expr);
2908 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2911 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
2912 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2913 else if (ts.type == BT_CHARACTER)
2915 if (sym->ts.u.cl->length == NULL)
2917 /* Assumed character length results are not allowed by 5.1.1.5 of the
2918 standard and are trapped in resolve.c; except in the case of SPREAD
2919 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2920 we take the character length of the first argument for the result.
2921 For dummies, we have to look through the formal argument list for
2922 this function and use the character length found there.*/
2923 if (!sym->attr.dummy)
2924 cl.backend_decl = TREE_VALUE (stringargs);
2927 formal = sym->ns->proc_name->formal;
2928 for (; formal; formal = formal->next)
2929 if (strcmp (formal->sym->name, sym->name) == 0)
2930 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
2937 /* Calculate the length of the returned string. */
2938 gfc_init_se (&parmse, NULL);
2939 if (need_interface_mapping)
2940 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length);
2942 gfc_conv_expr (&parmse, sym->ts.u.cl->length);
2943 gfc_add_block_to_block (&se->pre, &parmse.pre);
2944 gfc_add_block_to_block (&se->post, &parmse.post);
2946 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2947 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2948 build_int_cst (gfc_charlen_type_node, 0));
2949 cl.backend_decl = tmp;
2952 /* Set up a charlen structure for it. */
2957 len = cl.backend_decl;
2960 byref = (comp && comp->attr.dimension)
2961 || (!comp && gfc_return_by_reference (sym));
2964 if (se->direct_byref)
2966 /* Sometimes, too much indirection can be applied; e.g. for
2967 function_result = array_valued_recursive_function. */
2968 if (TREE_TYPE (TREE_TYPE (se->expr))
2969 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2970 && GFC_DESCRIPTOR_TYPE_P
2971 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2972 se->expr = build_fold_indirect_ref_loc (input_location,
2975 retargs = gfc_chainon_list (retargs, se->expr);
2977 else if (comp && comp->attr.dimension)
2979 gcc_assert (se->loop && info);
2981 /* Set the type of the array. */
2982 tmp = gfc_typenode_for_spec (&comp->ts);
2983 info->dimen = se->loop->dimen;
2985 /* Evaluate the bounds of the result, if known. */
2986 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
2988 /* Create a temporary to store the result. In case the function
2989 returns a pointer, the temporary will be a shallow copy and
2990 mustn't be deallocated. */
2991 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
2992 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2993 NULL_TREE, false, !comp->attr.pointer,
2994 callee_alloc, &se->ss->expr->where);
2996 /* Pass the temporary as the first argument. */
2997 tmp = info->descriptor;
2998 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2999 retargs = gfc_chainon_list (retargs, tmp);
3001 else if (sym->result->attr.dimension)
3003 gcc_assert (se->loop && info);
3005 /* Set the type of the array. */
3006 tmp = gfc_typenode_for_spec (&ts);
3007 info->dimen = se->loop->dimen;
3009 /* Evaluate the bounds of the result, if known. */
3010 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3012 /* Create a temporary to store the result. In case the function
3013 returns a pointer, the temporary will be a shallow copy and
3014 mustn't be deallocated. */
3015 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3016 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3017 NULL_TREE, false, !sym->attr.pointer,
3018 callee_alloc, &se->ss->expr->where);
3020 /* Pass the temporary as the first argument. */
3021 tmp = info->descriptor;
3022 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3023 retargs = gfc_chainon_list (retargs, tmp);
3025 else if (ts.type == BT_CHARACTER)
3027 /* Pass the string length. */
3028 type = gfc_get_character_type (ts.kind, ts.u.cl);
3029 type = build_pointer_type (type);
3031 /* Return an address to a char[0:len-1]* temporary for
3032 character pointers. */
3033 if (sym->attr.pointer || sym->attr.allocatable)
3035 var = gfc_create_var (type, "pstr");
3037 /* Provide an address expression for the function arguments. */
3038 var = gfc_build_addr_expr (NULL_TREE, var);
3041 var = gfc_conv_string_tmp (se, type, len);
3043 retargs = gfc_chainon_list (retargs, var);
3047 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3049 type = gfc_get_complex_type (ts.kind);
3050 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3051 retargs = gfc_chainon_list (retargs, var);
3054 /* Add the string length to the argument list. */
3055 if (ts.type == BT_CHARACTER)
3056 retargs = gfc_chainon_list (retargs, len);
3058 gfc_free_interface_mapping (&mapping);
3060 /* Add the return arguments. */
3061 arglist = chainon (retargs, arglist);
3063 /* Add the hidden string length parameters to the arguments. */
3064 arglist = chainon (arglist, stringargs);
3066 /* We may want to append extra arguments here. This is used e.g. for
3067 calls to libgfortran_matmul_??, which need extra information. */
3068 if (append_args != NULL_TREE)
3069 arglist = chainon (arglist, append_args);
3071 /* Generate the actual call. */
3072 conv_function_val (se, sym, expr);
3074 /* If there are alternate return labels, function type should be
3075 integer. Can't modify the type in place though, since it can be shared
3076 with other functions. For dummy arguments, the typing is done to
3077 to this result, even if it has to be repeated for each call. */
3078 if (has_alternate_specifier
3079 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3081 if (!sym->attr.dummy)
3083 TREE_TYPE (sym->backend_decl)
3084 = build_function_type (integer_type_node,
3085 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3086 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3089 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3092 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3093 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3095 /* If we have a pointer function, but we don't want a pointer, e.g.
3098 where f is pointer valued, we have to dereference the result. */
3099 if (!se->want_pointer && !byref && sym->attr.pointer
3100 && !gfc_is_proc_ptr_comp (expr, NULL))
3101 se->expr = build_fold_indirect_ref_loc (input_location,
3104 /* f2c calling conventions require a scalar default real function to
3105 return a double precision result. Convert this back to default
3106 real. We only care about the cases that can happen in Fortran 77.
3108 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3109 && sym->ts.kind == gfc_default_real_kind
3110 && !sym->attr.always_explicit)
3111 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3113 /* A pure function may still have side-effects - it may modify its
3115 TREE_SIDE_EFFECTS (se->expr) = 1;
3117 if (!sym->attr.pure)
3118 TREE_SIDE_EFFECTS (se->expr) = 1;
3123 /* Add the function call to the pre chain. There is no expression. */
3124 gfc_add_expr_to_block (&se->pre, se->expr);
3125 se->expr = NULL_TREE;
3127 if (!se->direct_byref)
3129 if (sym->attr.dimension || (comp && comp->attr.dimension))
3131 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3133 /* Check the data pointer hasn't been modified. This would
3134 happen in a function returning a pointer. */
3135 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3136 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3138 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3141 se->expr = info->descriptor;
3142 /* Bundle in the string length. */
3143 se->string_length = len;
3145 else if (sym->ts.type == BT_CHARACTER)
3147 /* Dereference for character pointer results. */
3148 if (sym->attr.pointer || sym->attr.allocatable)
3149 se->expr = build_fold_indirect_ref_loc (input_location,
3154 se->string_length = len;
3158 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3159 se->expr = build_fold_indirect_ref_loc (input_location,
3165 /* Follow the function call with the argument post block. */
3167 gfc_add_block_to_block (&se->pre, &post);
3169 gfc_add_block_to_block (&se->post, &post);
3171 return has_alternate_specifier;
3175 /* Fill a character string with spaces. */
3178 fill_with_spaces (tree start, tree type, tree size)
3180 stmtblock_t block, loop;
3181 tree i, el, exit_label, cond, tmp;
3183 /* For a simple char type, we can call memset(). */
3184 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3185 return build_call_expr_loc (input_location,
3186 built_in_decls[BUILT_IN_MEMSET], 3, start,
3187 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3188 lang_hooks.to_target_charset (' ')),
3191 /* Otherwise, we use a loop:
3192 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3196 /* Initialize variables. */
3197 gfc_init_block (&block);
3198 i = gfc_create_var (sizetype, "i");
3199 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3200 el = gfc_create_var (build_pointer_type (type), "el");
3201 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3202 exit_label = gfc_build_label_decl (NULL_TREE);
3203 TREE_USED (exit_label) = 1;
3207 gfc_init_block (&loop);
3209 /* Exit condition. */
3210 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3211 fold_convert (sizetype, integer_zero_node));
3212 tmp = build1_v (GOTO_EXPR, exit_label);
3213 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3214 build_empty_stmt (input_location));
3215 gfc_add_expr_to_block (&loop, tmp);
3218 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3219 build_int_cst (type,
3220 lang_hooks.to_target_charset (' ')));
3222 /* Increment loop variables. */
3223 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3224 TYPE_SIZE_UNIT (type)));
3225 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3227 TYPE_SIZE_UNIT (type)));
3229 /* Making the loop... actually loop! */
3230 tmp = gfc_finish_block (&loop);
3231 tmp = build1_v (LOOP_EXPR, tmp);
3232 gfc_add_expr_to_block (&block, tmp);
3234 /* The exit label. */
3235 tmp = build1_v (LABEL_EXPR, exit_label);
3236 gfc_add_expr_to_block (&block, tmp);
3239 return gfc_finish_block (&block);
3243 /* Generate code to copy a string. */
3246 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3247 int dkind, tree slength, tree src, int skind)
3249 tree tmp, dlen, slen;
3258 stmtblock_t tempblock;
3260 gcc_assert (dkind == skind);
3262 if (slength != NULL_TREE)
3264 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3265 ssc = string_to_single_character (slen, src, skind);
3269 slen = build_int_cst (size_type_node, 1);
3273 if (dlength != NULL_TREE)
3275 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3276 dsc = string_to_single_character (slen, dest, dkind);
3280 dlen = build_int_cst (size_type_node, 1);
3284 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3285 ssc = string_to_single_character (slen, src, skind);
3286 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3287 dsc = string_to_single_character (dlen, dest, dkind);
3290 /* Assign directly if the types are compatible. */
3291 if (dsc != NULL_TREE && ssc != NULL_TREE
3292 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3294 gfc_add_modify (block, dsc, ssc);
3298 /* Do nothing if the destination length is zero. */
3299 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3300 build_int_cst (size_type_node, 0));
3302 /* The following code was previously in _gfortran_copy_string:
3304 // The two strings may overlap so we use memmove.
3306 copy_string (GFC_INTEGER_4 destlen, char * dest,
3307 GFC_INTEGER_4 srclen, const char * src)
3309 if (srclen >= destlen)
3311 // This will truncate if too long.
3312 memmove (dest, src, destlen);
3316 memmove (dest, src, srclen);
3318 memset (&dest[srclen], ' ', destlen - srclen);
3322 We're now doing it here for better optimization, but the logic
3325 /* For non-default character kinds, we have to multiply the string
3326 length by the base type size. */
3327 chartype = gfc_get_char_type (dkind);
3328 slen = fold_build2 (MULT_EXPR, size_type_node,
3329 fold_convert (size_type_node, slen),
3330 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3331 dlen = fold_build2 (MULT_EXPR, size_type_node,
3332 fold_convert (size_type_node, dlen),
3333 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3336 dest = fold_convert (pvoid_type_node, dest);
3338 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3341 src = fold_convert (pvoid_type_node, src);
3343 src = gfc_build_addr_expr (pvoid_type_node, src);
3345 /* Truncate string if source is too long. */
3346 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3347 tmp2 = build_call_expr_loc (input_location,
3348 built_in_decls[BUILT_IN_MEMMOVE],
3349 3, dest, src, dlen);
3351 /* Else copy and pad with spaces. */
3352 tmp3 = build_call_expr_loc (input_location,
3353 built_in_decls[BUILT_IN_MEMMOVE],
3354 3, dest, src, slen);
3356 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3357 fold_convert (sizetype, slen));
3358 tmp4 = fill_with_spaces (tmp4, chartype,
3359 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3362 gfc_init_block (&tempblock);
3363 gfc_add_expr_to_block (&tempblock, tmp3);
3364 gfc_add_expr_to_block (&tempblock, tmp4);
3365 tmp3 = gfc_finish_block (&tempblock);
3367 /* The whole copy_string function is there. */
3368 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3369 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3370 build_empty_stmt (input_location));
3371 gfc_add_expr_to_block (block, tmp);
3375 /* Translate a statement function.
3376 The value of a statement function reference is obtained by evaluating the
3377 expression using the values of the actual arguments for the values of the
3378 corresponding dummy arguments. */
3381 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3385 gfc_formal_arglist *fargs;
3386 gfc_actual_arglist *args;
3389 gfc_saved_var *saved_vars;
3395 sym = expr->symtree->n.sym;
3396 args = expr->value.function.actual;
3397 gfc_init_se (&lse, NULL);
3398 gfc_init_se (&rse, NULL);
3401 for (fargs = sym->formal; fargs; fargs = fargs->next)
3403 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3404 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3406 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3408 /* Each dummy shall be specified, explicitly or implicitly, to be
3410 gcc_assert (fargs->sym->attr.dimension == 0);
3413 /* Create a temporary to hold the value. */
3414 type = gfc_typenode_for_spec (&fsym->ts);
3415 temp_vars[n] = gfc_create_var (type, fsym->name);
3417 if (fsym->ts.type == BT_CHARACTER)
3419 /* Copy string arguments. */
3422 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3423 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3425 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3426 tmp = gfc_build_addr_expr (build_pointer_type (type),
3429 gfc_conv_expr (&rse, args->expr);
3430 gfc_conv_string_parameter (&rse);
3431 gfc_add_block_to_block (&se->pre, &lse.pre);
3432 gfc_add_block_to_block (&se->pre, &rse.pre);
3434 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3435 rse.string_length, rse.expr, fsym->ts.kind);
3436 gfc_add_block_to_block (&se->pre, &lse.post);
3437 gfc_add_block_to_block (&se->pre, &rse.post);
3441 /* For everything else, just evaluate the expression. */
3442 gfc_conv_expr (&lse, args->expr);
3444 gfc_add_block_to_block (&se->pre, &lse.pre);
3445 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3446 gfc_add_block_to_block (&se->pre, &lse.post);
3452 /* Use the temporary variables in place of the real ones. */
3453 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3454 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3456 gfc_conv_expr (se, sym->value);
3458 if (sym->ts.type == BT_CHARACTER)
3460 gfc_conv_const_charlen (sym->ts.u.cl);
3462 /* Force the expression to the correct length. */
3463 if (!INTEGER_CST_P (se->string_length)
3464 || tree_int_cst_lt (se->string_length,
3465 sym->ts.u.cl->backend_decl))
3467 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3468 tmp = gfc_create_var (type, sym->name);
3469 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3470 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3471 sym->ts.kind, se->string_length, se->expr,
3475 se->string_length = sym->ts.u.cl->backend_decl;
3478 /* Restore the original variables. */
3479 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3480 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3481 gfc_free (saved_vars);
3485 /* Return the backend_decl for a procedure pointer component. */
3488 gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
3492 gfc_init_se (&comp_se, NULL);
3493 e2 = gfc_copy_expr (e);
3494 e2->expr_type = EXPR_VARIABLE;
3495 gfc_conv_expr (&comp_se, e2);
3496 comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr);
3497 return gfc_evaluate_now (comp_se.expr, &se->pre);
3501 /* Translate a function expression. */
3504 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3508 if (expr->value.function.isym)
3510 gfc_conv_intrinsic_function (se, expr);
3514 /* We distinguish statement functions from general functions to improve
3515 runtime performance. */
3516 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3518 gfc_conv_statement_function (se, expr);
3522 /* expr.value.function.esym is the resolved (specific) function symbol for
3523 most functions. However this isn't set for dummy procedures. */
3524 sym = expr->value.function.esym;
3526 sym = expr->symtree->n.sym;
3528 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3534 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3536 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3537 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3539 gfc_conv_tmp_array_ref (se);
3540 gfc_advance_se_ss_chain (se);
3544 /* Build a static initializer. EXPR is the expression for the initial value.
3545 The other parameters describe the variable of the component being
3546 initialized. EXPR may be null. */
3549 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3550 bool array, bool pointer)
3554 if (!(expr || pointer))
3557 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3558 (these are the only two iso_c_binding derived types that can be
3559 used as initialization expressions). If so, we need to modify
3560 the 'expr' to be that for a (void *). */
3561 if (expr != NULL && expr->ts.type == BT_DERIVED
3562 && expr->ts.is_iso_c && expr->ts.u.derived)
3564 gfc_symbol *derived = expr->ts.u.derived;
3566 expr = gfc_int_expr (0);
3568 /* The derived symbol has already been converted to a (void *). Use
3570 expr->ts.f90_type = derived->ts.f90_type;
3571 expr->ts.kind = derived->ts.kind;
3576 /* Arrays need special handling. */
3578 return gfc_build_null_descriptor (type);
3580 return gfc_conv_array_initializer (type, expr);
3583 return fold_convert (type, null_pointer_node);
3589 gfc_init_se (&se, NULL);
3590 gfc_conv_structure (&se, expr, 1);
3594 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3597 gfc_init_se (&se, NULL);
3598 gfc_conv_constant (&se, expr);
3605 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3617 gfc_start_block (&block);
3619 /* Initialize the scalarizer. */
3620 gfc_init_loopinfo (&loop);
3622 gfc_init_se (&lse, NULL);
3623 gfc_init_se (&rse, NULL);
3626 rss = gfc_walk_expr (expr);
3627 if (rss == gfc_ss_terminator)
3629 /* The rhs is scalar. Add a ss for the expression. */
3630 rss = gfc_get_ss ();
3631 rss->next = gfc_ss_terminator;
3632 rss->type = GFC_SS_SCALAR;
3636 /* Create a SS for the destination. */
3637 lss = gfc_get_ss ();
3638 lss->type = GFC_SS_COMPONENT;
3640 lss->shape = gfc_get_shape (cm->as->rank);
3641 lss->next = gfc_ss_terminator;
3642 lss->data.info.dimen = cm->as->rank;
3643 lss->data.info.descriptor = dest;
3644 lss->data.info.data = gfc_conv_array_data (dest);
3645 lss->data.info.offset = gfc_conv_array_offset (dest);
3646 for (n = 0; n < cm->as->rank; n++)
3648 lss->data.info.dim[n] = n;
3649 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3650 lss->data.info.stride[n] = gfc_index_one_node;
3652 mpz_init (lss->shape[n]);
3653 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3654 cm->as->lower[n]->value.integer);
3655 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3658 /* Associate the SS with the loop. */
3659 gfc_add_ss_to_loop (&loop, lss);
3660 gfc_add_ss_to_loop (&loop, rss);
3662 /* Calculate the bounds of the scalarization. */
3663 gfc_conv_ss_startstride (&loop);
3665 /* Setup the scalarizing loops. */
3666 gfc_conv_loop_setup (&loop, &expr->where);
3668 /* Setup the gfc_se structures. */
3669 gfc_copy_loopinfo_to_se (&lse, &loop);
3670 gfc_copy_loopinfo_to_se (&rse, &loop);
3673 gfc_mark_ss_chain_used (rss, 1);
3675 gfc_mark_ss_chain_used (lss, 1);
3677 /* Start the scalarized loop body. */
3678 gfc_start_scalarized_body (&loop, &body);
3680 gfc_conv_tmp_array_ref (&lse);
3681 if (cm->ts.type == BT_CHARACTER)
3682 lse.string_length = cm->ts.u.cl->backend_decl;
3684 gfc_conv_expr (&rse, expr);
3686 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3687 gfc_add_expr_to_block (&body, tmp);
3689 gcc_assert (rse.ss == gfc_ss_terminator);
3691 /* Generate the copying loops. */
3692 gfc_trans_scalarizing_loops (&loop, &body);
3694 /* Wrap the whole thing up. */
3695 gfc_add_block_to_block (&block, &loop.pre);
3696 gfc_add_block_to_block (&block, &loop.post);
3698 for (n = 0; n < cm->as->rank; n++)
3699 mpz_clear (lss->shape[n]);
3700 gfc_free (lss->shape);
3702 gfc_cleanup_loop (&loop);
3704 return gfc_finish_block (&block);
3708 /* Assign a single component of a derived type constructor. */
3711 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3721 gfc_start_block (&block);
3723 if (cm->attr.pointer)
3725 gfc_init_se (&se, NULL);
3726 /* Pointer component. */
3727 if (cm->attr.dimension)
3729 /* Array pointer. */
3730 if (expr->expr_type == EXPR_NULL)
3731 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3734 rss = gfc_walk_expr (expr);
3735 se.direct_byref = 1;
3737 gfc_conv_expr_descriptor (&se, expr, rss);
3738 gfc_add_block_to_block (&block, &se.pre);
3739 gfc_add_block_to_block (&block, &se.post);
3744 /* Scalar pointers. */
3745 se.want_pointer = 1;
3746 gfc_conv_expr (&se, expr);
3747 gfc_add_block_to_block (&block, &se.pre);
3748 gfc_add_modify (&block, dest,
3749 fold_convert (TREE_TYPE (dest), se.expr));
3750 gfc_add_block_to_block (&block, &se.post);
3753 else if (cm->attr.dimension)
3755 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3756 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3757 else if (cm->attr.allocatable)
3761 gfc_init_se (&se, NULL);
3763 rss = gfc_walk_expr (expr);
3764 se.want_pointer = 0;
3765 gfc_conv_expr_descriptor (&se, expr, rss);
3766 gfc_add_block_to_block (&block, &se.pre);
3767 gfc_add_modify (&block, dest, se.expr);
3769 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
3770 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
3773 tmp = gfc_duplicate_allocatable (dest, se.expr,
3774 TREE_TYPE(cm->backend_decl),
3777 gfc_add_expr_to_block (&block, tmp);
3778 gfc_add_block_to_block (&block, &se.post);
3780 if (expr->expr_type != EXPR_VARIABLE)
3781 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3783 /* Shift the lbound and ubound of temporaries to being unity, rather
3784 than zero, based. Calculate the offset for all cases. */
3785 offset = gfc_conv_descriptor_offset_get (dest);
3786 gfc_add_modify (&block, offset, gfc_index_zero_node);
3787 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3788 for (n = 0; n < expr->rank; n++)
3790 if (expr->expr_type != EXPR_VARIABLE
3791 && expr->expr_type != EXPR_CONSTANT)
3794 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
3795 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3796 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
3797 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3798 span, gfc_index_one_node);
3799 gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
3801 gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
3802 gfc_index_one_node);
3804 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3805 gfc_conv_descriptor_lbound_get (dest,
3807 gfc_conv_descriptor_stride_get (dest,
3809 gfc_add_modify (&block, tmp2, tmp);
3810 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3811 gfc_conv_descriptor_offset_set (&block, dest, tmp);
3814 if (expr->expr_type == EXPR_FUNCTION
3815 && expr->value.function.isym
3816 && expr->value.function.isym->conversion
3817 && expr->value.function.actual->expr
3818 && expr->value.function.actual->expr->expr_type
3821 /* If a conversion expression has a null data pointer
3822 argument, nullify the allocatable component. */
3826 s = expr->value.function.actual->expr->symtree->n.sym;
3827 if (s->attr.allocatable || s->attr.pointer)
3829 non_null_expr = gfc_finish_block (&block);
3830 gfc_start_block (&block);
3831 gfc_conv_descriptor_data_set (&block, dest,
3833 null_expr = gfc_finish_block (&block);
3834 tmp = gfc_conv_descriptor_data_get (s->backend_decl);
3835 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
3836 fold_convert (TREE_TYPE (tmp),
3837 null_pointer_node));
3838 return build3_v (COND_EXPR, tmp, null_expr,
3845 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3846 gfc_add_expr_to_block (&block, tmp);
3849 else if (expr->ts.type == BT_DERIVED)
3851 if (expr->expr_type != EXPR_STRUCTURE)
3853 gfc_init_se (&se, NULL);
3854 gfc_conv_expr (&se, expr);
3855 gfc_add_block_to_block (&block, &se.pre);
3856 gfc_add_modify (&block, dest,
3857 fold_convert (TREE_TYPE (dest), se.expr));
3858 gfc_add_block_to_block (&block, &se.post);
3862 /* Nested constructors. */
3863 tmp = gfc_trans_structure_assign (dest, expr);
3864 gfc_add_expr_to_block (&block, tmp);
3869 /* Scalar component. */
3870 gfc_init_se (&se, NULL);
3871 gfc_init_se (&lse, NULL);
3873 gfc_conv_expr (&se, expr);
3874 if (cm->ts.type == BT_CHARACTER)
3875 lse.string_length = cm->ts.u.cl->backend_decl;
3877 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3878 gfc_add_expr_to_block (&block, tmp);
3880 return gfc_finish_block (&block);
3883 /* Assign a derived type constructor to a variable. */
3886 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3894 gfc_start_block (&block);
3895 cm = expr->ts.u.derived->components;
3896 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3898 /* Skip absent members in default initializers. */
3902 field = cm->backend_decl;
3903 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3904 dest, field, NULL_TREE);
3905 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3906 gfc_add_expr_to_block (&block, tmp);
3908 return gfc_finish_block (&block);
3911 /* Build an expression for a constructor. If init is nonzero then
3912 this is part of a static variable initializer. */
3915 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3922 VEC(constructor_elt,gc) *v = NULL;
3924 gcc_assert (se->ss == NULL);
3925 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3926 type = gfc_typenode_for_spec (&expr->ts);
3930 /* Create a temporary variable and fill it in. */
3931 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
3932 tmp = gfc_trans_structure_assign (se->expr, expr);
3933 gfc_add_expr_to_block (&se->pre, tmp);
3937 cm = expr->ts.u.derived->components;
3939 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3941 /* Skip absent members in default initializers and allocatable
3942 components. Although the latter have a default initializer
3943 of EXPR_NULL,... by default, the static nullify is not needed
3944 since this is done every time we come into scope. */
3945 if (!c->expr || cm->attr.allocatable)
3948 val = gfc_conv_initializer (c->expr, &cm->ts,
3949 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
3950 cm->attr.pointer || cm->attr.proc_pointer);
3952 /* Append it to the constructor list. */
3953 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3955 se->expr = build_constructor (type, v);
3957 TREE_CONSTANT (se->expr) = 1;
3961 /* Translate a substring expression. */
3964 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3970 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3972 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3973 expr->value.character.length,
3974 expr->value.character.string);
3976 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3977 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3980 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3984 /* Entry point for expression translation. Evaluates a scalar quantity.
3985 EXPR is the expression to be translated, and SE is the state structure if
3986 called from within the scalarized. */
3989 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3991 if (se->ss && se->ss->expr == expr
3992 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3994 /* Substitute a scalar expression evaluated outside the scalarization
3996 se->expr = se->ss->data.scalar.expr;
3997 se->string_length = se->ss->string_length;
3998 gfc_advance_se_ss_chain (se);
4002 /* We need to convert the expressions for the iso_c_binding derived types.
4003 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4004 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4005 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4006 updated to be an integer with a kind equal to the size of a (void *). */
4007 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4008 && expr->ts.u.derived->attr.is_iso_c)
4010 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4011 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4013 /* Set expr_type to EXPR_NULL, which will result in
4014 null_pointer_node being used below. */
4015 expr->expr_type = EXPR_NULL;
4019 /* Update the type/kind of the expression to be what the new
4020 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4021 expr->ts.type = expr->ts.u.derived->ts.type;
4022 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4023 expr->ts.kind = expr->ts.u.derived->ts.kind;
4027 switch (expr->expr_type)
4030 gfc_conv_expr_op (se, expr);
4034 gfc_conv_function_expr (se, expr);
4038 gfc_conv_constant (se, expr);
4042 gfc_conv_variable (se, expr);
4046 se->expr = null_pointer_node;
4049 case EXPR_SUBSTRING:
4050 gfc_conv_substring_expr (se, expr);
4053 case EXPR_STRUCTURE:
4054 gfc_conv_structure (se, expr, 0);
4058 gfc_conv_array_constructor_expr (se, expr);
4067 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4068 of an assignment. */
4070 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4072 gfc_conv_expr (se, expr);
4073 /* All numeric lvalues should have empty post chains. If not we need to
4074 figure out a way of rewriting an lvalue so that it has no post chain. */
4075 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4078 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4079 numeric expressions. Used for scalar values where inserting cleanup code
4082 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4086 gcc_assert (expr->ts.type != BT_CHARACTER);
4087 gfc_conv_expr (se, expr);
4090 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4091 gfc_add_modify (&se->pre, val, se->expr);
4093 gfc_add_block_to_block (&se->pre, &se->post);
4097 /* Helper to translate an expression and convert it to a particular type. */
4099 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4101 gfc_conv_expr_val (se, expr);
4102 se->expr = convert (type, se->expr);
4106 /* Converts an expression so that it can be passed by reference. Scalar
4110 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4114 if (se->ss && se->ss->expr == expr
4115 && se->ss->type == GFC_SS_REFERENCE)
4117 se->expr = se->ss->data.scalar.expr;
4118 se->string_length = se->ss->string_length;
4119 gfc_advance_se_ss_chain (se);
4123 if (expr->ts.type == BT_CHARACTER)
4125 gfc_conv_expr (se, expr);
4126 gfc_conv_string_parameter (se);
4130 if (expr->expr_type == EXPR_VARIABLE)
4132 se->want_pointer = 1;
4133 gfc_conv_expr (se, expr);
4136 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4137 gfc_add_modify (&se->pre, var, se->expr);
4138 gfc_add_block_to_block (&se->pre, &se->post);
4144 if (expr->expr_type == EXPR_FUNCTION
4145 && expr->symtree->n.sym->attr.pointer
4146 && !expr->symtree->n.sym->attr.dimension)
4148 se->want_pointer = 1;
4149 gfc_conv_expr (se, expr);
4150 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4151 gfc_add_modify (&se->pre, var, se->expr);
4157 gfc_conv_expr (se, expr);
4159 /* Create a temporary var to hold the value. */
4160 if (TREE_CONSTANT (se->expr))
4162 tree tmp = se->expr;
4163 STRIP_TYPE_NOPS (tmp);
4164 var = build_decl (input_location,
4165 CONST_DECL, NULL, TREE_TYPE (tmp));
4166 DECL_INITIAL (var) = tmp;
4167 TREE_STATIC (var) = 1;
4172 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4173 gfc_add_modify (&se->pre, var, se->expr);
4175 gfc_add_block_to_block (&se->pre, &se->post);
4177 /* Take the address of that value. */
4178 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4183 gfc_trans_pointer_assign (gfc_code * code)
4185 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4189 /* Generate code for a pointer assignment. */
4192 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4203 gfc_start_block (&block);
4205 gfc_init_se (&lse, NULL);
4207 lss = gfc_walk_expr (expr1);
4208 rss = gfc_walk_expr (expr2);
4209 if (lss == gfc_ss_terminator)
4211 /* Scalar pointers. */
4212 lse.want_pointer = 1;
4213 gfc_conv_expr (&lse, expr1);
4214 gcc_assert (rss == gfc_ss_terminator);
4215 gfc_init_se (&rse, NULL);
4216 rse.want_pointer = 1;
4217 gfc_conv_expr (&rse, expr2);
4219 if (expr1->symtree->n.sym->attr.proc_pointer
4220 && expr1->symtree->n.sym->attr.dummy)
4221 lse.expr = build_fold_indirect_ref_loc (input_location,
4224 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4225 && expr2->symtree->n.sym->attr.dummy)
4226 rse.expr = build_fold_indirect_ref_loc (input_location,
4229 gfc_add_block_to_block (&block, &lse.pre);
4230 gfc_add_block_to_block (&block, &rse.pre);
4232 /* Check character lengths if character expression. The test is only
4233 really added if -fbounds-check is enabled. */
4234 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4236 gcc_assert (expr2->ts.type == BT_CHARACTER);
4237 gcc_assert (lse.string_length && rse.string_length);
4238 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4239 lse.string_length, rse.string_length,
4243 gfc_add_modify (&block, lse.expr,
4244 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4246 gfc_add_block_to_block (&block, &rse.post);
4247 gfc_add_block_to_block (&block, &lse.post);
4252 tree strlen_rhs = NULL_TREE;
4254 /* Array pointer. */
4255 gfc_conv_expr_descriptor (&lse, expr1, lss);
4256 strlen_lhs = lse.string_length;
4257 switch (expr2->expr_type)
4260 /* Just set the data pointer to null. */
4261 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4265 /* Assign directly to the pointer's descriptor. */
4266 lse.direct_byref = 1;
4267 gfc_conv_expr_descriptor (&lse, expr2, rss);
4268 strlen_rhs = lse.string_length;
4270 /* If this is a subreference array pointer assignment, use the rhs
4271 descriptor element size for the lhs span. */
4272 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4274 decl = expr1->symtree->n.sym->backend_decl;
4275 gfc_init_se (&rse, NULL);
4276 rse.descriptor_only = 1;
4277 gfc_conv_expr (&rse, expr2);
4278 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4279 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4280 if (!INTEGER_CST_P (tmp))
4281 gfc_add_block_to_block (&lse.post, &rse.pre);
4282 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4288 /* Assign to a temporary descriptor and then copy that
4289 temporary to the pointer. */
4291 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4294 lse.direct_byref = 1;
4295 gfc_conv_expr_descriptor (&lse, expr2, rss);
4296 strlen_rhs = lse.string_length;
4297 gfc_add_modify (&lse.pre, desc, tmp);
4301 gfc_add_block_to_block (&block, &lse.pre);
4303 /* Check string lengths if applicable. The check is only really added
4304 to the output code if -fbounds-check is enabled. */
4305 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4307 gcc_assert (expr2->ts.type == BT_CHARACTER);
4308 gcc_assert (strlen_lhs && strlen_rhs);
4309 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4310 strlen_lhs, strlen_rhs, &block);
4313 gfc_add_block_to_block (&block, &lse.post);
4315 return gfc_finish_block (&block);
4319 /* Makes sure se is suitable for passing as a function string parameter. */
4320 /* TODO: Need to check all callers of this function. It may be abused. */
4323 gfc_conv_string_parameter (gfc_se * se)
4327 if (TREE_CODE (se->expr) == STRING_CST)
4329 type = TREE_TYPE (TREE_TYPE (se->expr));
4330 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4334 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4336 if (TREE_CODE (se->expr) != INDIRECT_REF)
4338 type = TREE_TYPE (se->expr);
4339 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4343 type = gfc_get_character_type_len (gfc_default_character_kind,
4345 type = build_pointer_type (type);
4346 se->expr = gfc_build_addr_expr (type, se->expr);
4350 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4351 gcc_assert (se->string_length
4352 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4356 /* Generate code for assignment of scalar variables. Includes character
4357 strings and derived types with allocatable components. */
4360 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4361 bool l_is_temp, bool r_is_var)
4367 gfc_init_block (&block);
4369 if (ts.type == BT_CHARACTER)
4374 if (lse->string_length != NULL_TREE)
4376 gfc_conv_string_parameter (lse);
4377 gfc_add_block_to_block (&block, &lse->pre);
4378 llen = lse->string_length;
4381 if (rse->string_length != NULL_TREE)
4383 gcc_assert (rse->string_length != NULL_TREE);
4384 gfc_conv_string_parameter (rse);
4385 gfc_add_block_to_block (&block, &rse->pre);
4386 rlen = rse->string_length;
4389 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4390 rse->expr, ts.kind);
4392 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4396 /* Are the rhs and the lhs the same? */
4399 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4400 gfc_build_addr_expr (NULL_TREE, lse->expr),
4401 gfc_build_addr_expr (NULL_TREE, rse->expr));
4402 cond = gfc_evaluate_now (cond, &lse->pre);
4405 /* Deallocate the lhs allocated components as long as it is not
4406 the same as the rhs. This must be done following the assignment
4407 to prevent deallocating data that could be used in the rhs
4411 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4412 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4414 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4416 gfc_add_expr_to_block (&lse->post, tmp);
4419 gfc_add_block_to_block (&block, &rse->pre);
4420 gfc_add_block_to_block (&block, &lse->pre);
4422 gfc_add_modify (&block, lse->expr,
4423 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4425 /* Do a deep copy if the rhs is a variable, if it is not the
4429 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4430 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4432 gfc_add_expr_to_block (&block, tmp);
4435 else if (ts.type == BT_DERIVED)
4437 gfc_add_block_to_block (&block, &lse->pre);
4438 gfc_add_block_to_block (&block, &rse->pre);
4439 tmp = gfc_evaluate_now (rse->expr, &block);
4440 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4441 gfc_add_modify (&block, lse->expr, tmp);
4445 gfc_add_block_to_block (&block, &lse->pre);
4446 gfc_add_block_to_block (&block, &rse->pre);
4448 gfc_add_modify (&block, lse->expr,
4449 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4452 gfc_add_block_to_block (&block, &lse->post);
4453 gfc_add_block_to_block (&block, &rse->post);
4455 return gfc_finish_block (&block);
4459 /* Try to translate array(:) = func (...), where func is a transformational
4460 array function, without using a temporary. Returns NULL is this isn't the
4464 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4469 bool seen_array_ref;
4471 gfc_component *comp = NULL;
4473 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4474 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4477 /* Elemental functions don't need a temporary anyway. */
4478 if (expr2->value.function.esym != NULL
4479 && expr2->value.function.esym->attr.elemental)
4482 /* Fail if rhs is not FULL or a contiguous section. */
4483 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4486 /* Fail if EXPR1 can't be expressed as a descriptor. */
4487 if (gfc_ref_needs_temporary_p (expr1->ref))
4490 /* Functions returning pointers need temporaries. */
4491 if (expr2->symtree->n.sym->attr.pointer
4492 || expr2->symtree->n.sym->attr.allocatable)
4495 /* Character array functions need temporaries unless the
4496 character lengths are the same. */
4497 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4499 if (expr1->ts.u.cl->length == NULL
4500 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4503 if (expr2->ts.u.cl->length == NULL
4504 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4507 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
4508 expr2->ts.u.cl->length->value.integer) != 0)
4512 /* Check that no LHS component references appear during an array
4513 reference. This is needed because we do not have the means to
4514 span any arbitrary stride with an array descriptor. This check
4515 is not needed for the rhs because the function result has to be
4517 seen_array_ref = false;
4518 for (ref = expr1->ref; ref; ref = ref->next)
4520 if (ref->type == REF_ARRAY)
4521 seen_array_ref= true;
4522 else if (ref->type == REF_COMPONENT && seen_array_ref)
4526 /* Check for a dependency. */
4527 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4528 expr2->value.function.esym,
4529 expr2->value.function.actual,
4533 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4535 gcc_assert (expr2->value.function.isym
4536 || (gfc_is_proc_ptr_comp (expr2, &comp)
4537 && comp && comp->attr.dimension)
4538 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
4539 && expr2->value.function.esym->result->attr.dimension));
4541 ss = gfc_walk_expr (expr1);
4542 gcc_assert (ss != gfc_ss_terminator);
4543 gfc_init_se (&se, NULL);
4544 gfc_start_block (&se.pre);
4545 se.want_pointer = 1;
4547 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
4549 se.direct_byref = 1;
4550 se.ss = gfc_walk_expr (expr2);
4551 gcc_assert (se.ss != gfc_ss_terminator);
4552 gfc_conv_function_expr (&se, expr2);
4553 gfc_add_block_to_block (&se.pre, &se.post);
4555 return gfc_finish_block (&se.pre);
4558 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4561 is_zero_initializer_p (gfc_expr * expr)
4563 if (expr->expr_type != EXPR_CONSTANT)
4566 /* We ignore constants with prescribed memory representations for now. */
4567 if (expr->representation.string)
4570 switch (expr->ts.type)
4573 return mpz_cmp_si (expr->value.integer, 0) == 0;
4576 return mpfr_zero_p (expr->value.real)
4577 && MPFR_SIGN (expr->value.real) >= 0;
4580 return expr->value.logical == 0;
4583 return mpfr_zero_p (mpc_realref (expr->value.complex))
4584 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4585 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4586 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4594 /* Try to efficiently translate array(:) = 0. Return NULL if this
4598 gfc_trans_zero_assign (gfc_expr * expr)
4600 tree dest, len, type;
4604 sym = expr->symtree->n.sym;
4605 dest = gfc_get_symbol_decl (sym);
4607 type = TREE_TYPE (dest);
4608 if (POINTER_TYPE_P (type))
4609 type = TREE_TYPE (type);
4610 if (!GFC_ARRAY_TYPE_P (type))
4613 /* Determine the length of the array. */
4614 len = GFC_TYPE_ARRAY_SIZE (type);
4615 if (!len || TREE_CODE (len) != INTEGER_CST)
4618 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4619 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4620 fold_convert (gfc_array_index_type, tmp));
4622 /* If we are zeroing a local array avoid taking its address by emitting
4624 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4625 return build2 (MODIFY_EXPR, void_type_node,
4626 dest, build_constructor (TREE_TYPE (dest), NULL));
4628 /* Convert arguments to the correct types. */
4629 dest = fold_convert (pvoid_type_node, dest);
4630 len = fold_convert (size_type_node, len);
4632 /* Construct call to __builtin_memset. */
4633 tmp = build_call_expr_loc (input_location,
4634 built_in_decls[BUILT_IN_MEMSET],
4635 3, dest, integer_zero_node, len);
4636 return fold_convert (void_type_node, tmp);
4640 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4641 that constructs the call to __builtin_memcpy. */
4644 gfc_build_memcpy_call (tree dst, tree src, tree len)
4648 /* Convert arguments to the correct types. */
4649 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4650 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4652 dst = fold_convert (pvoid_type_node, dst);
4654 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4655 src = gfc_build_addr_expr (pvoid_type_node, src);
4657 src = fold_convert (pvoid_type_node, src);
4659 len = fold_convert (size_type_node, len);
4661 /* Construct call to __builtin_memcpy. */
4662 tmp = build_call_expr_loc (input_location,
4663 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4664 return fold_convert (void_type_node, tmp);
4668 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4669 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4670 source/rhs, both are gfc_full_array_ref_p which have been checked for
4674 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4676 tree dst, dlen, dtype;
4677 tree src, slen, stype;
4680 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4681 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4683 dtype = TREE_TYPE (dst);
4684 if (POINTER_TYPE_P (dtype))
4685 dtype = TREE_TYPE (dtype);
4686 stype = TREE_TYPE (src);
4687 if (POINTER_TYPE_P (stype))
4688 stype = TREE_TYPE (stype);
4690 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4693 /* Determine the lengths of the arrays. */
4694 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4695 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4697 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4698 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4699 fold_convert (gfc_array_index_type, tmp));
4701 slen = GFC_TYPE_ARRAY_SIZE (stype);
4702 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4704 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4705 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4706 fold_convert (gfc_array_index_type, tmp));
4708 /* Sanity check that they are the same. This should always be
4709 the case, as we should already have checked for conformance. */
4710 if (!tree_int_cst_equal (slen, dlen))
4713 return gfc_build_memcpy_call (dst, src, dlen);
4717 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4718 this can't be done. EXPR1 is the destination/lhs for which
4719 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4722 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4724 unsigned HOST_WIDE_INT nelem;
4730 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4734 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4735 dtype = TREE_TYPE (dst);
4736 if (POINTER_TYPE_P (dtype))
4737 dtype = TREE_TYPE (dtype);
4738 if (!GFC_ARRAY_TYPE_P (dtype))
4741 /* Determine the lengths of the array. */
4742 len = GFC_TYPE_ARRAY_SIZE (dtype);
4743 if (!len || TREE_CODE (len) != INTEGER_CST)
4746 /* Confirm that the constructor is the same size. */
4747 if (compare_tree_int (len, nelem) != 0)
4750 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4751 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4752 fold_convert (gfc_array_index_type, tmp));
4754 stype = gfc_typenode_for_spec (&expr2->ts);
4755 src = gfc_build_constant_array_constructor (expr2, stype);
4757 stype = TREE_TYPE (src);
4758 if (POINTER_TYPE_P (stype))
4759 stype = TREE_TYPE (stype);
4761 return gfc_build_memcpy_call (dst, src, len);
4765 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4766 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4769 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4774 gfc_ss *lss_section;
4781 bool scalar_to_array;
4784 /* Assignment of the form lhs = rhs. */
4785 gfc_start_block (&block);
4787 gfc_init_se (&lse, NULL);
4788 gfc_init_se (&rse, NULL);
4791 lss = gfc_walk_expr (expr1);
4793 if (lss != gfc_ss_terminator)
4795 /* Allow the scalarizer to workshare array assignments. */
4796 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4797 ompws_flags |= OMPWS_SCALARIZER_WS;
4799 /* The assignment needs scalarization. */
4802 /* Find a non-scalar SS from the lhs. */
4803 while (lss_section != gfc_ss_terminator
4804 && lss_section->type != GFC_SS_SECTION)
4805 lss_section = lss_section->next;
4807 gcc_assert (lss_section != gfc_ss_terminator);
4809 /* Initialize the scalarizer. */
4810 gfc_init_loopinfo (&loop);
4813 rss = gfc_walk_expr (expr2);
4814 if (rss == gfc_ss_terminator)
4816 /* The rhs is scalar. Add a ss for the expression. */
4817 rss = gfc_get_ss ();
4818 rss->next = gfc_ss_terminator;
4819 rss->type = GFC_SS_SCALAR;
4822 /* Associate the SS with the loop. */
4823 gfc_add_ss_to_loop (&loop, lss);
4824 gfc_add_ss_to_loop (&loop, rss);
4826 /* Calculate the bounds of the scalarization. */
4827 gfc_conv_ss_startstride (&loop);
4828 /* Resolve any data dependencies in the statement. */
4829 gfc_conv_resolve_dependencies (&loop, lss, rss);
4830 /* Setup the scalarizing loops. */
4831 gfc_conv_loop_setup (&loop, &expr2->where);
4833 /* Setup the gfc_se structures. */
4834 gfc_copy_loopinfo_to_se (&lse, &loop);
4835 gfc_copy_loopinfo_to_se (&rse, &loop);
4838 gfc_mark_ss_chain_used (rss, 1);
4839 if (loop.temp_ss == NULL)
4842 gfc_mark_ss_chain_used (lss, 1);
4846 lse.ss = loop.temp_ss;
4847 gfc_mark_ss_chain_used (lss, 3);
4848 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4851 /* Start the scalarized loop body. */
4852 gfc_start_scalarized_body (&loop, &body);
4855 gfc_init_block (&body);
4857 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4859 /* Translate the expression. */
4860 gfc_conv_expr (&rse, expr2);
4862 /* Stabilize a string length for temporaries. */
4863 if (expr2->ts.type == BT_CHARACTER)
4864 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
4866 string_length = NULL_TREE;
4870 gfc_conv_tmp_array_ref (&lse);
4871 gfc_advance_se_ss_chain (&lse);
4872 if (expr2->ts.type == BT_CHARACTER)
4873 lse.string_length = string_length;
4876 gfc_conv_expr (&lse, expr1);
4878 /* Assignments of scalar derived types with allocatable components
4879 to arrays must be done with a deep copy and the rhs temporary
4880 must have its components deallocated afterwards. */
4881 scalar_to_array = (expr2->ts.type == BT_DERIVED
4882 && expr2->ts.u.derived->attr.alloc_comp
4883 && expr2->expr_type != EXPR_VARIABLE
4884 && !gfc_is_constant_expr (expr2)
4885 && expr1->rank && !expr2->rank);
4886 if (scalar_to_array)
4888 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
4889 gfc_add_expr_to_block (&loop.post, tmp);
4892 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4893 l_is_temp || init_flag,
4894 (expr2->expr_type == EXPR_VARIABLE)
4895 || scalar_to_array);
4896 gfc_add_expr_to_block (&body, tmp);
4898 if (lss == gfc_ss_terminator)
4900 /* Use the scalar assignment as is. */
4901 gfc_add_block_to_block (&block, &body);
4905 gcc_assert (lse.ss == gfc_ss_terminator
4906 && rse.ss == gfc_ss_terminator);
4910 gfc_trans_scalarized_loop_boundary (&loop, &body);
4912 /* We need to copy the temporary to the actual lhs. */
4913 gfc_init_se (&lse, NULL);
4914 gfc_init_se (&rse, NULL);
4915 gfc_copy_loopinfo_to_se (&lse, &loop);
4916 gfc_copy_loopinfo_to_se (&rse, &loop);
4918 rse.ss = loop.temp_ss;
4921 gfc_conv_tmp_array_ref (&rse);
4922 gfc_advance_se_ss_chain (&rse);
4923 gfc_conv_expr (&lse, expr1);
4925 gcc_assert (lse.ss == gfc_ss_terminator
4926 && rse.ss == gfc_ss_terminator);
4928 if (expr2->ts.type == BT_CHARACTER)
4929 rse.string_length = string_length;
4931 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4933 gfc_add_expr_to_block (&body, tmp);
4936 /* Generate the copying loops. */
4937 gfc_trans_scalarizing_loops (&loop, &body);
4939 /* Wrap the whole thing up. */
4940 gfc_add_block_to_block (&block, &loop.pre);
4941 gfc_add_block_to_block (&block, &loop.post);
4943 gfc_cleanup_loop (&loop);
4946 return gfc_finish_block (&block);
4950 /* Check whether EXPR is a copyable array. */
4953 copyable_array_p (gfc_expr * expr)
4955 if (expr->expr_type != EXPR_VARIABLE)
4958 /* First check it's an array. */
4959 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4962 if (!gfc_full_array_ref_p (expr->ref, NULL))
4965 /* Next check that it's of a simple enough type. */
4966 switch (expr->ts.type)
4978 return !expr->ts.u.derived->attr.alloc_comp;
4987 /* Translate an assignment. */
4990 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4994 /* Special case a single function returning an array. */
4995 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4997 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5002 /* Special case assigning an array to zero. */
5003 if (copyable_array_p (expr1)
5004 && is_zero_initializer_p (expr2))
5006 tmp = gfc_trans_zero_assign (expr1);
5011 /* Special case copying one array to another. */
5012 if (copyable_array_p (expr1)
5013 && copyable_array_p (expr2)
5014 && gfc_compare_types (&expr1->ts, &expr2->ts)
5015 && !gfc_check_dependency (expr1, expr2, 0))
5017 tmp = gfc_trans_array_copy (expr1, expr2);
5022 /* Special case initializing an array from a constant array constructor. */
5023 if (copyable_array_p (expr1)
5024 && expr2->expr_type == EXPR_ARRAY
5025 && gfc_compare_types (&expr1->ts, &expr2->ts))
5027 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5032 /* Fallback to the scalarizer to generate explicit loops. */
5033 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
5037 gfc_trans_init_assign (gfc_code * code)
5039 return gfc_trans_assignment (code->expr1, code->expr2, true);
5043 gfc_trans_assign (gfc_code * code)
5045 return gfc_trans_assignment (code->expr1, code->expr2, false);