1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se * se, gfc_se * parent)
66 memset (se, 0, sizeof (gfc_se));
67 gfc_init_block (&se->pre);
68 gfc_init_block (&se->post);
73 gfc_copy_se_loopvars (se, parent);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se * se)
110 if (CONSTANT_CLASS_P (se->expr))
113 /* We need a temporary for this result. */
114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115 gfc_add_modify (&se->pre, var, se->expr);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol * sym)
128 gcc_assert (sym->attr.dummy);
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
140 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
141 fold_convert (TREE_TYPE (decl), null_pointer_node));
143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
144 as actual argument to denote absent dummies. For array descriptors,
145 we thus also need to check the array descriptor. */
146 if (!sym->attr.pointer && !sym->attr.allocatable
147 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
148 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
151 tmp = build_fold_indirect_ref_loc (input_location, decl);
152 tmp = gfc_conv_array_data (tmp);
153 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
154 fold_convert (TREE_TYPE (tmp), null_pointer_node));
155 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
156 boolean_type_node, cond, tmp);
163 /* Converts a missing, dummy argument into a null or zero. */
166 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
171 present = gfc_conv_expr_present (arg->symtree->n.sym);
175 /* Create a temporary and convert it to the correct type. */
176 tmp = gfc_get_int_type (kind);
177 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
180 /* Test for a NULL value. */
181 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
182 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
183 tmp = gfc_evaluate_now (tmp, &se->pre);
184 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
188 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
190 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
191 tmp = gfc_evaluate_now (tmp, &se->pre);
195 if (ts.type == BT_CHARACTER)
197 tmp = build_int_cst (gfc_charlen_type_node, 0);
198 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
199 present, se->string_length, tmp);
200 tmp = gfc_evaluate_now (tmp, &se->pre);
201 se->string_length = tmp;
207 /* Get the character length of an expression, looking through gfc_refs
211 gfc_get_expr_charlen (gfc_expr *e)
216 gcc_assert (e->expr_type == EXPR_VARIABLE
217 && e->ts.type == BT_CHARACTER);
219 length = NULL; /* To silence compiler warning. */
221 if (is_subref_array (e) && e->ts.u.cl->length)
224 gfc_init_se (&tmpse, NULL);
225 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
226 e->ts.u.cl->backend_decl = tmpse.expr;
230 /* First candidate: if the variable is of type CHARACTER, the
231 expression's length could be the length of the character
233 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
234 length = e->symtree->n.sym->ts.u.cl->backend_decl;
236 /* Look through the reference chain for component references. */
237 for (r = e->ref; r; r = r->next)
242 if (r->u.c.component->ts.type == BT_CHARACTER)
243 length = r->u.c.component->ts.u.cl->backend_decl;
251 /* We should never got substring references here. These will be
252 broken down by the scalarizer. */
258 gcc_assert (length != NULL);
263 /* For each character array constructor subexpression without a ts.u.cl->length,
264 replace it by its first element (if there aren't any elements, the length
265 should already be set to zero). */
268 flatten_array_ctors_without_strlen (gfc_expr* e)
270 gfc_actual_arglist* arg;
276 switch (e->expr_type)
280 flatten_array_ctors_without_strlen (e->value.op.op1);
281 flatten_array_ctors_without_strlen (e->value.op.op2);
285 /* TODO: Implement as with EXPR_FUNCTION when needed. */
289 for (arg = e->value.function.actual; arg; arg = arg->next)
290 flatten_array_ctors_without_strlen (arg->expr);
295 /* We've found what we're looking for. */
296 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
301 gcc_assert (e->value.constructor);
303 c = gfc_constructor_first (e->value.constructor);
307 flatten_array_ctors_without_strlen (new_expr);
308 gfc_replace_expr (e, new_expr);
312 /* Otherwise, fall through to handle constructor elements. */
314 for (c = gfc_constructor_first (e->value.constructor);
315 c; c = gfc_constructor_next (c))
316 flatten_array_ctors_without_strlen (c->expr);
326 /* Generate code to initialize a string length variable. Returns the
327 value. For array constructors, cl->length might be NULL and in this case,
328 the first element of the constructor is needed. expr is the original
329 expression so we can access it but can be NULL if this is not needed. */
332 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
336 gfc_init_se (&se, NULL);
338 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
339 "flatten" array constructors by taking their first element; all elements
340 should be the same length or a cl->length should be present. */
346 expr_flat = gfc_copy_expr (expr);
347 flatten_array_ctors_without_strlen (expr_flat);
348 gfc_resolve_expr (expr_flat);
350 gfc_conv_expr (&se, expr_flat);
351 gfc_add_block_to_block (pblock, &se.pre);
352 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
354 gfc_free_expr (expr_flat);
358 /* Convert cl->length. */
360 gcc_assert (cl->length);
362 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
363 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
364 se.expr, build_int_cst (gfc_charlen_type_node, 0));
365 gfc_add_block_to_block (pblock, &se.pre);
367 if (cl->backend_decl)
368 gfc_add_modify (pblock, cl->backend_decl, se.expr);
370 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
375 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
376 const char *name, locus *where)
385 type = gfc_get_character_type (kind, ref->u.ss.length);
386 type = build_pointer_type (type);
388 gfc_init_se (&start, se);
389 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
390 gfc_add_block_to_block (&se->pre, &start.pre);
392 if (integer_onep (start.expr))
393 gfc_conv_string_parameter (se);
398 /* Avoid multiple evaluation of substring start. */
399 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
400 start.expr = gfc_evaluate_now (start.expr, &se->pre);
402 /* Change the start of the string. */
403 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
406 tmp = build_fold_indirect_ref_loc (input_location,
408 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
409 se->expr = gfc_build_addr_expr (type, tmp);
412 /* Length = end + 1 - start. */
413 gfc_init_se (&end, se);
414 if (ref->u.ss.end == NULL)
415 end.expr = se->string_length;
418 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
419 gfc_add_block_to_block (&se->pre, &end.pre);
423 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
424 end.expr = gfc_evaluate_now (end.expr, &se->pre);
426 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
428 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
429 boolean_type_node, start.expr,
432 /* Check lower bound. */
433 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
435 build_int_cst (gfc_charlen_type_node, 1));
436 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
437 boolean_type_node, nonempty, fault);
439 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
440 "is less than one", name);
442 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
444 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
445 fold_convert (long_integer_type_node,
449 /* Check upper bound. */
450 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
451 end.expr, se->string_length);
452 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
453 boolean_type_node, nonempty, fault);
455 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
456 "exceeds string length (%%ld)", name);
458 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
459 "exceeds string length (%%ld)");
460 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
461 fold_convert (long_integer_type_node, end.expr),
462 fold_convert (long_integer_type_node,
467 /* If the start and end expressions are equal, the length is one. */
469 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
470 tmp = build_int_cst (gfc_charlen_type_node, 1);
473 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
474 end.expr, start.expr);
475 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
476 build_int_cst (gfc_charlen_type_node, 1), tmp);
477 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
478 tmp, build_int_cst (gfc_charlen_type_node, 0));
481 se->string_length = tmp;
485 /* Convert a derived type component reference. */
488 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
495 c = ref->u.c.component;
497 gcc_assert (c->backend_decl);
499 field = c->backend_decl;
500 gcc_assert (TREE_CODE (field) == FIELD_DECL);
502 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
503 decl, field, NULL_TREE);
507 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
509 tmp = c->ts.u.cl->backend_decl;
510 /* Components must always be constant length. */
511 gcc_assert (tmp && INTEGER_CST_P (tmp));
512 se->string_length = tmp;
515 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
516 && c->ts.type != BT_CHARACTER)
517 || c->attr.proc_pointer)
518 se->expr = build_fold_indirect_ref_loc (input_location,
523 /* This function deals with component references to components of the
524 parent type for derived type extensons. */
526 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
534 c = ref->u.c.component;
536 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
537 parent.type = REF_COMPONENT;
540 parent.u.c.component = dt->components;
542 if (dt->backend_decl == NULL)
543 gfc_get_derived_type (dt);
545 if (dt->attr.extension && dt->components)
547 if (dt->attr.is_class)
548 cmp = dt->components;
550 cmp = dt->components->next;
551 /* Return if the component is not in the parent type. */
552 for (; cmp; cmp = cmp->next)
553 if (strcmp (c->name, cmp->name) == 0)
556 /* Otherwise build the reference and call self. */
557 gfc_conv_component_ref (se, &parent);
558 parent.u.c.sym = dt->components->ts.u.derived;
559 parent.u.c.component = c;
560 conv_parent_component_references (se, &parent);
564 /* Return the contents of a variable. Also handles reference/pointer
565 variables (all Fortran pointer references are implicit). */
568 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
572 tree parent_decl = NULL_TREE;
575 bool alternate_entry;
578 sym = expr->symtree->n.sym;
581 /* Check that something hasn't gone horribly wrong. */
582 gcc_assert (se->ss != gfc_ss_terminator);
583 gcc_assert (se->ss->expr == expr);
585 /* A scalarized term. We already know the descriptor. */
586 se->expr = se->ss->data.info.descriptor;
587 se->string_length = se->ss->string_length;
588 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
589 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
594 tree se_expr = NULL_TREE;
596 se->expr = gfc_get_symbol_decl (sym);
598 /* Deal with references to a parent results or entries by storing
599 the current_function_decl and moving to the parent_decl. */
600 return_value = sym->attr.function && sym->result == sym;
601 alternate_entry = sym->attr.function && sym->attr.entry
602 && sym->result == sym;
603 entry_master = sym->attr.result
604 && sym->ns->proc_name->attr.entry_master
605 && !gfc_return_by_reference (sym->ns->proc_name);
606 if (current_function_decl)
607 parent_decl = DECL_CONTEXT (current_function_decl);
609 if ((se->expr == parent_decl && return_value)
610 || (sym->ns && sym->ns->proc_name
612 && sym->ns->proc_name->backend_decl == parent_decl
613 && (alternate_entry || entry_master)))
618 /* Special case for assigning the return value of a function.
619 Self recursive functions must have an explicit return value. */
620 if (return_value && (se->expr == current_function_decl || parent_flag))
621 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
623 /* Similarly for alternate entry points. */
624 else if (alternate_entry
625 && (sym->ns->proc_name->backend_decl == current_function_decl
628 gfc_entry_list *el = NULL;
630 for (el = sym->ns->entries; el; el = el->next)
633 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
638 else if (entry_master
639 && (sym->ns->proc_name->backend_decl == current_function_decl
641 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
646 /* Procedure actual arguments. */
647 else if (sym->attr.flavor == FL_PROCEDURE
648 && se->expr != current_function_decl)
650 if (!sym->attr.dummy && !sym->attr.proc_pointer)
652 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
653 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
659 /* Dereference the expression, where needed. Since characters
660 are entirely different from other types, they are treated
662 if (sym->ts.type == BT_CHARACTER)
664 /* Dereference character pointer dummy arguments
666 if ((sym->attr.pointer || sym->attr.allocatable)
668 || sym->attr.function
669 || sym->attr.result))
670 se->expr = build_fold_indirect_ref_loc (input_location,
674 else if (!sym->attr.value)
676 /* Dereference non-character scalar dummy arguments. */
677 if (sym->attr.dummy && !sym->attr.dimension)
678 se->expr = build_fold_indirect_ref_loc (input_location,
681 /* Dereference scalar hidden result. */
682 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
683 && (sym->attr.function || sym->attr.result)
684 && !sym->attr.dimension && !sym->attr.pointer
685 && !sym->attr.always_explicit)
686 se->expr = build_fold_indirect_ref_loc (input_location,
689 /* Dereference non-character pointer variables.
690 These must be dummies, results, or scalars. */
691 if ((sym->attr.pointer || sym->attr.allocatable
692 || gfc_is_associate_pointer (sym))
694 || sym->attr.function
696 || !sym->attr.dimension))
697 se->expr = build_fold_indirect_ref_loc (input_location,
704 /* For character variables, also get the length. */
705 if (sym->ts.type == BT_CHARACTER)
707 /* If the character length of an entry isn't set, get the length from
708 the master function instead. */
709 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
710 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
712 se->string_length = sym->ts.u.cl->backend_decl;
713 gcc_assert (se->string_length);
721 /* Return the descriptor if that's what we want and this is an array
722 section reference. */
723 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
725 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
726 /* Return the descriptor for array pointers and allocations. */
728 && ref->next == NULL && (se->descriptor_only))
731 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
732 /* Return a pointer to an element. */
736 if (ref->u.c.sym->attr.extension)
737 conv_parent_component_references (se, ref);
739 gfc_conv_component_ref (se, ref);
743 gfc_conv_substring (se, ref, expr->ts.kind,
744 expr->symtree->name, &expr->where);
753 /* Pointer assignment, allocation or pass by reference. Arrays are handled
755 if (se->want_pointer)
757 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
758 gfc_conv_string_parameter (se);
760 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
765 /* Unary ops are easy... Or they would be if ! was a valid op. */
768 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
773 gcc_assert (expr->ts.type != BT_CHARACTER);
774 /* Initialize the operand. */
775 gfc_init_se (&operand, se);
776 gfc_conv_expr_val (&operand, expr->value.op.op1);
777 gfc_add_block_to_block (&se->pre, &operand.pre);
779 type = gfc_typenode_for_spec (&expr->ts);
781 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
782 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
783 All other unary operators have an equivalent GIMPLE unary operator. */
784 if (code == TRUTH_NOT_EXPR)
785 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
786 build_int_cst (type, 0));
788 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
792 /* Expand power operator to optimal multiplications when a value is raised
793 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
794 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
795 Programming", 3rd Edition, 1998. */
797 /* This code is mostly duplicated from expand_powi in the backend.
798 We establish the "optimal power tree" lookup table with the defined size.
799 The items in the table are the exponents used to calculate the index
800 exponents. Any integer n less than the value can get an "addition chain",
801 with the first node being one. */
802 #define POWI_TABLE_SIZE 256
804 /* The table is from builtins.c. */
805 static const unsigned char powi_table[POWI_TABLE_SIZE] =
807 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
808 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
809 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
810 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
811 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
812 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
813 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
814 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
815 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
816 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
817 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
818 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
819 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
820 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
821 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
822 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
823 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
824 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
825 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
826 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
827 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
828 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
829 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
830 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
831 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
832 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
833 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
834 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
835 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
836 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
837 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
838 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
841 /* If n is larger than lookup table's max index, we use the "window
843 #define POWI_WINDOW_SIZE 3
845 /* Recursive function to expand the power operator. The temporary
846 values are put in tmpvar. The function returns tmpvar[1] ** n. */
848 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
855 if (n < POWI_TABLE_SIZE)
860 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
861 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
865 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
866 op0 = gfc_conv_powi (se, n - digit, tmpvar);
867 op1 = gfc_conv_powi (se, digit, tmpvar);
871 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
875 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
876 tmp = gfc_evaluate_now (tmp, &se->pre);
878 if (n < POWI_TABLE_SIZE)
885 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
886 return 1. Else return 0 and a call to runtime library functions
887 will have to be built. */
889 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
894 tree vartmp[POWI_TABLE_SIZE];
896 unsigned HOST_WIDE_INT n;
899 /* If exponent is too large, we won't expand it anyway, so don't bother
900 with large integer values. */
901 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
904 m = double_int_to_shwi (TREE_INT_CST (rhs));
905 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
906 of the asymmetric range of the integer type. */
907 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
909 type = TREE_TYPE (lhs);
910 sgn = tree_int_cst_sgn (rhs);
912 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
913 || optimize_size) && (m > 2 || m < -1))
919 se->expr = gfc_build_const (type, integer_one_node);
923 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
924 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
926 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
927 lhs, build_int_cst (TREE_TYPE (lhs), -1));
928 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
929 lhs, build_int_cst (TREE_TYPE (lhs), 1));
932 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
935 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
936 boolean_type_node, tmp, cond);
937 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
938 tmp, build_int_cst (type, 1),
939 build_int_cst (type, 0));
943 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
944 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
945 build_int_cst (type, -1),
946 build_int_cst (type, 0));
947 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
948 cond, build_int_cst (type, 1), tmp);
952 memset (vartmp, 0, sizeof (vartmp));
956 tmp = gfc_build_const (type, integer_one_node);
957 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
961 se->expr = gfc_conv_powi (se, n, vartmp);
967 /* Power op (**). Constant integer exponent has special handling. */
970 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
972 tree gfc_int4_type_node;
979 gfc_init_se (&lse, se);
980 gfc_conv_expr_val (&lse, expr->value.op.op1);
981 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
982 gfc_add_block_to_block (&se->pre, &lse.pre);
984 gfc_init_se (&rse, se);
985 gfc_conv_expr_val (&rse, expr->value.op.op2);
986 gfc_add_block_to_block (&se->pre, &rse.pre);
988 if (expr->value.op.op2->ts.type == BT_INTEGER
989 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
990 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
993 gfc_int4_type_node = gfc_get_int_type (4);
995 kind = expr->value.op.op1->ts.kind;
996 switch (expr->value.op.op2->ts.type)
999 ikind = expr->value.op.op2->ts.kind;
1004 rse.expr = convert (gfc_int4_type_node, rse.expr);
1026 if (expr->value.op.op1->ts.type == BT_INTEGER)
1027 lse.expr = convert (gfc_int4_type_node, lse.expr);
1052 switch (expr->value.op.op1->ts.type)
1055 if (kind == 3) /* Case 16 was not handled properly above. */
1057 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1061 /* Use builtins for real ** int4. */
1067 fndecl = built_in_decls[BUILT_IN_POWIF];
1071 fndecl = built_in_decls[BUILT_IN_POWI];
1075 fndecl = built_in_decls[BUILT_IN_POWIL];
1079 /* Use the __builtin_powil() only if real(kind=16) is
1080 actually the C long double type. */
1081 if (!gfc_real16_is_float128)
1082 fndecl = built_in_decls[BUILT_IN_POWIL];
1090 /* If we don't have a good builtin for this, go for the
1091 library function. */
1093 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1097 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1106 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1110 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1118 se->expr = build_call_expr_loc (input_location,
1119 fndecl, 2, lse.expr, rse.expr);
1123 /* Generate code to allocate a string temporary. */
1126 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1131 if (gfc_can_put_var_on_stack (len))
1133 /* Create a temporary variable to hold the result. */
1134 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1135 gfc_charlen_type_node, len,
1136 build_int_cst (gfc_charlen_type_node, 1));
1137 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1139 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1140 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1142 tmp = build_array_type (TREE_TYPE (type), tmp);
1144 var = gfc_create_var (tmp, "str");
1145 var = gfc_build_addr_expr (type, var);
1149 /* Allocate a temporary to hold the result. */
1150 var = gfc_create_var (type, "pstr");
1151 tmp = gfc_call_malloc (&se->pre, type,
1152 fold_build2_loc (input_location, MULT_EXPR,
1153 TREE_TYPE (len), len,
1154 fold_convert (TREE_TYPE (len),
1155 TYPE_SIZE (type))));
1156 gfc_add_modify (&se->pre, var, tmp);
1158 /* Free the temporary afterwards. */
1159 tmp = gfc_call_free (convert (pvoid_type_node, var));
1160 gfc_add_expr_to_block (&se->post, tmp);
1167 /* Handle a string concatenation operation. A temporary will be allocated to
1171 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1174 tree len, type, var, tmp, fndecl;
1176 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1177 && expr->value.op.op2->ts.type == BT_CHARACTER);
1178 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1180 gfc_init_se (&lse, se);
1181 gfc_conv_expr (&lse, expr->value.op.op1);
1182 gfc_conv_string_parameter (&lse);
1183 gfc_init_se (&rse, se);
1184 gfc_conv_expr (&rse, expr->value.op.op2);
1185 gfc_conv_string_parameter (&rse);
1187 gfc_add_block_to_block (&se->pre, &lse.pre);
1188 gfc_add_block_to_block (&se->pre, &rse.pre);
1190 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1191 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1192 if (len == NULL_TREE)
1194 len = fold_build2_loc (input_location, PLUS_EXPR,
1195 TREE_TYPE (lse.string_length),
1196 lse.string_length, rse.string_length);
1199 type = build_pointer_type (type);
1201 var = gfc_conv_string_tmp (se, type, len);
1203 /* Do the actual concatenation. */
1204 if (expr->ts.kind == 1)
1205 fndecl = gfor_fndecl_concat_string;
1206 else if (expr->ts.kind == 4)
1207 fndecl = gfor_fndecl_concat_string_char4;
1211 tmp = build_call_expr_loc (input_location,
1212 fndecl, 6, len, var, lse.string_length, lse.expr,
1213 rse.string_length, rse.expr);
1214 gfc_add_expr_to_block (&se->pre, tmp);
1216 /* Add the cleanup for the operands. */
1217 gfc_add_block_to_block (&se->pre, &rse.post);
1218 gfc_add_block_to_block (&se->pre, &lse.post);
1221 se->string_length = len;
1224 /* Translates an op expression. Common (binary) cases are handled by this
1225 function, others are passed on. Recursion is used in either case.
1226 We use the fact that (op1.ts == op2.ts) (except for the power
1228 Operators need no special handling for scalarized expressions as long as
1229 they call gfc_conv_simple_val to get their operands.
1230 Character strings get special handling. */
1233 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1235 enum tree_code code;
1244 switch (expr->value.op.op)
1246 case INTRINSIC_PARENTHESES:
1247 if ((expr->ts.type == BT_REAL
1248 || expr->ts.type == BT_COMPLEX)
1249 && gfc_option.flag_protect_parens)
1251 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1252 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1257 case INTRINSIC_UPLUS:
1258 gfc_conv_expr (se, expr->value.op.op1);
1261 case INTRINSIC_UMINUS:
1262 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1266 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1269 case INTRINSIC_PLUS:
1273 case INTRINSIC_MINUS:
1277 case INTRINSIC_TIMES:
1281 case INTRINSIC_DIVIDE:
1282 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1283 an integer, we must round towards zero, so we use a
1285 if (expr->ts.type == BT_INTEGER)
1286 code = TRUNC_DIV_EXPR;
1291 case INTRINSIC_POWER:
1292 gfc_conv_power_op (se, expr);
1295 case INTRINSIC_CONCAT:
1296 gfc_conv_concat_op (se, expr);
1300 code = TRUTH_ANDIF_EXPR;
1305 code = TRUTH_ORIF_EXPR;
1309 /* EQV and NEQV only work on logicals, but since we represent them
1310 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1312 case INTRINSIC_EQ_OS:
1320 case INTRINSIC_NE_OS:
1321 case INTRINSIC_NEQV:
1328 case INTRINSIC_GT_OS:
1335 case INTRINSIC_GE_OS:
1342 case INTRINSIC_LT_OS:
1349 case INTRINSIC_LE_OS:
1355 case INTRINSIC_USER:
1356 case INTRINSIC_ASSIGN:
1357 /* These should be converted into function calls by the frontend. */
1361 fatal_error ("Unknown intrinsic op");
1365 /* The only exception to this is **, which is handled separately anyway. */
1366 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1368 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1372 gfc_init_se (&lse, se);
1373 gfc_conv_expr (&lse, expr->value.op.op1);
1374 gfc_add_block_to_block (&se->pre, &lse.pre);
1377 gfc_init_se (&rse, se);
1378 gfc_conv_expr (&rse, expr->value.op.op2);
1379 gfc_add_block_to_block (&se->pre, &rse.pre);
1383 gfc_conv_string_parameter (&lse);
1384 gfc_conv_string_parameter (&rse);
1386 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1387 rse.string_length, rse.expr,
1388 expr->value.op.op1->ts.kind,
1390 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1391 gfc_add_block_to_block (&lse.post, &rse.post);
1394 type = gfc_typenode_for_spec (&expr->ts);
1398 /* The result of logical ops is always boolean_type_node. */
1399 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1400 lse.expr, rse.expr);
1401 se->expr = convert (type, tmp);
1404 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1406 /* Add the post blocks. */
1407 gfc_add_block_to_block (&se->post, &rse.post);
1408 gfc_add_block_to_block (&se->post, &lse.post);
1411 /* If a string's length is one, we convert it to a single character. */
1414 gfc_string_to_single_character (tree len, tree str, int kind)
1416 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1418 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1421 if (TREE_INT_CST_LOW (len) == 1)
1423 str = fold_convert (gfc_get_pchar_type (kind), str);
1424 return build_fold_indirect_ref_loc (input_location, str);
1428 && TREE_CODE (str) == ADDR_EXPR
1429 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1430 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1431 && array_ref_low_bound (TREE_OPERAND (str, 0))
1432 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1433 && TREE_INT_CST_LOW (len) > 1
1434 && TREE_INT_CST_LOW (len)
1435 == (unsigned HOST_WIDE_INT)
1436 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1438 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1439 ret = build_fold_indirect_ref_loc (input_location, ret);
1440 if (TREE_CODE (ret) == INTEGER_CST)
1442 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1443 int i, length = TREE_STRING_LENGTH (string_cst);
1444 const char *ptr = TREE_STRING_POINTER (string_cst);
1446 for (i = 1; i < length; i++)
1459 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1462 if (sym->backend_decl)
1464 /* This becomes the nominal_type in
1465 function.c:assign_parm_find_data_types. */
1466 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1467 /* This becomes the passed_type in
1468 function.c:assign_parm_find_data_types. C promotes char to
1469 integer for argument passing. */
1470 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1472 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1477 /* If we have a constant character expression, make it into an
1479 if ((*expr)->expr_type == EXPR_CONSTANT)
1484 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1485 (int)(*expr)->value.character.string[0]);
1486 if ((*expr)->ts.kind != gfc_c_int_kind)
1488 /* The expr needs to be compatible with a C int. If the
1489 conversion fails, then the 2 causes an ICE. */
1490 ts.type = BT_INTEGER;
1491 ts.kind = gfc_c_int_kind;
1492 gfc_convert_type (*expr, &ts, 2);
1495 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1497 if ((*expr)->ref == NULL)
1499 se->expr = gfc_string_to_single_character
1500 (build_int_cst (integer_type_node, 1),
1501 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1503 ((*expr)->symtree->n.sym)),
1508 gfc_conv_variable (se, *expr);
1509 se->expr = gfc_string_to_single_character
1510 (build_int_cst (integer_type_node, 1),
1511 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1519 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1520 if STR is a string literal, otherwise return -1. */
1523 gfc_optimize_len_trim (tree len, tree str, int kind)
1526 && TREE_CODE (str) == ADDR_EXPR
1527 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1528 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1529 && array_ref_low_bound (TREE_OPERAND (str, 0))
1530 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1531 && TREE_INT_CST_LOW (len) >= 1
1532 && TREE_INT_CST_LOW (len)
1533 == (unsigned HOST_WIDE_INT)
1534 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1536 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1537 folded = build_fold_indirect_ref_loc (input_location, folded);
1538 if (TREE_CODE (folded) == INTEGER_CST)
1540 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1541 int length = TREE_STRING_LENGTH (string_cst);
1542 const char *ptr = TREE_STRING_POINTER (string_cst);
1544 for (; length > 0; length--)
1545 if (ptr[length - 1] != ' ')
1554 /* Compare two strings. If they are all single characters, the result is the
1555 subtraction of them. Otherwise, we build a library call. */
1558 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1559 enum tree_code code)
1565 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1566 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1568 sc1 = gfc_string_to_single_character (len1, str1, kind);
1569 sc2 = gfc_string_to_single_character (len2, str2, kind);
1571 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1573 /* Deal with single character specially. */
1574 sc1 = fold_convert (integer_type_node, sc1);
1575 sc2 = fold_convert (integer_type_node, sc2);
1576 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1580 if ((code == EQ_EXPR || code == NE_EXPR)
1582 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1584 /* If one string is a string literal with LEN_TRIM longer
1585 than the length of the second string, the strings
1587 int len = gfc_optimize_len_trim (len1, str1, kind);
1588 if (len > 0 && compare_tree_int (len2, len) < 0)
1589 return integer_one_node;
1590 len = gfc_optimize_len_trim (len2, str2, kind);
1591 if (len > 0 && compare_tree_int (len1, len) < 0)
1592 return integer_one_node;
1595 /* Build a call for the comparison. */
1597 fndecl = gfor_fndecl_compare_string;
1599 fndecl = gfor_fndecl_compare_string_char4;
1603 return build_call_expr_loc (input_location, fndecl, 4,
1604 len1, str1, len2, str2);
1608 /* Return the backend_decl for a procedure pointer component. */
1611 get_proc_ptr_comp (gfc_expr *e)
1615 gfc_init_se (&comp_se, NULL);
1616 e2 = gfc_copy_expr (e);
1617 e2->expr_type = EXPR_VARIABLE;
1618 gfc_conv_expr (&comp_se, e2);
1620 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1625 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1629 if (gfc_is_proc_ptr_comp (expr, NULL))
1630 tmp = get_proc_ptr_comp (expr);
1631 else if (sym->attr.dummy)
1633 tmp = gfc_get_symbol_decl (sym);
1634 if (sym->attr.proc_pointer)
1635 tmp = build_fold_indirect_ref_loc (input_location,
1637 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1638 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1642 if (!sym->backend_decl)
1643 sym->backend_decl = gfc_get_extern_function_decl (sym);
1645 tmp = sym->backend_decl;
1647 if (sym->attr.cray_pointee)
1649 /* TODO - make the cray pointee a pointer to a procedure,
1650 assign the pointer to it and use it for the call. This
1652 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1653 gfc_get_symbol_decl (sym->cp_pointer));
1654 tmp = gfc_evaluate_now (tmp, &se->pre);
1657 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1659 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1660 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1667 /* Initialize MAPPING. */
1670 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1672 mapping->syms = NULL;
1673 mapping->charlens = NULL;
1677 /* Free all memory held by MAPPING (but not MAPPING itself). */
1680 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1682 gfc_interface_sym_mapping *sym;
1683 gfc_interface_sym_mapping *nextsym;
1685 gfc_charlen *nextcl;
1687 for (sym = mapping->syms; sym; sym = nextsym)
1689 nextsym = sym->next;
1690 sym->new_sym->n.sym->formal = NULL;
1691 gfc_free_symbol (sym->new_sym->n.sym);
1692 gfc_free_expr (sym->expr);
1693 gfc_free (sym->new_sym);
1696 for (cl = mapping->charlens; cl; cl = nextcl)
1699 gfc_free_expr (cl->length);
1705 /* Return a copy of gfc_charlen CL. Add the returned structure to
1706 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1708 static gfc_charlen *
1709 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1712 gfc_charlen *new_charlen;
1714 new_charlen = gfc_get_charlen ();
1715 new_charlen->next = mapping->charlens;
1716 new_charlen->length = gfc_copy_expr (cl->length);
1718 mapping->charlens = new_charlen;
1723 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1724 array variable that can be used as the actual argument for dummy
1725 argument SYM. Add any initialization code to BLOCK. PACKED is as
1726 for gfc_get_nodesc_array_type and DATA points to the first element
1727 in the passed array. */
1730 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1731 gfc_packed packed, tree data)
1736 type = gfc_typenode_for_spec (&sym->ts);
1737 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1738 !sym->attr.target && !sym->attr.pointer
1739 && !sym->attr.proc_pointer);
1741 var = gfc_create_var (type, "ifm");
1742 gfc_add_modify (block, var, fold_convert (type, data));
1748 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1749 and offset of descriptorless array type TYPE given that it has the same
1750 size as DESC. Add any set-up code to BLOCK. */
1753 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1760 offset = gfc_index_zero_node;
1761 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1763 dim = gfc_rank_cst[n];
1764 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1765 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1767 GFC_TYPE_ARRAY_LBOUND (type, n)
1768 = gfc_conv_descriptor_lbound_get (desc, dim);
1769 GFC_TYPE_ARRAY_UBOUND (type, n)
1770 = gfc_conv_descriptor_ubound_get (desc, dim);
1772 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1774 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1775 gfc_array_index_type,
1776 gfc_conv_descriptor_ubound_get (desc, dim),
1777 gfc_conv_descriptor_lbound_get (desc, dim));
1778 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1779 gfc_array_index_type,
1780 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1781 tmp = gfc_evaluate_now (tmp, block);
1782 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1784 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1785 GFC_TYPE_ARRAY_LBOUND (type, n),
1786 GFC_TYPE_ARRAY_STRIDE (type, n));
1787 offset = fold_build2_loc (input_location, MINUS_EXPR,
1788 gfc_array_index_type, offset, tmp);
1790 offset = gfc_evaluate_now (offset, block);
1791 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1795 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1796 in SE. The caller may still use se->expr and se->string_length after
1797 calling this function. */
1800 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1801 gfc_symbol * sym, gfc_se * se,
1804 gfc_interface_sym_mapping *sm;
1808 gfc_symbol *new_sym;
1810 gfc_symtree *new_symtree;
1812 /* Create a new symbol to represent the actual argument. */
1813 new_sym = gfc_new_symbol (sym->name, NULL);
1814 new_sym->ts = sym->ts;
1815 new_sym->as = gfc_copy_array_spec (sym->as);
1816 new_sym->attr.referenced = 1;
1817 new_sym->attr.dimension = sym->attr.dimension;
1818 new_sym->attr.contiguous = sym->attr.contiguous;
1819 new_sym->attr.codimension = sym->attr.codimension;
1820 new_sym->attr.pointer = sym->attr.pointer;
1821 new_sym->attr.allocatable = sym->attr.allocatable;
1822 new_sym->attr.flavor = sym->attr.flavor;
1823 new_sym->attr.function = sym->attr.function;
1825 /* Ensure that the interface is available and that
1826 descriptors are passed for array actual arguments. */
1827 if (sym->attr.flavor == FL_PROCEDURE)
1829 new_sym->formal = expr->symtree->n.sym->formal;
1830 new_sym->attr.always_explicit
1831 = expr->symtree->n.sym->attr.always_explicit;
1834 /* Create a fake symtree for it. */
1836 new_symtree = gfc_new_symtree (&root, sym->name);
1837 new_symtree->n.sym = new_sym;
1838 gcc_assert (new_symtree == root);
1840 /* Create a dummy->actual mapping. */
1841 sm = XCNEW (gfc_interface_sym_mapping);
1842 sm->next = mapping->syms;
1844 sm->new_sym = new_symtree;
1845 sm->expr = gfc_copy_expr (expr);
1848 /* Stabilize the argument's value. */
1849 if (!sym->attr.function && se)
1850 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1852 if (sym->ts.type == BT_CHARACTER)
1854 /* Create a copy of the dummy argument's length. */
1855 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1856 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1858 /* If the length is specified as "*", record the length that
1859 the caller is passing. We should use the callee's length
1860 in all other cases. */
1861 if (!new_sym->ts.u.cl->length && se)
1863 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1864 new_sym->ts.u.cl->backend_decl = se->string_length;
1871 /* Use the passed value as-is if the argument is a function. */
1872 if (sym->attr.flavor == FL_PROCEDURE)
1875 /* If the argument is either a string or a pointer to a string,
1876 convert it to a boundless character type. */
1877 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1879 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1880 tmp = build_pointer_type (tmp);
1881 if (sym->attr.pointer)
1882 value = build_fold_indirect_ref_loc (input_location,
1886 value = fold_convert (tmp, value);
1889 /* If the argument is a scalar, a pointer to an array or an allocatable,
1891 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1892 value = build_fold_indirect_ref_loc (input_location,
1895 /* For character(*), use the actual argument's descriptor. */
1896 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1897 value = build_fold_indirect_ref_loc (input_location,
1900 /* If the argument is an array descriptor, use it to determine
1901 information about the actual argument's shape. */
1902 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1903 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1905 /* Get the actual argument's descriptor. */
1906 desc = build_fold_indirect_ref_loc (input_location,
1909 /* Create the replacement variable. */
1910 tmp = gfc_conv_descriptor_data_get (desc);
1911 value = gfc_get_interface_mapping_array (&se->pre, sym,
1914 /* Use DESC to work out the upper bounds, strides and offset. */
1915 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1918 /* Otherwise we have a packed array. */
1919 value = gfc_get_interface_mapping_array (&se->pre, sym,
1920 PACKED_FULL, se->expr);
1922 new_sym->backend_decl = value;
1926 /* Called once all dummy argument mappings have been added to MAPPING,
1927 but before the mapping is used to evaluate expressions. Pre-evaluate
1928 the length of each argument, adding any initialization code to PRE and
1929 any finalization code to POST. */
1932 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1933 stmtblock_t * pre, stmtblock_t * post)
1935 gfc_interface_sym_mapping *sym;
1939 for (sym = mapping->syms; sym; sym = sym->next)
1940 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1941 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1943 expr = sym->new_sym->n.sym->ts.u.cl->length;
1944 gfc_apply_interface_mapping_to_expr (mapping, expr);
1945 gfc_init_se (&se, NULL);
1946 gfc_conv_expr (&se, expr);
1947 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1948 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1949 gfc_add_block_to_block (pre, &se.pre);
1950 gfc_add_block_to_block (post, &se.post);
1952 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1957 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1961 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1962 gfc_constructor_base base)
1965 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1967 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1970 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1971 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1972 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1978 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1982 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1987 for (; ref; ref = ref->next)
1991 for (n = 0; n < ref->u.ar.dimen; n++)
1993 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1994 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1995 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1997 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2004 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2005 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2011 /* Convert intrinsic function calls into result expressions. */
2014 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2022 arg1 = expr->value.function.actual->expr;
2023 if (expr->value.function.actual->next)
2024 arg2 = expr->value.function.actual->next->expr;
2028 sym = arg1->symtree->n.sym;
2030 if (sym->attr.dummy)
2035 switch (expr->value.function.isym->id)
2038 /* TODO figure out why this condition is necessary. */
2039 if (sym->attr.function
2040 && (arg1->ts.u.cl->length == NULL
2041 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2042 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2045 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2049 if (!sym->as || sym->as->rank == 0)
2052 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2054 dup = mpz_get_si (arg2->value.integer);
2059 dup = sym->as->rank;
2063 for (; d < dup; d++)
2067 if (!sym->as->upper[d] || !sym->as->lower[d])
2069 gfc_free_expr (new_expr);
2073 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2074 gfc_get_int_expr (gfc_default_integer_kind,
2076 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2078 new_expr = gfc_multiply (new_expr, tmp);
2084 case GFC_ISYM_LBOUND:
2085 case GFC_ISYM_UBOUND:
2086 /* TODO These implementations of lbound and ubound do not limit if
2087 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2089 if (!sym->as || sym->as->rank == 0)
2092 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2093 d = mpz_get_si (arg2->value.integer) - 1;
2095 /* TODO: If the need arises, this could produce an array of
2099 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2101 if (sym->as->lower[d])
2102 new_expr = gfc_copy_expr (sym->as->lower[d]);
2106 if (sym->as->upper[d])
2107 new_expr = gfc_copy_expr (sym->as->upper[d]);
2115 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2119 gfc_replace_expr (expr, new_expr);
2125 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2126 gfc_interface_mapping * mapping)
2128 gfc_formal_arglist *f;
2129 gfc_actual_arglist *actual;
2131 actual = expr->value.function.actual;
2132 f = map_expr->symtree->n.sym->formal;
2134 for (; f && actual; f = f->next, actual = actual->next)
2139 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2142 if (map_expr->symtree->n.sym->attr.dimension)
2147 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2149 for (d = 0; d < as->rank; d++)
2151 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2152 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2155 expr->value.function.esym->as = as;
2158 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2160 expr->value.function.esym->ts.u.cl->length
2161 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2163 gfc_apply_interface_mapping_to_expr (mapping,
2164 expr->value.function.esym->ts.u.cl->length);
2169 /* EXPR is a copy of an expression that appeared in the interface
2170 associated with MAPPING. Walk it recursively looking for references to
2171 dummy arguments that MAPPING maps to actual arguments. Replace each such
2172 reference with a reference to the associated actual argument. */
2175 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2178 gfc_interface_sym_mapping *sym;
2179 gfc_actual_arglist *actual;
2184 /* Copying an expression does not copy its length, so do that here. */
2185 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2187 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2188 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2191 /* Apply the mapping to any references. */
2192 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2194 /* ...and to the expression's symbol, if it has one. */
2195 /* TODO Find out why the condition on expr->symtree had to be moved into
2196 the loop rather than being outside it, as originally. */
2197 for (sym = mapping->syms; sym; sym = sym->next)
2198 if (expr->symtree && sym->old == expr->symtree->n.sym)
2200 if (sym->new_sym->n.sym->backend_decl)
2201 expr->symtree = sym->new_sym;
2203 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2206 /* ...and to subexpressions in expr->value. */
2207 switch (expr->expr_type)
2212 case EXPR_SUBSTRING:
2216 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2217 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2221 for (actual = expr->value.function.actual; actual; actual = actual->next)
2222 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2224 if (expr->value.function.esym == NULL
2225 && expr->value.function.isym != NULL
2226 && expr->value.function.actual->expr->symtree
2227 && gfc_map_intrinsic_function (expr, mapping))
2230 for (sym = mapping->syms; sym; sym = sym->next)
2231 if (sym->old == expr->value.function.esym)
2233 expr->value.function.esym = sym->new_sym->n.sym;
2234 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2235 expr->value.function.esym->result = sym->new_sym->n.sym;
2240 case EXPR_STRUCTURE:
2241 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2254 /* Evaluate interface expression EXPR using MAPPING. Store the result
2258 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2259 gfc_se * se, gfc_expr * expr)
2261 expr = gfc_copy_expr (expr);
2262 gfc_apply_interface_mapping_to_expr (mapping, expr);
2263 gfc_conv_expr (se, expr);
2264 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2265 gfc_free_expr (expr);
2269 /* Returns a reference to a temporary array into which a component of
2270 an actual argument derived type array is copied and then returned
2271 after the function call. */
2273 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2274 sym_intent intent, bool formal_ptr)
2292 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2294 gfc_init_se (&lse, NULL);
2295 gfc_init_se (&rse, NULL);
2297 /* Walk the argument expression. */
2298 rss = gfc_walk_expr (expr);
2300 gcc_assert (rss != gfc_ss_terminator);
2302 /* Initialize the scalarizer. */
2303 gfc_init_loopinfo (&loop);
2304 gfc_add_ss_to_loop (&loop, rss);
2306 /* Calculate the bounds of the scalarization. */
2307 gfc_conv_ss_startstride (&loop);
2309 /* Build an ss for the temporary. */
2310 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2311 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2313 base_type = gfc_typenode_for_spec (&expr->ts);
2314 if (GFC_ARRAY_TYPE_P (base_type)
2315 || GFC_DESCRIPTOR_TYPE_P (base_type))
2316 base_type = gfc_get_element_type (base_type);
2318 loop.temp_ss = gfc_get_ss ();;
2319 loop.temp_ss->type = GFC_SS_TEMP;
2320 loop.temp_ss->data.temp.type = base_type;
2322 if (expr->ts.type == BT_CHARACTER)
2323 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2325 loop.temp_ss->string_length = NULL;
2327 parmse->string_length = loop.temp_ss->string_length;
2328 loop.temp_ss->data.temp.dimen = loop.dimen;
2329 loop.temp_ss->next = gfc_ss_terminator;
2331 /* Associate the SS with the loop. */
2332 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2334 /* Setup the scalarizing loops. */
2335 gfc_conv_loop_setup (&loop, &expr->where);
2337 /* Pass the temporary descriptor back to the caller. */
2338 info = &loop.temp_ss->data.info;
2339 parmse->expr = info->descriptor;
2341 /* Setup the gfc_se structures. */
2342 gfc_copy_loopinfo_to_se (&lse, &loop);
2343 gfc_copy_loopinfo_to_se (&rse, &loop);
2346 lse.ss = loop.temp_ss;
2347 gfc_mark_ss_chain_used (rss, 1);
2348 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2350 /* Start the scalarized loop body. */
2351 gfc_start_scalarized_body (&loop, &body);
2353 /* Translate the expression. */
2354 gfc_conv_expr (&rse, expr);
2356 gfc_conv_tmp_array_ref (&lse);
2357 gfc_advance_se_ss_chain (&lse);
2359 if (intent != INTENT_OUT)
2361 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2362 gfc_add_expr_to_block (&body, tmp);
2363 gcc_assert (rse.ss == gfc_ss_terminator);
2364 gfc_trans_scalarizing_loops (&loop, &body);
2368 /* Make sure that the temporary declaration survives by merging
2369 all the loop declarations into the current context. */
2370 for (n = 0; n < loop.dimen; n++)
2372 gfc_merge_block_scope (&body);
2373 body = loop.code[loop.order[n]];
2375 gfc_merge_block_scope (&body);
2378 /* Add the post block after the second loop, so that any
2379 freeing of allocated memory is done at the right time. */
2380 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2382 /**********Copy the temporary back again.*********/
2384 gfc_init_se (&lse, NULL);
2385 gfc_init_se (&rse, NULL);
2387 /* Walk the argument expression. */
2388 lss = gfc_walk_expr (expr);
2389 rse.ss = loop.temp_ss;
2392 /* Initialize the scalarizer. */
2393 gfc_init_loopinfo (&loop2);
2394 gfc_add_ss_to_loop (&loop2, lss);
2396 /* Calculate the bounds of the scalarization. */
2397 gfc_conv_ss_startstride (&loop2);
2399 /* Setup the scalarizing loops. */
2400 gfc_conv_loop_setup (&loop2, &expr->where);
2402 gfc_copy_loopinfo_to_se (&lse, &loop2);
2403 gfc_copy_loopinfo_to_se (&rse, &loop2);
2405 gfc_mark_ss_chain_used (lss, 1);
2406 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2408 /* Declare the variable to hold the temporary offset and start the
2409 scalarized loop body. */
2410 offset = gfc_create_var (gfc_array_index_type, NULL);
2411 gfc_start_scalarized_body (&loop2, &body);
2413 /* Build the offsets for the temporary from the loop variables. The
2414 temporary array has lbounds of zero and strides of one in all
2415 dimensions, so this is very simple. The offset is only computed
2416 outside the innermost loop, so the overall transfer could be
2417 optimized further. */
2418 info = &rse.ss->data.info;
2419 dimen = info->dimen;
2421 tmp_index = gfc_index_zero_node;
2422 for (n = dimen - 1; n > 0; n--)
2425 tmp = rse.loop->loopvar[n];
2426 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2427 tmp, rse.loop->from[n]);
2428 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2431 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2432 gfc_array_index_type,
2433 rse.loop->to[n-1], rse.loop->from[n-1]);
2434 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2435 gfc_array_index_type,
2436 tmp_str, gfc_index_one_node);
2438 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2439 gfc_array_index_type, tmp, tmp_str);
2442 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2443 gfc_array_index_type,
2444 tmp_index, rse.loop->from[0]);
2445 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2447 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2448 gfc_array_index_type,
2449 rse.loop->loopvar[0], offset);
2451 /* Now use the offset for the reference. */
2452 tmp = build_fold_indirect_ref_loc (input_location,
2454 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2456 if (expr->ts.type == BT_CHARACTER)
2457 rse.string_length = expr->ts.u.cl->backend_decl;
2459 gfc_conv_expr (&lse, expr);
2461 gcc_assert (lse.ss == gfc_ss_terminator);
2463 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2464 gfc_add_expr_to_block (&body, tmp);
2466 /* Generate the copying loops. */
2467 gfc_trans_scalarizing_loops (&loop2, &body);
2469 /* Wrap the whole thing up by adding the second loop to the post-block
2470 and following it by the post-block of the first loop. In this way,
2471 if the temporary needs freeing, it is done after use! */
2472 if (intent != INTENT_IN)
2474 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2475 gfc_add_block_to_block (&parmse->post, &loop2.post);
2478 gfc_add_block_to_block (&parmse->post, &loop.post);
2480 gfc_cleanup_loop (&loop);
2481 gfc_cleanup_loop (&loop2);
2483 /* Pass the string length to the argument expression. */
2484 if (expr->ts.type == BT_CHARACTER)
2485 parmse->string_length = expr->ts.u.cl->backend_decl;
2487 /* Determine the offset for pointer formal arguments and set the
2491 size = gfc_index_one_node;
2492 offset = gfc_index_zero_node;
2493 for (n = 0; n < dimen; n++)
2495 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2497 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2498 gfc_array_index_type, tmp,
2499 gfc_index_one_node);
2500 gfc_conv_descriptor_ubound_set (&parmse->pre,
2504 gfc_conv_descriptor_lbound_set (&parmse->pre,
2507 gfc_index_one_node);
2508 size = gfc_evaluate_now (size, &parmse->pre);
2509 offset = fold_build2_loc (input_location, MINUS_EXPR,
2510 gfc_array_index_type,
2512 offset = gfc_evaluate_now (offset, &parmse->pre);
2513 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2514 gfc_array_index_type,
2515 rse.loop->to[n], rse.loop->from[n]);
2516 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2517 gfc_array_index_type,
2518 tmp, gfc_index_one_node);
2519 size = fold_build2_loc (input_location, MULT_EXPR,
2520 gfc_array_index_type, size, tmp);
2523 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2527 /* We want either the address for the data or the address of the descriptor,
2528 depending on the mode of passing array arguments. */
2530 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2532 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2538 /* Generate the code for argument list functions. */
2541 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2543 /* Pass by value for g77 %VAL(arg), pass the address
2544 indirectly for %LOC, else by reference. Thus %REF
2545 is a "do-nothing" and %LOC is the same as an F95
2547 if (strncmp (name, "%VAL", 4) == 0)
2548 gfc_conv_expr (se, expr);
2549 else if (strncmp (name, "%LOC", 4) == 0)
2551 gfc_conv_expr_reference (se, expr);
2552 se->expr = gfc_build_addr_expr (NULL, se->expr);
2554 else if (strncmp (name, "%REF", 4) == 0)
2555 gfc_conv_expr_reference (se, expr);
2557 gfc_error ("Unknown argument list function at %L", &expr->where);
2561 /* Takes a derived type expression and returns the address of a temporary
2562 class object of the 'declared' type. */
2564 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2565 gfc_typespec class_ts)
2569 gfc_symbol *declared = class_ts.u.derived;
2575 /* The derived type needs to be converted to a temporary
2577 tmp = gfc_typenode_for_spec (&class_ts);
2578 var = gfc_create_var (tmp, "class");
2581 cmp = gfc_find_component (declared, "$vptr", true, true);
2582 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2583 TREE_TYPE (cmp->backend_decl),
2584 var, cmp->backend_decl, NULL_TREE);
2586 /* Remember the vtab corresponds to the derived type
2587 not to the class declared type. */
2588 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2590 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2591 gfc_add_modify (&parmse->pre, ctree,
2592 fold_convert (TREE_TYPE (ctree), tmp));
2594 /* Now set the data field. */
2595 cmp = gfc_find_component (declared, "$data", true, true);
2596 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2597 TREE_TYPE (cmp->backend_decl),
2598 var, cmp->backend_decl, NULL_TREE);
2599 ss = gfc_walk_expr (e);
2600 if (ss == gfc_ss_terminator)
2603 gfc_conv_expr_reference (parmse, e);
2604 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2605 gfc_add_modify (&parmse->pre, ctree, tmp);
2610 gfc_conv_expr (parmse, e);
2611 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2614 /* Pass the address of the class object. */
2615 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2619 /* The following routine generates code for the intrinsic
2620 procedures from the ISO_C_BINDING module:
2622 * C_FUNLOC (function)
2623 * C_F_POINTER (subroutine)
2624 * C_F_PROCPOINTER (subroutine)
2625 * C_ASSOCIATED (function)
2626 One exception which is not handled here is C_F_POINTER with non-scalar
2627 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2630 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2631 gfc_actual_arglist * arg)
2636 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2638 if (arg->expr->rank == 0)
2639 gfc_conv_expr_reference (se, arg->expr);
2643 /* This is really the actual arg because no formal arglist is
2644 created for C_LOC. */
2645 fsym = arg->expr->symtree->n.sym;
2647 /* We should want it to do g77 calling convention. */
2649 && !(fsym->attr.pointer || fsym->attr.allocatable)
2650 && fsym->as->type != AS_ASSUMED_SHAPE;
2651 f = f || !sym->attr.always_explicit;
2653 argss = gfc_walk_expr (arg->expr);
2654 gfc_conv_array_parameter (se, arg->expr, argss, f,
2658 /* TODO -- the following two lines shouldn't be necessary, but if
2659 they're removed, a bug is exposed later in the code path.
2660 This workaround was thus introduced, but will have to be
2661 removed; please see PR 35150 for details about the issue. */
2662 se->expr = convert (pvoid_type_node, se->expr);
2663 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2667 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2669 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2670 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2671 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2672 gfc_conv_expr_reference (se, arg->expr);
2676 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2677 && arg->next->expr->rank == 0)
2678 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2680 /* Convert c_f_pointer if fptr is a scalar
2681 and convert c_f_procpointer. */
2685 gfc_init_se (&cptrse, NULL);
2686 gfc_conv_expr (&cptrse, arg->expr);
2687 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2688 gfc_add_block_to_block (&se->post, &cptrse.post);
2690 gfc_init_se (&fptrse, NULL);
2691 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2692 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2693 fptrse.want_pointer = 1;
2695 gfc_conv_expr (&fptrse, arg->next->expr);
2696 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2697 gfc_add_block_to_block (&se->post, &fptrse.post);
2699 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2700 && arg->next->expr->symtree->n.sym->attr.dummy)
2701 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2704 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2705 TREE_TYPE (fptrse.expr),
2707 fold_convert (TREE_TYPE (fptrse.expr),
2712 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2717 /* Build the addr_expr for the first argument. The argument is
2718 already an *address* so we don't need to set want_pointer in
2720 gfc_init_se (&arg1se, NULL);
2721 gfc_conv_expr (&arg1se, arg->expr);
2722 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2723 gfc_add_block_to_block (&se->post, &arg1se.post);
2725 /* See if we were given two arguments. */
2726 if (arg->next == NULL)
2727 /* Only given one arg so generate a null and do a
2728 not-equal comparison against the first arg. */
2729 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2731 fold_convert (TREE_TYPE (arg1se.expr),
2732 null_pointer_node));
2738 /* Given two arguments so build the arg2se from second arg. */
2739 gfc_init_se (&arg2se, NULL);
2740 gfc_conv_expr (&arg2se, arg->next->expr);
2741 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2742 gfc_add_block_to_block (&se->post, &arg2se.post);
2744 /* Generate test to compare that the two args are equal. */
2745 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2746 arg1se.expr, arg2se.expr);
2747 /* Generate test to ensure that the first arg is not null. */
2748 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2750 arg1se.expr, null_pointer_node);
2752 /* Finally, the generated test must check that both arg1 is not
2753 NULL and that it is equal to the second arg. */
2754 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2756 not_null_expr, eq_expr);
2762 /* Nothing was done. */
2766 /* Generate code for a procedure call. Note can return se->post != NULL.
2767 If se->direct_byref is set then se->expr contains the return parameter.
2768 Return nonzero, if the call has alternate specifiers.
2769 'expr' is only needed for procedure pointer components. */
2772 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2773 gfc_actual_arglist * args, gfc_expr * expr,
2774 VEC(tree,gc) *append_args)
2776 gfc_interface_mapping mapping;
2777 VEC(tree,gc) *arglist;
2778 VEC(tree,gc) *retargs;
2789 VEC(tree,gc) *stringargs;
2791 gfc_formal_arglist *formal;
2792 gfc_actual_arglist *arg;
2793 int has_alternate_specifier = 0;
2794 bool need_interface_mapping;
2801 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2802 gfc_component *comp = NULL;
2812 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2813 && conv_isocbinding_procedure (se, sym, args))
2816 gfc_is_proc_ptr_comp (expr, &comp);
2820 if (!sym->attr.elemental)
2822 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2823 if (se->ss->useflags)
2825 gcc_assert ((!comp && gfc_return_by_reference (sym)
2826 && sym->result->attr.dimension)
2827 || (comp && comp->attr.dimension));
2828 gcc_assert (se->loop != NULL);
2830 /* Access the previously obtained result. */
2831 gfc_conv_tmp_array_ref (se);
2832 gfc_advance_se_ss_chain (se);
2836 info = &se->ss->data.info;
2841 gfc_init_block (&post);
2842 gfc_init_interface_mapping (&mapping);
2845 formal = sym->formal;
2846 need_interface_mapping = sym->attr.dimension ||
2847 (sym->ts.type == BT_CHARACTER
2848 && sym->ts.u.cl->length
2849 && sym->ts.u.cl->length->expr_type
2854 formal = comp->formal;
2855 need_interface_mapping = comp->attr.dimension ||
2856 (comp->ts.type == BT_CHARACTER
2857 && comp->ts.u.cl->length
2858 && comp->ts.u.cl->length->expr_type
2862 /* Evaluate the arguments. */
2863 for (arg = args; arg != NULL;
2864 arg = arg->next, formal = formal ? formal->next : NULL)
2867 fsym = formal ? formal->sym : NULL;
2868 parm_kind = MISSING;
2872 if (se->ignore_optional)
2874 /* Some intrinsics have already been resolved to the correct
2878 else if (arg->label)
2880 has_alternate_specifier = 1;
2885 /* Pass a NULL pointer for an absent arg. */
2886 gfc_init_se (&parmse, NULL);
2887 parmse.expr = null_pointer_node;
2888 if (arg->missing_arg_type == BT_CHARACTER)
2889 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2892 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2894 /* Pass a NULL pointer to denote an absent arg. */
2895 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2896 gfc_init_se (&parmse, NULL);
2897 parmse.expr = null_pointer_node;
2898 if (arg->missing_arg_type == BT_CHARACTER)
2899 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2901 else if (fsym && fsym->ts.type == BT_CLASS
2902 && e->ts.type == BT_DERIVED)
2904 /* The derived type needs to be converted to a temporary
2906 gfc_init_se (&parmse, se);
2907 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2909 else if (se->ss && se->ss->useflags)
2911 /* An elemental function inside a scalarized loop. */
2912 gfc_init_se (&parmse, se);
2913 gfc_conv_expr_reference (&parmse, e);
2914 parm_kind = ELEMENTAL;
2918 /* A scalar or transformational function. */
2919 gfc_init_se (&parmse, NULL);
2920 argss = gfc_walk_expr (e);
2922 if (argss == gfc_ss_terminator)
2924 if (e->expr_type == EXPR_VARIABLE
2925 && e->symtree->n.sym->attr.cray_pointee
2926 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2928 /* The Cray pointer needs to be converted to a pointer to
2929 a type given by the expression. */
2930 gfc_conv_expr (&parmse, e);
2931 type = build_pointer_type (TREE_TYPE (parmse.expr));
2932 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2933 parmse.expr = convert (type, tmp);
2935 else if (fsym && fsym->attr.value)
2937 if (fsym->ts.type == BT_CHARACTER
2938 && fsym->ts.is_c_interop
2939 && fsym->ns->proc_name != NULL
2940 && fsym->ns->proc_name->attr.is_bind_c)
2943 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2944 if (parmse.expr == NULL)
2945 gfc_conv_expr (&parmse, e);
2948 gfc_conv_expr (&parmse, e);
2950 else if (arg->name && arg->name[0] == '%')
2951 /* Argument list functions %VAL, %LOC and %REF are signalled
2952 through arg->name. */
2953 conv_arglist_function (&parmse, arg->expr, arg->name);
2954 else if ((e->expr_type == EXPR_FUNCTION)
2955 && ((e->value.function.esym
2956 && e->value.function.esym->result->attr.pointer)
2957 || (!e->value.function.esym
2958 && e->symtree->n.sym->attr.pointer))
2959 && fsym && fsym->attr.target)
2961 gfc_conv_expr (&parmse, e);
2962 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2964 else if (e->expr_type == EXPR_FUNCTION
2965 && e->symtree->n.sym->result
2966 && e->symtree->n.sym->result != e->symtree->n.sym
2967 && e->symtree->n.sym->result->attr.proc_pointer)
2969 /* Functions returning procedure pointers. */
2970 gfc_conv_expr (&parmse, e);
2971 if (fsym && fsym->attr.proc_pointer)
2972 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2976 gfc_conv_expr_reference (&parmse, e);
2978 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2979 allocated on entry, it must be deallocated. */
2980 if (fsym && fsym->attr.allocatable
2981 && fsym->attr.intent == INTENT_OUT)
2985 gfc_init_block (&block);
2986 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2988 gfc_add_expr_to_block (&block, tmp);
2989 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2990 void_type_node, parmse.expr,
2992 gfc_add_expr_to_block (&block, tmp);
2994 if (fsym->attr.optional
2995 && e->expr_type == EXPR_VARIABLE
2996 && e->symtree->n.sym->attr.optional)
2998 tmp = fold_build3_loc (input_location, COND_EXPR,
3000 gfc_conv_expr_present (e->symtree->n.sym),
3001 gfc_finish_block (&block),
3002 build_empty_stmt (input_location));
3005 tmp = gfc_finish_block (&block);
3007 gfc_add_expr_to_block (&se->pre, tmp);
3010 if (fsym && e->expr_type != EXPR_NULL
3011 && ((fsym->attr.pointer
3012 && fsym->attr.flavor != FL_PROCEDURE)
3013 || (fsym->attr.proc_pointer
3014 && !(e->expr_type == EXPR_VARIABLE
3015 && e->symtree->n.sym->attr.dummy))
3016 || (e->expr_type == EXPR_VARIABLE
3017 && gfc_is_proc_ptr_comp (e, NULL))
3018 || fsym->attr.allocatable))
3020 /* Scalar pointer dummy args require an extra level of
3021 indirection. The null pointer already contains
3022 this level of indirection. */
3023 parm_kind = SCALAR_POINTER;
3024 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3030 /* If the procedure requires an explicit interface, the actual
3031 argument is passed according to the corresponding formal
3032 argument. If the corresponding formal argument is a POINTER,
3033 ALLOCATABLE or assumed shape, we do not use g77's calling
3034 convention, and pass the address of the array descriptor
3035 instead. Otherwise we use g77's calling convention. */
3038 && !(fsym->attr.pointer || fsym->attr.allocatable)
3039 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3041 f = f || !comp->attr.always_explicit;
3043 f = f || !sym->attr.always_explicit;
3045 /* If the argument is a function call that may not create
3046 a temporary for the result, we have to check that we
3047 can do it, i.e. that there is no alias between this
3048 argument and another one. */
3049 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3054 intent = fsym->attr.intent;
3056 intent = INTENT_UNKNOWN;
3058 if (gfc_check_fncall_dependency (e, intent, sym, args,
3060 parmse.force_tmp = 1;
3063 if (e->expr_type == EXPR_VARIABLE
3064 && is_subref_array (e))
3065 /* The actual argument is a component reference to an
3066 array of derived types. In this case, the argument
3067 is converted to a temporary, which is passed and then
3068 written back after the procedure call. */
3069 gfc_conv_subref_array_arg (&parmse, e, f,
3070 fsym ? fsym->attr.intent : INTENT_INOUT,
3071 fsym && fsym->attr.pointer);
3073 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3076 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3077 allocated on entry, it must be deallocated. */
3078 if (fsym && fsym->attr.allocatable
3079 && fsym->attr.intent == INTENT_OUT)
3081 tmp = build_fold_indirect_ref_loc (input_location,
3083 tmp = gfc_trans_dealloc_allocated (tmp);
3084 if (fsym->attr.optional
3085 && e->expr_type == EXPR_VARIABLE
3086 && e->symtree->n.sym->attr.optional)
3087 tmp = fold_build3_loc (input_location, COND_EXPR,
3089 gfc_conv_expr_present (e->symtree->n.sym),
3090 tmp, build_empty_stmt (input_location));
3091 gfc_add_expr_to_block (&se->pre, tmp);
3096 /* The case with fsym->attr.optional is that of a user subroutine
3097 with an interface indicating an optional argument. When we call
3098 an intrinsic subroutine, however, fsym is NULL, but we might still
3099 have an optional argument, so we proceed to the substitution
3101 if (e && (fsym == NULL || fsym->attr.optional))
3103 /* If an optional argument is itself an optional dummy argument,
3104 check its presence and substitute a null if absent. This is
3105 only needed when passing an array to an elemental procedure
3106 as then array elements are accessed - or no NULL pointer is
3107 allowed and a "1" or "0" should be passed if not present.
3108 When passing a non-array-descriptor full array to a
3109 non-array-descriptor dummy, no check is needed. For
3110 array-descriptor actual to array-descriptor dummy, see
3111 PR 41911 for why a check has to be inserted.
3112 fsym == NULL is checked as intrinsics required the descriptor
3113 but do not always set fsym. */
3114 if (e->expr_type == EXPR_VARIABLE
3115 && e->symtree->n.sym->attr.optional
3116 && ((e->rank > 0 && sym->attr.elemental)
3117 || e->representation.length || e->ts.type == BT_CHARACTER
3119 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3120 || fsym->as->type == AS_DEFERRED))))
3121 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3122 e->representation.length);
3127 /* Obtain the character length of an assumed character length
3128 length procedure from the typespec. */
3129 if (fsym->ts.type == BT_CHARACTER
3130 && parmse.string_length == NULL_TREE
3131 && e->ts.type == BT_PROCEDURE
3132 && e->symtree->n.sym->ts.type == BT_CHARACTER
3133 && e->symtree->n.sym->ts.u.cl->length != NULL
3134 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3136 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3137 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3141 if (fsym && need_interface_mapping && e)
3142 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3144 gfc_add_block_to_block (&se->pre, &parmse.pre);
3145 gfc_add_block_to_block (&post, &parmse.post);
3147 /* Allocated allocatable components of derived types must be
3148 deallocated for non-variable scalars. Non-variable arrays are
3149 dealt with in trans-array.c(gfc_conv_array_parameter). */
3150 if (e && e->ts.type == BT_DERIVED
3151 && e->ts.u.derived->attr.alloc_comp
3152 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3153 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3156 tmp = build_fold_indirect_ref_loc (input_location,
3158 parm_rank = e->rank;
3166 case (SCALAR_POINTER):
3167 tmp = build_fold_indirect_ref_loc (input_location,
3172 if (e->expr_type == EXPR_OP
3173 && e->value.op.op == INTRINSIC_PARENTHESES
3174 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3177 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3178 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3179 gfc_add_expr_to_block (&se->post, local_tmp);
3182 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3184 gfc_add_expr_to_block (&se->post, tmp);
3187 /* Add argument checking of passing an unallocated/NULL actual to
3188 a nonallocatable/nonpointer dummy. */
3190 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3192 symbol_attribute attr;
3196 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3197 attr = gfc_expr_attr (e);
3199 goto end_pointer_check;
3203 /* If the actual argument is an optional pointer/allocatable and
3204 the formal argument takes an nonpointer optional value,
3205 it is invalid to pass a non-present argument on, even
3206 though there is no technical reason for this in gfortran.
3207 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3208 tree present, null_ptr, type;
3210 if (attr.allocatable
3211 && (fsym == NULL || !fsym->attr.allocatable))
3212 asprintf (&msg, "Allocatable actual argument '%s' is not "
3213 "allocated or not present", e->symtree->n.sym->name);
3214 else if (attr.pointer
3215 && (fsym == NULL || !fsym->attr.pointer))
3216 asprintf (&msg, "Pointer actual argument '%s' is not "
3217 "associated or not present",
3218 e->symtree->n.sym->name);
3219 else if (attr.proc_pointer
3220 && (fsym == NULL || !fsym->attr.proc_pointer))
3221 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3222 "associated or not present",
3223 e->symtree->n.sym->name);
3225 goto end_pointer_check;
3227 present = gfc_conv_expr_present (e->symtree->n.sym);
3228 type = TREE_TYPE (present);
3229 present = fold_build2_loc (input_location, EQ_EXPR,
3230 boolean_type_node, present,
3232 null_pointer_node));
3233 type = TREE_TYPE (parmse.expr);
3234 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3235 boolean_type_node, parmse.expr,
3237 null_pointer_node));
3238 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3239 boolean_type_node, present, null_ptr);
3243 if (attr.allocatable
3244 && (fsym == NULL || !fsym->attr.allocatable))
3245 asprintf (&msg, "Allocatable actual argument '%s' is not "
3246 "allocated", e->symtree->n.sym->name);
3247 else if (attr.pointer
3248 && (fsym == NULL || !fsym->attr.pointer))
3249 asprintf (&msg, "Pointer actual argument '%s' is not "
3250 "associated", e->symtree->n.sym->name);
3251 else if (attr.proc_pointer
3252 && (fsym == NULL || !fsym->attr.proc_pointer))
3253 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3254 "associated", e->symtree->n.sym->name);
3256 goto end_pointer_check;
3259 cond = fold_build2_loc (input_location, EQ_EXPR,
3260 boolean_type_node, parmse.expr,
3261 fold_convert (TREE_TYPE (parmse.expr),
3262 null_pointer_node));
3265 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3272 /* Character strings are passed as two parameters, a length and a
3273 pointer - except for Bind(c) which only passes the pointer. */
3274 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3275 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3277 VEC_safe_push (tree, gc, arglist, parmse.expr);
3279 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3286 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3287 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3288 else if (ts.type == BT_CHARACTER)
3290 if (ts.u.cl->length == NULL)
3292 /* Assumed character length results are not allowed by 5.1.1.5 of the
3293 standard and are trapped in resolve.c; except in the case of SPREAD
3294 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3295 we take the character length of the first argument for the result.
3296 For dummies, we have to look through the formal argument list for
3297 this function and use the character length found there.*/
3298 if (!sym->attr.dummy)
3299 cl.backend_decl = VEC_index (tree, stringargs, 0);
3302 formal = sym->ns->proc_name->formal;
3303 for (; formal; formal = formal->next)
3304 if (strcmp (formal->sym->name, sym->name) == 0)
3305 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3312 /* Calculate the length of the returned string. */
3313 gfc_init_se (&parmse, NULL);
3314 if (need_interface_mapping)
3315 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3317 gfc_conv_expr (&parmse, ts.u.cl->length);
3318 gfc_add_block_to_block (&se->pre, &parmse.pre);
3319 gfc_add_block_to_block (&se->post, &parmse.post);
3321 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3322 tmp = fold_build2_loc (input_location, MAX_EXPR,
3323 gfc_charlen_type_node, tmp,
3324 build_int_cst (gfc_charlen_type_node, 0));
3325 cl.backend_decl = tmp;
3328 /* Set up a charlen structure for it. */
3333 len = cl.backend_decl;
3336 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3337 || (!comp && gfc_return_by_reference (sym));
3340 if (se->direct_byref)
3342 /* Sometimes, too much indirection can be applied; e.g. for
3343 function_result = array_valued_recursive_function. */
3344 if (TREE_TYPE (TREE_TYPE (se->expr))
3345 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3346 && GFC_DESCRIPTOR_TYPE_P
3347 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3348 se->expr = build_fold_indirect_ref_loc (input_location,
3351 result = build_fold_indirect_ref_loc (input_location,
3353 VEC_safe_push (tree, gc, retargs, se->expr);
3355 else if (comp && comp->attr.dimension)
3357 gcc_assert (se->loop && info);
3359 /* Set the type of the array. */
3360 tmp = gfc_typenode_for_spec (&comp->ts);
3361 info->dimen = se->loop->dimen;
3363 /* Evaluate the bounds of the result, if known. */
3364 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3366 /* Create a temporary to store the result. In case the function
3367 returns a pointer, the temporary will be a shallow copy and
3368 mustn't be deallocated. */
3369 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3370 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3371 NULL_TREE, false, !comp->attr.pointer,
3372 callee_alloc, &se->ss->expr->where);
3374 /* Pass the temporary as the first argument. */
3375 result = info->descriptor;
3376 tmp = gfc_build_addr_expr (NULL_TREE, result);
3377 VEC_safe_push (tree, gc, retargs, tmp);
3379 else if (!comp && sym->result->attr.dimension)
3381 gcc_assert (se->loop && info);
3383 /* Set the type of the array. */
3384 tmp = gfc_typenode_for_spec (&ts);
3385 info->dimen = se->loop->dimen;
3387 /* Evaluate the bounds of the result, if known. */
3388 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3390 /* Create a temporary to store the result. In case the function
3391 returns a pointer, the temporary will be a shallow copy and
3392 mustn't be deallocated. */
3393 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3394 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3395 NULL_TREE, false, !sym->attr.pointer,
3396 callee_alloc, &se->ss->expr->where);
3398 /* Pass the temporary as the first argument. */
3399 result = info->descriptor;
3400 tmp = gfc_build_addr_expr (NULL_TREE, result);
3401 VEC_safe_push (tree, gc, retargs, tmp);
3403 else if (ts.type == BT_CHARACTER)
3405 /* Pass the string length. */
3406 type = gfc_get_character_type (ts.kind, ts.u.cl);
3407 type = build_pointer_type (type);
3409 /* Return an address to a char[0:len-1]* temporary for
3410 character pointers. */
3411 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3412 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3414 var = gfc_create_var (type, "pstr");
3416 if ((!comp && sym->attr.allocatable)
3417 || (comp && comp->attr.allocatable))
3418 gfc_add_modify (&se->pre, var,
3419 fold_convert (TREE_TYPE (var),
3420 null_pointer_node));
3422 /* Provide an address expression for the function arguments. */
3423 var = gfc_build_addr_expr (NULL_TREE, var);
3426 var = gfc_conv_string_tmp (se, type, len);
3428 VEC_safe_push (tree, gc, retargs, var);
3432 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3434 type = gfc_get_complex_type (ts.kind);
3435 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3436 VEC_safe_push (tree, gc, retargs, var);
3439 /* Add the string length to the argument list. */
3440 if (ts.type == BT_CHARACTER)
3441 VEC_safe_push (tree, gc, retargs, len);
3443 gfc_free_interface_mapping (&mapping);
3445 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3446 arglen = (VEC_length (tree, arglist)
3447 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3448 VEC_reserve_exact (tree, gc, retargs, arglen);
3450 /* Add the return arguments. */
3451 VEC_splice (tree, retargs, arglist);
3453 /* Add the hidden string length parameters to the arguments. */
3454 VEC_splice (tree, retargs, stringargs);
3456 /* We may want to append extra arguments here. This is used e.g. for
3457 calls to libgfortran_matmul_??, which need extra information. */
3458 if (!VEC_empty (tree, append_args))
3459 VEC_splice (tree, retargs, append_args);
3462 /* Generate the actual call. */
3463 conv_function_val (se, sym, expr);
3465 /* If there are alternate return labels, function type should be
3466 integer. Can't modify the type in place though, since it can be shared
3467 with other functions. For dummy arguments, the typing is done to
3468 to this result, even if it has to be repeated for each call. */
3469 if (has_alternate_specifier
3470 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3472 if (!sym->attr.dummy)
3474 TREE_TYPE (sym->backend_decl)
3475 = build_function_type (integer_type_node,
3476 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3477 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3480 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3483 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3484 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3486 /* If we have a pointer function, but we don't want a pointer, e.g.
3489 where f is pointer valued, we have to dereference the result. */
3490 if (!se->want_pointer && !byref
3491 && (sym->attr.pointer || sym->attr.allocatable)
3492 && !gfc_is_proc_ptr_comp (expr, NULL))
3493 se->expr = build_fold_indirect_ref_loc (input_location,
3496 /* f2c calling conventions require a scalar default real function to
3497 return a double precision result. Convert this back to default
3498 real. We only care about the cases that can happen in Fortran 77.
3500 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3501 && sym->ts.kind == gfc_default_real_kind
3502 && !sym->attr.always_explicit)
3503 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3505 /* A pure function may still have side-effects - it may modify its
3507 TREE_SIDE_EFFECTS (se->expr) = 1;
3509 if (!sym->attr.pure)
3510 TREE_SIDE_EFFECTS (se->expr) = 1;
3515 /* Add the function call to the pre chain. There is no expression. */
3516 gfc_add_expr_to_block (&se->pre, se->expr);
3517 se->expr = NULL_TREE;
3519 if (!se->direct_byref)
3521 if (sym->attr.dimension || (comp && comp->attr.dimension))
3523 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3525 /* Check the data pointer hasn't been modified. This would
3526 happen in a function returning a pointer. */
3527 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3528 tmp = fold_build2_loc (input_location, NE_EXPR,
3531 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3534 se->expr = info->descriptor;
3535 /* Bundle in the string length. */
3536 se->string_length = len;
3538 else if (ts.type == BT_CHARACTER)
3540 /* Dereference for character pointer results. */
3541 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3542 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3543 se->expr = build_fold_indirect_ref_loc (input_location, var);
3547 se->string_length = len;
3551 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3552 se->expr = build_fold_indirect_ref_loc (input_location, var);
3557 /* Follow the function call with the argument post block. */
3560 gfc_add_block_to_block (&se->pre, &post);
3562 /* Transformational functions of derived types with allocatable
3563 components must have the result allocatable components copied. */
3564 arg = expr->value.function.actual;
3565 if (result && arg && expr->rank
3566 && expr->value.function.isym
3567 && expr->value.function.isym->transformational
3568 && arg->expr->ts.type == BT_DERIVED
3569 && arg->expr->ts.u.derived->attr.alloc_comp)
3572 /* Copy the allocatable components. We have to use a
3573 temporary here to prevent source allocatable components
3574 from being corrupted. */
3575 tmp2 = gfc_evaluate_now (result, &se->pre);
3576 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3577 result, tmp2, expr->rank);
3578 gfc_add_expr_to_block (&se->pre, tmp);
3579 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3581 gfc_add_expr_to_block (&se->pre, tmp);
3583 /* Finally free the temporary's data field. */
3584 tmp = gfc_conv_descriptor_data_get (tmp2);
3585 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3586 gfc_add_expr_to_block (&se->pre, tmp);
3590 gfc_add_block_to_block (&se->post, &post);
3592 return has_alternate_specifier;
3596 /* Fill a character string with spaces. */
3599 fill_with_spaces (tree start, tree type, tree size)
3601 stmtblock_t block, loop;
3602 tree i, el, exit_label, cond, tmp;
3604 /* For a simple char type, we can call memset(). */
3605 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3606 return build_call_expr_loc (input_location,
3607 built_in_decls[BUILT_IN_MEMSET], 3, start,
3608 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3609 lang_hooks.to_target_charset (' ')),
3612 /* Otherwise, we use a loop:
3613 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3617 /* Initialize variables. */
3618 gfc_init_block (&block);
3619 i = gfc_create_var (sizetype, "i");
3620 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3621 el = gfc_create_var (build_pointer_type (type), "el");
3622 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3623 exit_label = gfc_build_label_decl (NULL_TREE);
3624 TREE_USED (exit_label) = 1;
3628 gfc_init_block (&loop);
3630 /* Exit condition. */
3631 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3632 fold_convert (sizetype, integer_zero_node));
3633 tmp = build1_v (GOTO_EXPR, exit_label);
3634 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3635 build_empty_stmt (input_location));
3636 gfc_add_expr_to_block (&loop, tmp);
3639 gfc_add_modify (&loop,
3640 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3641 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3643 /* Increment loop variables. */
3644 gfc_add_modify (&loop, i,
3645 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3646 TYPE_SIZE_UNIT (type)));
3647 gfc_add_modify (&loop, el,
3648 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3649 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3651 /* Making the loop... actually loop! */
3652 tmp = gfc_finish_block (&loop);
3653 tmp = build1_v (LOOP_EXPR, tmp);
3654 gfc_add_expr_to_block (&block, tmp);
3656 /* The exit label. */
3657 tmp = build1_v (LABEL_EXPR, exit_label);
3658 gfc_add_expr_to_block (&block, tmp);
3661 return gfc_finish_block (&block);
3665 /* Generate code to copy a string. */
3668 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3669 int dkind, tree slength, tree src, int skind)
3671 tree tmp, dlen, slen;
3680 stmtblock_t tempblock;
3682 gcc_assert (dkind == skind);
3684 if (slength != NULL_TREE)
3686 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3687 ssc = gfc_string_to_single_character (slen, src, skind);
3691 slen = build_int_cst (size_type_node, 1);
3695 if (dlength != NULL_TREE)
3697 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3698 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3702 dlen = build_int_cst (size_type_node, 1);
3706 /* Assign directly if the types are compatible. */
3707 if (dsc != NULL_TREE && ssc != NULL_TREE
3708 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3710 gfc_add_modify (block, dsc, ssc);
3714 /* Do nothing if the destination length is zero. */
3715 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3716 build_int_cst (size_type_node, 0));
3718 /* The following code was previously in _gfortran_copy_string:
3720 // The two strings may overlap so we use memmove.
3722 copy_string (GFC_INTEGER_4 destlen, char * dest,
3723 GFC_INTEGER_4 srclen, const char * src)
3725 if (srclen >= destlen)
3727 // This will truncate if too long.
3728 memmove (dest, src, destlen);
3732 memmove (dest, src, srclen);
3734 memset (&dest[srclen], ' ', destlen - srclen);
3738 We're now doing it here for better optimization, but the logic
3741 /* For non-default character kinds, we have to multiply the string
3742 length by the base type size. */
3743 chartype = gfc_get_char_type (dkind);
3744 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3745 fold_convert (size_type_node, slen),
3746 fold_convert (size_type_node,
3747 TYPE_SIZE_UNIT (chartype)));
3748 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3749 fold_convert (size_type_node, dlen),
3750 fold_convert (size_type_node,
3751 TYPE_SIZE_UNIT (chartype)));
3754 dest = fold_convert (pvoid_type_node, dest);
3756 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3759 src = fold_convert (pvoid_type_node, src);
3761 src = gfc_build_addr_expr (pvoid_type_node, src);
3763 /* Truncate string if source is too long. */
3764 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3766 tmp2 = build_call_expr_loc (input_location,
3767 built_in_decls[BUILT_IN_MEMMOVE],
3768 3, dest, src, dlen);
3770 /* Else copy and pad with spaces. */
3771 tmp3 = build_call_expr_loc (input_location,
3772 built_in_decls[BUILT_IN_MEMMOVE],
3773 3, dest, src, slen);
3775 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3776 dest, fold_convert (sizetype, slen));
3777 tmp4 = fill_with_spaces (tmp4, chartype,
3778 fold_build2_loc (input_location, MINUS_EXPR,
3779 TREE_TYPE(dlen), dlen, slen));
3781 gfc_init_block (&tempblock);
3782 gfc_add_expr_to_block (&tempblock, tmp3);
3783 gfc_add_expr_to_block (&tempblock, tmp4);
3784 tmp3 = gfc_finish_block (&tempblock);
3786 /* The whole copy_string function is there. */
3787 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3789 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3790 build_empty_stmt (input_location));
3791 gfc_add_expr_to_block (block, tmp);
3795 /* Translate a statement function.
3796 The value of a statement function reference is obtained by evaluating the
3797 expression using the values of the actual arguments for the values of the
3798 corresponding dummy arguments. */
3801 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3805 gfc_formal_arglist *fargs;
3806 gfc_actual_arglist *args;
3809 gfc_saved_var *saved_vars;
3815 sym = expr->symtree->n.sym;
3816 args = expr->value.function.actual;
3817 gfc_init_se (&lse, NULL);
3818 gfc_init_se (&rse, NULL);
3821 for (fargs = sym->formal; fargs; fargs = fargs->next)
3823 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3824 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3826 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3828 /* Each dummy shall be specified, explicitly or implicitly, to be
3830 gcc_assert (fargs->sym->attr.dimension == 0);
3833 /* Create a temporary to hold the value. */
3834 type = gfc_typenode_for_spec (&fsym->ts);
3835 temp_vars[n] = gfc_create_var (type, fsym->name);
3837 if (fsym->ts.type == BT_CHARACTER)
3839 /* Copy string arguments. */
3842 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3843 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3845 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3846 tmp = gfc_build_addr_expr (build_pointer_type (type),
3849 gfc_conv_expr (&rse, args->expr);
3850 gfc_conv_string_parameter (&rse);
3851 gfc_add_block_to_block (&se->pre, &lse.pre);
3852 gfc_add_block_to_block (&se->pre, &rse.pre);
3854 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3855 rse.string_length, rse.expr, fsym->ts.kind);
3856 gfc_add_block_to_block (&se->pre, &lse.post);
3857 gfc_add_block_to_block (&se->pre, &rse.post);
3861 /* For everything else, just evaluate the expression. */
3862 gfc_conv_expr (&lse, args->expr);
3864 gfc_add_block_to_block (&se->pre, &lse.pre);
3865 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3866 gfc_add_block_to_block (&se->pre, &lse.post);
3872 /* Use the temporary variables in place of the real ones. */
3873 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3874 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3876 gfc_conv_expr (se, sym->value);
3878 if (sym->ts.type == BT_CHARACTER)
3880 gfc_conv_const_charlen (sym->ts.u.cl);
3882 /* Force the expression to the correct length. */
3883 if (!INTEGER_CST_P (se->string_length)
3884 || tree_int_cst_lt (se->string_length,
3885 sym->ts.u.cl->backend_decl))
3887 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3888 tmp = gfc_create_var (type, sym->name);
3889 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3890 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3891 sym->ts.kind, se->string_length, se->expr,
3895 se->string_length = sym->ts.u.cl->backend_decl;
3898 /* Restore the original variables. */
3899 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3900 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3901 gfc_free (saved_vars);
3905 /* Translate a function expression. */
3908 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3912 if (expr->value.function.isym)
3914 gfc_conv_intrinsic_function (se, expr);
3918 /* We distinguish statement functions from general functions to improve
3919 runtime performance. */
3920 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3922 gfc_conv_statement_function (se, expr);
3926 /* expr.value.function.esym is the resolved (specific) function symbol for
3927 most functions. However this isn't set for dummy procedures. */
3928 sym = expr->value.function.esym;
3930 sym = expr->symtree->n.sym;
3932 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3936 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3939 is_zero_initializer_p (gfc_expr * expr)
3941 if (expr->expr_type != EXPR_CONSTANT)
3944 /* We ignore constants with prescribed memory representations for now. */
3945 if (expr->representation.string)
3948 switch (expr->ts.type)
3951 return mpz_cmp_si (expr->value.integer, 0) == 0;
3954 return mpfr_zero_p (expr->value.real)
3955 && MPFR_SIGN (expr->value.real) >= 0;
3958 return expr->value.logical == 0;
3961 return mpfr_zero_p (mpc_realref (expr->value.complex))
3962 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3963 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3964 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3974 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3976 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3977 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3979 gfc_conv_tmp_array_ref (se);
3980 gfc_advance_se_ss_chain (se);
3984 /* Build a static initializer. EXPR is the expression for the initial value.
3985 The other parameters describe the variable of the component being
3986 initialized. EXPR may be null. */
3989 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3990 bool array, bool pointer, bool procptr)
3994 if (!(expr || pointer || procptr))
3997 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3998 (these are the only two iso_c_binding derived types that can be
3999 used as initialization expressions). If so, we need to modify
4000 the 'expr' to be that for a (void *). */
4001 if (expr != NULL && expr->ts.type == BT_DERIVED
4002 && expr->ts.is_iso_c && expr->ts.u.derived)
4004 gfc_symbol *derived = expr->ts.u.derived;
4006 /* The derived symbol has already been converted to a (void *). Use
4008 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4009 expr->ts.f90_type = derived->ts.f90_type;
4011 gfc_init_se (&se, NULL);
4012 gfc_conv_constant (&se, expr);
4013 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4017 if (array && !procptr)
4020 /* Arrays need special handling. */
4022 ctor = gfc_build_null_descriptor (type);
4023 /* Special case assigning an array to zero. */
4024 else if (is_zero_initializer_p (expr))
4025 ctor = build_constructor (type, NULL);
4027 ctor = gfc_conv_array_initializer (type, expr);
4028 TREE_STATIC (ctor) = 1;
4031 else if (pointer || procptr)
4033 if (!expr || expr->expr_type == EXPR_NULL)
4034 return fold_convert (type, null_pointer_node);
4037 gfc_init_se (&se, NULL);
4038 se.want_pointer = 1;
4039 gfc_conv_expr (&se, expr);
4040 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4050 gfc_init_se (&se, NULL);
4051 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4052 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4054 gfc_conv_structure (&se, expr, 1);
4055 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4056 TREE_STATIC (se.expr) = 1;
4061 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4062 TREE_STATIC (ctor) = 1;
4067 gfc_init_se (&se, NULL);
4068 gfc_conv_constant (&se, expr);
4069 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4076 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4088 gfc_start_block (&block);
4090 /* Initialize the scalarizer. */
4091 gfc_init_loopinfo (&loop);
4093 gfc_init_se (&lse, NULL);
4094 gfc_init_se (&rse, NULL);
4097 rss = gfc_walk_expr (expr);
4098 if (rss == gfc_ss_terminator)
4100 /* The rhs is scalar. Add a ss for the expression. */
4101 rss = gfc_get_ss ();
4102 rss->next = gfc_ss_terminator;
4103 rss->type = GFC_SS_SCALAR;
4107 /* Create a SS for the destination. */
4108 lss = gfc_get_ss ();
4109 lss->type = GFC_SS_COMPONENT;
4111 lss->shape = gfc_get_shape (cm->as->rank);
4112 lss->next = gfc_ss_terminator;
4113 lss->data.info.dimen = cm->as->rank;
4114 lss->data.info.descriptor = dest;
4115 lss->data.info.data = gfc_conv_array_data (dest);
4116 lss->data.info.offset = gfc_conv_array_offset (dest);
4117 for (n = 0; n < cm->as->rank; n++)
4119 lss->data.info.dim[n] = n;
4120 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4121 lss->data.info.stride[n] = gfc_index_one_node;
4123 mpz_init (lss->shape[n]);
4124 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4125 cm->as->lower[n]->value.integer);
4126 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4129 /* Associate the SS with the loop. */
4130 gfc_add_ss_to_loop (&loop, lss);
4131 gfc_add_ss_to_loop (&loop, rss);
4133 /* Calculate the bounds of the scalarization. */
4134 gfc_conv_ss_startstride (&loop);
4136 /* Setup the scalarizing loops. */
4137 gfc_conv_loop_setup (&loop, &expr->where);
4139 /* Setup the gfc_se structures. */
4140 gfc_copy_loopinfo_to_se (&lse, &loop);
4141 gfc_copy_loopinfo_to_se (&rse, &loop);
4144 gfc_mark_ss_chain_used (rss, 1);
4146 gfc_mark_ss_chain_used (lss, 1);
4148 /* Start the scalarized loop body. */
4149 gfc_start_scalarized_body (&loop, &body);
4151 gfc_conv_tmp_array_ref (&lse);
4152 if (cm->ts.type == BT_CHARACTER)
4153 lse.string_length = cm->ts.u.cl->backend_decl;
4155 gfc_conv_expr (&rse, expr);
4157 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4158 gfc_add_expr_to_block (&body, tmp);
4160 gcc_assert (rse.ss == gfc_ss_terminator);
4162 /* Generate the copying loops. */
4163 gfc_trans_scalarizing_loops (&loop, &body);
4165 /* Wrap the whole thing up. */
4166 gfc_add_block_to_block (&block, &loop.pre);
4167 gfc_add_block_to_block (&block, &loop.post);
4169 for (n = 0; n < cm->as->rank; n++)
4170 mpz_clear (lss->shape[n]);
4171 gfc_free (lss->shape);
4173 gfc_cleanup_loop (&loop);
4175 return gfc_finish_block (&block);
4180 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4191 gfc_expr *arg = NULL;
4193 gfc_start_block (&block);
4194 gfc_init_se (&se, NULL);
4196 /* Get the descriptor for the expressions. */
4197 rss = gfc_walk_expr (expr);
4198 se.want_pointer = 0;
4199 gfc_conv_expr_descriptor (&se, expr, rss);
4200 gfc_add_block_to_block (&block, &se.pre);
4201 gfc_add_modify (&block, dest, se.expr);
4203 /* Deal with arrays of derived types with allocatable components. */
4204 if (cm->ts.type == BT_DERIVED
4205 && cm->ts.u.derived->attr.alloc_comp)
4206 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4210 tmp = gfc_duplicate_allocatable (dest, se.expr,
4211 TREE_TYPE(cm->backend_decl),
4214 gfc_add_expr_to_block (&block, tmp);
4215 gfc_add_block_to_block (&block, &se.post);
4217 if (expr->expr_type != EXPR_VARIABLE)
4218 gfc_conv_descriptor_data_set (&block, se.expr,
4221 /* We need to know if the argument of a conversion function is a
4222 variable, so that the correct lower bound can be used. */
4223 if (expr->expr_type == EXPR_FUNCTION
4224 && expr->value.function.isym
4225 && expr->value.function.isym->conversion
4226 && expr->value.function.actual->expr
4227 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4228 arg = expr->value.function.actual->expr;
4230 /* Obtain the array spec of full array references. */
4232 as = gfc_get_full_arrayspec_from_expr (arg);
4234 as = gfc_get_full_arrayspec_from_expr (expr);
4236 /* Shift the lbound and ubound of temporaries to being unity,
4237 rather than zero, based. Always calculate the offset. */
4238 offset = gfc_conv_descriptor_offset_get (dest);
4239 gfc_add_modify (&block, offset, gfc_index_zero_node);
4240 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4242 for (n = 0; n < expr->rank; n++)
4247 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4248 TODO It looks as if gfc_conv_expr_descriptor should return
4249 the correct bounds and that the following should not be
4250 necessary. This would simplify gfc_conv_intrinsic_bound
4252 if (as && as->lower[n])
4255 gfc_init_se (&lbse, NULL);
4256 gfc_conv_expr (&lbse, as->lower[n]);
4257 gfc_add_block_to_block (&block, &lbse.pre);
4258 lbound = gfc_evaluate_now (lbse.expr, &block);
4262 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4263 lbound = gfc_conv_descriptor_lbound_get (tmp,
4267 lbound = gfc_conv_descriptor_lbound_get (dest,
4270 lbound = gfc_index_one_node;
4272 lbound = fold_convert (gfc_array_index_type, lbound);
4274 /* Shift the bounds and set the offset accordingly. */
4275 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4276 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4277 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4278 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4280 gfc_conv_descriptor_ubound_set (&block, dest,
4281 gfc_rank_cst[n], tmp);
4282 gfc_conv_descriptor_lbound_set (&block, dest,
4283 gfc_rank_cst[n], lbound);
4285 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4286 gfc_conv_descriptor_lbound_get (dest,
4288 gfc_conv_descriptor_stride_get (dest,
4290 gfc_add_modify (&block, tmp2, tmp);
4291 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4293 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4298 /* If a conversion expression has a null data pointer
4299 argument, nullify the allocatable component. */
4303 if (arg->symtree->n.sym->attr.allocatable
4304 || arg->symtree->n.sym->attr.pointer)
4306 non_null_expr = gfc_finish_block (&block);
4307 gfc_start_block (&block);
4308 gfc_conv_descriptor_data_set (&block, dest,
4310 null_expr = gfc_finish_block (&block);
4311 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4312 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4313 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4314 return build3_v (COND_EXPR, tmp,
4315 null_expr, non_null_expr);
4319 return gfc_finish_block (&block);
4323 /* Assign a single component of a derived type constructor. */
4326 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4334 gfc_start_block (&block);
4336 if (cm->attr.pointer)
4338 gfc_init_se (&se, NULL);
4339 /* Pointer component. */
4340 if (cm->attr.dimension)
4342 /* Array pointer. */
4343 if (expr->expr_type == EXPR_NULL)
4344 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4347 rss = gfc_walk_expr (expr);
4348 se.direct_byref = 1;
4350 gfc_conv_expr_descriptor (&se, expr, rss);
4351 gfc_add_block_to_block (&block, &se.pre);
4352 gfc_add_block_to_block (&block, &se.post);
4357 /* Scalar pointers. */
4358 se.want_pointer = 1;
4359 gfc_conv_expr (&se, expr);
4360 gfc_add_block_to_block (&block, &se.pre);
4361 gfc_add_modify (&block, dest,
4362 fold_convert (TREE_TYPE (dest), se.expr));
4363 gfc_add_block_to_block (&block, &se.post);
4366 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4368 /* NULL initialization for CLASS components. */
4369 tmp = gfc_trans_structure_assign (dest,
4370 gfc_class_null_initializer (&cm->ts));
4371 gfc_add_expr_to_block (&block, tmp);
4373 else if (cm->attr.dimension)
4375 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4376 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4377 else if (cm->attr.allocatable)
4379 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4380 gfc_add_expr_to_block (&block, tmp);
4384 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4385 gfc_add_expr_to_block (&block, tmp);
4388 else if (expr->ts.type == BT_DERIVED)
4390 if (expr->expr_type != EXPR_STRUCTURE)
4392 gfc_init_se (&se, NULL);
4393 gfc_conv_expr (&se, expr);
4394 gfc_add_block_to_block (&block, &se.pre);
4395 gfc_add_modify (&block, dest,
4396 fold_convert (TREE_TYPE (dest), se.expr));
4397 gfc_add_block_to_block (&block, &se.post);
4401 /* Nested constructors. */
4402 tmp = gfc_trans_structure_assign (dest, expr);
4403 gfc_add_expr_to_block (&block, tmp);
4408 /* Scalar component. */
4409 gfc_init_se (&se, NULL);
4410 gfc_init_se (&lse, NULL);
4412 gfc_conv_expr (&se, expr);
4413 if (cm->ts.type == BT_CHARACTER)
4414 lse.string_length = cm->ts.u.cl->backend_decl;
4416 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4417 gfc_add_expr_to_block (&block, tmp);
4419 return gfc_finish_block (&block);
4422 /* Assign a derived type constructor to a variable. */
4425 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4433 gfc_start_block (&block);
4434 cm = expr->ts.u.derived->components;
4435 for (c = gfc_constructor_first (expr->value.constructor);
4436 c; c = gfc_constructor_next (c), cm = cm->next)
4438 /* Skip absent members in default initializers. */
4442 /* Handle c_null_(fun)ptr. */
4443 if (c && c->expr && c->expr->ts.is_iso_c)
4445 field = cm->backend_decl;
4446 tmp = fold_build3_loc (input_location, COMPONENT_REF,
4448 dest, field, NULL_TREE);
4449 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
4450 tmp, fold_convert (TREE_TYPE (tmp),
4451 null_pointer_node));
4452 gfc_add_expr_to_block (&block, tmp);
4456 field = cm->backend_decl;
4457 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4458 dest, field, NULL_TREE);
4459 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4460 gfc_add_expr_to_block (&block, tmp);
4462 return gfc_finish_block (&block);
4465 /* Build an expression for a constructor. If init is nonzero then
4466 this is part of a static variable initializer. */
4469 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4476 VEC(constructor_elt,gc) *v = NULL;
4478 gcc_assert (se->ss == NULL);
4479 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4480 type = gfc_typenode_for_spec (&expr->ts);
4484 /* Create a temporary variable and fill it in. */
4485 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4486 tmp = gfc_trans_structure_assign (se->expr, expr);
4487 gfc_add_expr_to_block (&se->pre, tmp);
4491 cm = expr->ts.u.derived->components;
4493 for (c = gfc_constructor_first (expr->value.constructor);
4494 c; c = gfc_constructor_next (c), cm = cm->next)
4496 /* Skip absent members in default initializers and allocatable
4497 components. Although the latter have a default initializer
4498 of EXPR_NULL,... by default, the static nullify is not needed
4499 since this is done every time we come into scope. */
4500 if (!c->expr || cm->attr.allocatable)
4503 if (strcmp (cm->name, "$size") == 0)
4505 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4506 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4508 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4509 && strcmp (cm->name, "$extends") == 0)
4513 vtabs = cm->initializer->symtree->n.sym;
4514 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4515 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4519 val = gfc_conv_initializer (c->expr, &cm->ts,
4520 TREE_TYPE (cm->backend_decl),
4521 cm->attr.dimension, cm->attr.pointer,
4522 cm->attr.proc_pointer);
4524 /* Append it to the constructor list. */
4525 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4528 se->expr = build_constructor (type, v);
4530 TREE_CONSTANT (se->expr) = 1;
4534 /* Translate a substring expression. */
4537 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4543 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4545 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4546 expr->value.character.length,
4547 expr->value.character.string);
4549 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4550 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4553 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4557 /* Entry point for expression translation. Evaluates a scalar quantity.
4558 EXPR is the expression to be translated, and SE is the state structure if
4559 called from within the scalarized. */
4562 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4564 if (se->ss && se->ss->expr == expr
4565 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4567 /* Substitute a scalar expression evaluated outside the scalarization
4569 se->expr = se->ss->data.scalar.expr;
4570 if (se->ss->type == GFC_SS_REFERENCE)
4571 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4572 se->string_length = se->ss->string_length;
4573 gfc_advance_se_ss_chain (se);
4577 /* We need to convert the expressions for the iso_c_binding derived types.
4578 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4579 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4580 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4581 updated to be an integer with a kind equal to the size of a (void *). */
4582 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4583 && expr->ts.u.derived->attr.is_iso_c)
4585 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4586 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4588 /* Set expr_type to EXPR_NULL, which will result in
4589 null_pointer_node being used below. */
4590 expr->expr_type = EXPR_NULL;
4594 /* Update the type/kind of the expression to be what the new
4595 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4596 expr->ts.type = expr->ts.u.derived->ts.type;
4597 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4598 expr->ts.kind = expr->ts.u.derived->ts.kind;
4602 switch (expr->expr_type)
4605 gfc_conv_expr_op (se, expr);
4609 gfc_conv_function_expr (se, expr);
4613 gfc_conv_constant (se, expr);
4617 gfc_conv_variable (se, expr);
4621 se->expr = null_pointer_node;
4624 case EXPR_SUBSTRING:
4625 gfc_conv_substring_expr (se, expr);
4628 case EXPR_STRUCTURE:
4629 gfc_conv_structure (se, expr, 0);
4633 gfc_conv_array_constructor_expr (se, expr);
4642 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4643 of an assignment. */
4645 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4647 gfc_conv_expr (se, expr);
4648 /* All numeric lvalues should have empty post chains. If not we need to
4649 figure out a way of rewriting an lvalue so that it has no post chain. */
4650 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4653 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4654 numeric expressions. Used for scalar values where inserting cleanup code
4657 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4661 gcc_assert (expr->ts.type != BT_CHARACTER);
4662 gfc_conv_expr (se, expr);
4665 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4666 gfc_add_modify (&se->pre, val, se->expr);
4668 gfc_add_block_to_block (&se->pre, &se->post);
4672 /* Helper to translate an expression and convert it to a particular type. */
4674 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4676 gfc_conv_expr_val (se, expr);
4677 se->expr = convert (type, se->expr);
4681 /* Converts an expression so that it can be passed by reference. Scalar
4685 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4689 if (se->ss && se->ss->expr == expr
4690 && se->ss->type == GFC_SS_REFERENCE)
4692 /* Returns a reference to the scalar evaluated outside the loop
4694 gfc_conv_expr (se, expr);
4698 if (expr->ts.type == BT_CHARACTER)
4700 gfc_conv_expr (se, expr);
4701 gfc_conv_string_parameter (se);
4705 if (expr->expr_type == EXPR_VARIABLE)
4707 se->want_pointer = 1;
4708 gfc_conv_expr (se, expr);
4711 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4712 gfc_add_modify (&se->pre, var, se->expr);
4713 gfc_add_block_to_block (&se->pre, &se->post);
4719 if (expr->expr_type == EXPR_FUNCTION
4720 && ((expr->value.function.esym
4721 && expr->value.function.esym->result->attr.pointer
4722 && !expr->value.function.esym->result->attr.dimension)
4723 || (!expr->value.function.esym
4724 && expr->symtree->n.sym->attr.pointer
4725 && !expr->symtree->n.sym->attr.dimension)))
4727 se->want_pointer = 1;
4728 gfc_conv_expr (se, expr);
4729 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4730 gfc_add_modify (&se->pre, var, se->expr);
4736 gfc_conv_expr (se, expr);
4738 /* Create a temporary var to hold the value. */
4739 if (TREE_CONSTANT (se->expr))
4741 tree tmp = se->expr;
4742 STRIP_TYPE_NOPS (tmp);
4743 var = build_decl (input_location,
4744 CONST_DECL, NULL, TREE_TYPE (tmp));
4745 DECL_INITIAL (var) = tmp;
4746 TREE_STATIC (var) = 1;
4751 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4752 gfc_add_modify (&se->pre, var, se->expr);
4754 gfc_add_block_to_block (&se->pre, &se->post);
4756 /* Take the address of that value. */
4757 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4762 gfc_trans_pointer_assign (gfc_code * code)
4764 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4768 /* Generate code for a pointer assignment. */
4771 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4782 gfc_start_block (&block);
4784 gfc_init_se (&lse, NULL);
4786 lss = gfc_walk_expr (expr1);
4787 rss = gfc_walk_expr (expr2);
4788 if (lss == gfc_ss_terminator)
4790 /* Scalar pointers. */
4791 lse.want_pointer = 1;
4792 gfc_conv_expr (&lse, expr1);
4793 gcc_assert (rss == gfc_ss_terminator);
4794 gfc_init_se (&rse, NULL);
4795 rse.want_pointer = 1;
4796 gfc_conv_expr (&rse, expr2);
4798 if (expr1->symtree->n.sym->attr.proc_pointer
4799 && expr1->symtree->n.sym->attr.dummy)
4800 lse.expr = build_fold_indirect_ref_loc (input_location,
4803 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4804 && expr2->symtree->n.sym->attr.dummy)
4805 rse.expr = build_fold_indirect_ref_loc (input_location,
4808 gfc_add_block_to_block (&block, &lse.pre);
4809 gfc_add_block_to_block (&block, &rse.pre);
4811 /* Check character lengths if character expression. The test is only
4812 really added if -fbounds-check is enabled. */
4813 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4814 && !expr1->symtree->n.sym->attr.proc_pointer
4815 && !gfc_is_proc_ptr_comp (expr1, NULL))
4817 gcc_assert (expr2->ts.type == BT_CHARACTER);
4818 gcc_assert (lse.string_length && rse.string_length);
4819 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4820 lse.string_length, rse.string_length,
4824 gfc_add_modify (&block, lse.expr,
4825 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4827 gfc_add_block_to_block (&block, &rse.post);
4828 gfc_add_block_to_block (&block, &lse.post);
4835 tree strlen_rhs = NULL_TREE;
4837 /* Array pointer. Find the last reference on the LHS and if it is an
4838 array section ref, we're dealing with bounds remapping. In this case,
4839 set it to AR_FULL so that gfc_conv_expr_descriptor does
4840 not see it and process the bounds remapping afterwards explicitely. */
4841 for (remap = expr1->ref; remap; remap = remap->next)
4842 if (!remap->next && remap->type == REF_ARRAY
4843 && remap->u.ar.type == AR_SECTION)
4845 remap->u.ar.type = AR_FULL;
4848 rank_remap = (remap && remap->u.ar.end[0]);
4850 gfc_conv_expr_descriptor (&lse, expr1, lss);
4851 strlen_lhs = lse.string_length;
4854 if (expr2->expr_type == EXPR_NULL)
4856 /* Just set the data pointer to null. */
4857 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4859 else if (rank_remap)
4861 /* If we are rank-remapping, just get the RHS's descriptor and
4862 process this later on. */
4863 gfc_init_se (&rse, NULL);
4864 rse.direct_byref = 1;
4865 rse.byref_noassign = 1;
4866 gfc_conv_expr_descriptor (&rse, expr2, rss);
4867 strlen_rhs = rse.string_length;
4869 else if (expr2->expr_type == EXPR_VARIABLE)
4871 /* Assign directly to the LHS's descriptor. */
4872 lse.direct_byref = 1;
4873 gfc_conv_expr_descriptor (&lse, expr2, rss);
4874 strlen_rhs = lse.string_length;
4876 /* If this is a subreference array pointer assignment, use the rhs
4877 descriptor element size for the lhs span. */
4878 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4880 decl = expr1->symtree->n.sym->backend_decl;
4881 gfc_init_se (&rse, NULL);
4882 rse.descriptor_only = 1;
4883 gfc_conv_expr (&rse, expr2);
4884 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4885 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4886 if (!INTEGER_CST_P (tmp))
4887 gfc_add_block_to_block (&lse.post, &rse.pre);
4888 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4893 /* Assign to a temporary descriptor and then copy that
4894 temporary to the pointer. */
4895 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4898 lse.direct_byref = 1;
4899 gfc_conv_expr_descriptor (&lse, expr2, rss);
4900 strlen_rhs = lse.string_length;
4901 gfc_add_modify (&lse.pre, desc, tmp);
4904 gfc_add_block_to_block (&block, &lse.pre);
4906 gfc_add_block_to_block (&block, &rse.pre);
4908 /* If we do bounds remapping, update LHS descriptor accordingly. */
4912 gcc_assert (remap->u.ar.dimen == expr1->rank);
4916 /* Do rank remapping. We already have the RHS's descriptor
4917 converted in rse and now have to build the correct LHS
4918 descriptor for it. */
4922 tree lbound, ubound;
4925 dtype = gfc_conv_descriptor_dtype (desc);
4926 tmp = gfc_get_dtype (TREE_TYPE (desc));
4927 gfc_add_modify (&block, dtype, tmp);
4929 /* Copy data pointer. */
4930 data = gfc_conv_descriptor_data_get (rse.expr);
4931 gfc_conv_descriptor_data_set (&block, desc, data);
4933 /* Copy offset but adjust it such that it would correspond
4934 to a lbound of zero. */
4935 offs = gfc_conv_descriptor_offset_get (rse.expr);
4936 for (dim = 0; dim < expr2->rank; ++dim)
4938 stride = gfc_conv_descriptor_stride_get (rse.expr,
4940 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
4942 tmp = fold_build2_loc (input_location, MULT_EXPR,
4943 gfc_array_index_type, stride, lbound);
4944 offs = fold_build2_loc (input_location, PLUS_EXPR,
4945 gfc_array_index_type, offs, tmp);
4947 gfc_conv_descriptor_offset_set (&block, desc, offs);
4949 /* Set the bounds as declared for the LHS and calculate strides as
4950 well as another offset update accordingly. */
4951 stride = gfc_conv_descriptor_stride_get (rse.expr,
4953 for (dim = 0; dim < expr1->rank; ++dim)
4958 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
4960 /* Convert declared bounds. */
4961 gfc_init_se (&lower_se, NULL);
4962 gfc_init_se (&upper_se, NULL);
4963 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
4964 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
4966 gfc_add_block_to_block (&block, &lower_se.pre);
4967 gfc_add_block_to_block (&block, &upper_se.pre);
4969 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
4970 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
4972 lbound = gfc_evaluate_now (lbound, &block);
4973 ubound = gfc_evaluate_now (ubound, &block);
4975 gfc_add_block_to_block (&block, &lower_se.post);
4976 gfc_add_block_to_block (&block, &upper_se.post);
4978 /* Set bounds in descriptor. */
4979 gfc_conv_descriptor_lbound_set (&block, desc,
4980 gfc_rank_cst[dim], lbound);
4981 gfc_conv_descriptor_ubound_set (&block, desc,
4982 gfc_rank_cst[dim], ubound);
4985 stride = gfc_evaluate_now (stride, &block);
4986 gfc_conv_descriptor_stride_set (&block, desc,
4987 gfc_rank_cst[dim], stride);
4989 /* Update offset. */
4990 offs = gfc_conv_descriptor_offset_get (desc);
4991 tmp = fold_build2_loc (input_location, MULT_EXPR,
4992 gfc_array_index_type, lbound, stride);
4993 offs = fold_build2_loc (input_location, MINUS_EXPR,
4994 gfc_array_index_type, offs, tmp);
4995 offs = gfc_evaluate_now (offs, &block);
4996 gfc_conv_descriptor_offset_set (&block, desc, offs);
4998 /* Update stride. */
4999 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5000 stride = fold_build2_loc (input_location, MULT_EXPR,
5001 gfc_array_index_type, stride, tmp);
5006 /* Bounds remapping. Just shift the lower bounds. */
5008 gcc_assert (expr1->rank == expr2->rank);
5010 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5014 gcc_assert (remap->u.ar.start[dim]);
5015 gcc_assert (!remap->u.ar.end[dim]);
5016 gfc_init_se (&lbound_se, NULL);
5017 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5019 gfc_add_block_to_block (&block, &lbound_se.pre);
5020 gfc_conv_shift_descriptor_lbound (&block, desc,
5021 dim, lbound_se.expr);
5022 gfc_add_block_to_block (&block, &lbound_se.post);
5027 /* Check string lengths if applicable. The check is only really added
5028 to the output code if -fbounds-check is enabled. */
5029 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5031 gcc_assert (expr2->ts.type == BT_CHARACTER);
5032 gcc_assert (strlen_lhs && strlen_rhs);
5033 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5034 strlen_lhs, strlen_rhs, &block);
5037 /* If rank remapping was done, check with -fcheck=bounds that
5038 the target is at least as large as the pointer. */
5039 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5045 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5046 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5048 lsize = gfc_evaluate_now (lsize, &block);
5049 rsize = gfc_evaluate_now (rsize, &block);
5050 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5053 msg = _("Target of rank remapping is too small (%ld < %ld)");
5054 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5058 gfc_add_block_to_block (&block, &lse.post);
5060 gfc_add_block_to_block (&block, &rse.post);
5063 return gfc_finish_block (&block);
5067 /* Makes sure se is suitable for passing as a function string parameter. */
5068 /* TODO: Need to check all callers of this function. It may be abused. */
5071 gfc_conv_string_parameter (gfc_se * se)
5075 if (TREE_CODE (se->expr) == STRING_CST)
5077 type = TREE_TYPE (TREE_TYPE (se->expr));
5078 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5082 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5084 if (TREE_CODE (se->expr) != INDIRECT_REF)
5086 type = TREE_TYPE (se->expr);
5087 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5091 type = gfc_get_character_type_len (gfc_default_character_kind,
5093 type = build_pointer_type (type);
5094 se->expr = gfc_build_addr_expr (type, se->expr);
5098 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5099 gcc_assert (se->string_length
5100 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
5104 /* Generate code for assignment of scalar variables. Includes character
5105 strings and derived types with allocatable components.
5106 If you know that the LHS has no allocations, set dealloc to false. */
5109 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5110 bool l_is_temp, bool r_is_var, bool dealloc)
5116 gfc_init_block (&block);
5118 if (ts.type == BT_CHARACTER)
5123 if (lse->string_length != NULL_TREE)
5125 gfc_conv_string_parameter (lse);
5126 gfc_add_block_to_block (&block, &lse->pre);
5127 llen = lse->string_length;
5130 if (rse->string_length != NULL_TREE)
5132 gcc_assert (rse->string_length != NULL_TREE);
5133 gfc_conv_string_parameter (rse);
5134 gfc_add_block_to_block (&block, &rse->pre);
5135 rlen = rse->string_length;
5138 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5139 rse->expr, ts.kind);
5141 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5145 /* Are the rhs and the lhs the same? */
5148 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5149 gfc_build_addr_expr (NULL_TREE, lse->expr),
5150 gfc_build_addr_expr (NULL_TREE, rse->expr));
5151 cond = gfc_evaluate_now (cond, &lse->pre);
5154 /* Deallocate the lhs allocated components as long as it is not
5155 the same as the rhs. This must be done following the assignment
5156 to prevent deallocating data that could be used in the rhs
5158 if (!l_is_temp && dealloc)
5160 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5161 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5163 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5165 gfc_add_expr_to_block (&lse->post, tmp);
5168 gfc_add_block_to_block (&block, &rse->pre);
5169 gfc_add_block_to_block (&block, &lse->pre);
5171 gfc_add_modify (&block, lse->expr,
5172 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5174 /* Do a deep copy if the rhs is a variable, if it is not the
5178 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5179 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5181 gfc_add_expr_to_block (&block, tmp);
5184 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5186 gfc_add_block_to_block (&block, &lse->pre);
5187 gfc_add_block_to_block (&block, &rse->pre);
5188 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5189 TREE_TYPE (lse->expr), rse->expr);
5190 gfc_add_modify (&block, lse->expr, tmp);
5194 gfc_add_block_to_block (&block, &lse->pre);
5195 gfc_add_block_to_block (&block, &rse->pre);
5197 gfc_add_modify (&block, lse->expr,
5198 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5201 gfc_add_block_to_block (&block, &lse->post);
5202 gfc_add_block_to_block (&block, &rse->post);
5204 return gfc_finish_block (&block);
5208 /* There are quite a lot of restrictions on the optimisation in using an
5209 array function assign without a temporary. */
5212 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5215 bool seen_array_ref;
5217 gfc_symbol *sym = expr1->symtree->n.sym;
5219 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5220 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5223 /* Elemental functions are scalarized so that they don't need a
5224 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5225 they would need special treatment in gfc_trans_arrayfunc_assign. */
5226 if (expr2->value.function.esym != NULL
5227 && expr2->value.function.esym->attr.elemental)
5230 /* Need a temporary if rhs is not FULL or a contiguous section. */
5231 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5234 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5235 if (gfc_ref_needs_temporary_p (expr1->ref))
5238 /* Functions returning pointers need temporaries. */
5239 if (expr2->symtree->n.sym->attr.pointer
5240 || expr2->symtree->n.sym->attr.allocatable)
5243 /* Character array functions need temporaries unless the
5244 character lengths are the same. */
5245 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5247 if (expr1->ts.u.cl->length == NULL
5248 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5251 if (expr2->ts.u.cl->length == NULL
5252 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5255 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5256 expr2->ts.u.cl->length->value.integer) != 0)
5260 /* Check that no LHS component references appear during an array
5261 reference. This is needed because we do not have the means to
5262 span any arbitrary stride with an array descriptor. This check
5263 is not needed for the rhs because the function result has to be
5265 seen_array_ref = false;
5266 for (ref = expr1->ref; ref; ref = ref->next)
5268 if (ref->type == REF_ARRAY)
5269 seen_array_ref= true;
5270 else if (ref->type == REF_COMPONENT && seen_array_ref)
5274 /* Check for a dependency. */
5275 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5276 expr2->value.function.esym,
5277 expr2->value.function.actual,
5281 /* If we have reached here with an intrinsic function, we do not
5282 need a temporary. */
5283 if (expr2->value.function.isym)
5286 /* If the LHS is a dummy, we need a temporary if it is not
5288 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5291 /* A PURE function can unconditionally be called without a temporary. */
5292 if (expr2->value.function.esym != NULL
5293 && expr2->value.function.esym->attr.pure)
5296 /* TODO a function that could correctly be declared PURE but is not
5297 could do with returning false as well. */
5299 if (!sym->attr.use_assoc
5300 && !sym->attr.in_common
5301 && !sym->attr.pointer
5302 && !sym->attr.target
5303 && expr2->value.function.esym)
5305 /* A temporary is not needed if the function is not contained and
5306 the variable is local or host associated and not a pointer or
5308 if (!expr2->value.function.esym->attr.contained)
5311 /* A temporary is not needed if the lhs has never been host
5312 associated and the procedure is contained. */
5313 else if (!sym->attr.host_assoc)
5316 /* A temporary is not needed if the variable is local and not
5317 a pointer, a target or a result. */
5319 && expr2->value.function.esym->ns == sym->ns->parent)
5323 /* Default to temporary use. */
5328 /* Try to translate array(:) = func (...), where func is a transformational
5329 array function, without using a temporary. Returns NULL if this isn't the
5333 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5337 gfc_component *comp = NULL;
5339 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5342 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5344 gcc_assert (expr2->value.function.isym
5345 || (gfc_is_proc_ptr_comp (expr2, &comp)
5346 && comp && comp->attr.dimension)
5347 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5348 && expr2->value.function.esym->result->attr.dimension));
5350 ss = gfc_walk_expr (expr1);
5351 gcc_assert (ss != gfc_ss_terminator);
5352 gfc_init_se (&se, NULL);
5353 gfc_start_block (&se.pre);
5354 se.want_pointer = 1;
5356 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5358 if (expr1->ts.type == BT_DERIVED
5359 && expr1->ts.u.derived->attr.alloc_comp)
5362 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5364 gfc_add_expr_to_block (&se.pre, tmp);
5367 se.direct_byref = 1;
5368 se.ss = gfc_walk_expr (expr2);
5369 gcc_assert (se.ss != gfc_ss_terminator);
5370 gfc_conv_function_expr (&se, expr2);
5371 gfc_add_block_to_block (&se.pre, &se.post);
5373 return gfc_finish_block (&se.pre);
5377 /* Try to efficiently translate array(:) = 0. Return NULL if this
5381 gfc_trans_zero_assign (gfc_expr * expr)
5383 tree dest, len, type;
5387 sym = expr->symtree->n.sym;
5388 dest = gfc_get_symbol_decl (sym);
5390 type = TREE_TYPE (dest);
5391 if (POINTER_TYPE_P (type))
5392 type = TREE_TYPE (type);
5393 if (!GFC_ARRAY_TYPE_P (type))
5396 /* Determine the length of the array. */
5397 len = GFC_TYPE_ARRAY_SIZE (type);
5398 if (!len || TREE_CODE (len) != INTEGER_CST)
5401 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5402 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5403 fold_convert (gfc_array_index_type, tmp));
5405 /* If we are zeroing a local array avoid taking its address by emitting
5407 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5408 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5409 dest, build_constructor (TREE_TYPE (dest), NULL));
5411 /* Convert arguments to the correct types. */
5412 dest = fold_convert (pvoid_type_node, dest);
5413 len = fold_convert (size_type_node, len);
5415 /* Construct call to __builtin_memset. */
5416 tmp = build_call_expr_loc (input_location,
5417 built_in_decls[BUILT_IN_MEMSET],
5418 3, dest, integer_zero_node, len);
5419 return fold_convert (void_type_node, tmp);
5423 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5424 that constructs the call to __builtin_memcpy. */
5427 gfc_build_memcpy_call (tree dst, tree src, tree len)
5431 /* Convert arguments to the correct types. */
5432 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5433 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5435 dst = fold_convert (pvoid_type_node, dst);
5437 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5438 src = gfc_build_addr_expr (pvoid_type_node, src);
5440 src = fold_convert (pvoid_type_node, src);
5442 len = fold_convert (size_type_node, len);
5444 /* Construct call to __builtin_memcpy. */
5445 tmp = build_call_expr_loc (input_location,
5446 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5447 return fold_convert (void_type_node, tmp);
5451 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5452 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5453 source/rhs, both are gfc_full_array_ref_p which have been checked for
5457 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5459 tree dst, dlen, dtype;
5460 tree src, slen, stype;
5463 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5464 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5466 dtype = TREE_TYPE (dst);
5467 if (POINTER_TYPE_P (dtype))
5468 dtype = TREE_TYPE (dtype);
5469 stype = TREE_TYPE (src);
5470 if (POINTER_TYPE_P (stype))
5471 stype = TREE_TYPE (stype);
5473 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5476 /* Determine the lengths of the arrays. */
5477 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5478 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5480 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5481 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5482 dlen, fold_convert (gfc_array_index_type, tmp));
5484 slen = GFC_TYPE_ARRAY_SIZE (stype);
5485 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5487 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5488 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5489 slen, fold_convert (gfc_array_index_type, tmp));
5491 /* Sanity check that they are the same. This should always be
5492 the case, as we should already have checked for conformance. */
5493 if (!tree_int_cst_equal (slen, dlen))
5496 return gfc_build_memcpy_call (dst, src, dlen);
5500 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5501 this can't be done. EXPR1 is the destination/lhs for which
5502 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5505 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5507 unsigned HOST_WIDE_INT nelem;
5513 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5517 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5518 dtype = TREE_TYPE (dst);
5519 if (POINTER_TYPE_P (dtype))
5520 dtype = TREE_TYPE (dtype);
5521 if (!GFC_ARRAY_TYPE_P (dtype))
5524 /* Determine the lengths of the array. */
5525 len = GFC_TYPE_ARRAY_SIZE (dtype);
5526 if (!len || TREE_CODE (len) != INTEGER_CST)
5529 /* Confirm that the constructor is the same size. */
5530 if (compare_tree_int (len, nelem) != 0)
5533 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5534 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5535 fold_convert (gfc_array_index_type, tmp));
5537 stype = gfc_typenode_for_spec (&expr2->ts);
5538 src = gfc_build_constant_array_constructor (expr2, stype);
5540 stype = TREE_TYPE (src);
5541 if (POINTER_TYPE_P (stype))
5542 stype = TREE_TYPE (stype);
5544 return gfc_build_memcpy_call (dst, src, len);
5548 /* Tells whether the expression is to be treated as a variable reference. */
5551 expr_is_variable (gfc_expr *expr)
5555 if (expr->expr_type == EXPR_VARIABLE)
5558 arg = gfc_get_noncopying_intrinsic_argument (expr);
5561 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5562 return expr_is_variable (arg);
5569 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5570 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5571 init_flag indicates initialization expressions and dealloc that no
5572 deallocate prior assignment is needed (if in doubt, set true). */
5575 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5581 gfc_ss *lss_section;
5588 bool scalar_to_array;
5592 /* Assignment of the form lhs = rhs. */
5593 gfc_start_block (&block);
5595 gfc_init_se (&lse, NULL);
5596 gfc_init_se (&rse, NULL);
5599 lss = gfc_walk_expr (expr1);
5601 if (lss != gfc_ss_terminator)
5603 /* Allow the scalarizer to workshare array assignments. */
5604 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5605 ompws_flags |= OMPWS_SCALARIZER_WS;
5607 /* The assignment needs scalarization. */
5610 /* Find a non-scalar SS from the lhs. */
5611 while (lss_section != gfc_ss_terminator
5612 && lss_section->type != GFC_SS_SECTION)
5613 lss_section = lss_section->next;
5615 gcc_assert (lss_section != gfc_ss_terminator);
5617 /* Initialize the scalarizer. */
5618 gfc_init_loopinfo (&loop);
5621 rss = gfc_walk_expr (expr2);
5622 if (rss == gfc_ss_terminator)
5624 /* The rhs is scalar. Add a ss for the expression. */
5625 rss = gfc_get_ss ();
5626 rss->next = gfc_ss_terminator;
5627 rss->type = GFC_SS_SCALAR;
5630 /* Associate the SS with the loop. */
5631 gfc_add_ss_to_loop (&loop, lss);
5632 gfc_add_ss_to_loop (&loop, rss);
5634 /* Calculate the bounds of the scalarization. */
5635 gfc_conv_ss_startstride (&loop);
5636 /* Enable loop reversal. */
5637 for (n = 0; n < loop.dimen; n++)
5638 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5639 /* Resolve any data dependencies in the statement. */
5640 gfc_conv_resolve_dependencies (&loop, lss, rss);
5641 /* Setup the scalarizing loops. */
5642 gfc_conv_loop_setup (&loop, &expr2->where);
5644 /* Setup the gfc_se structures. */
5645 gfc_copy_loopinfo_to_se (&lse, &loop);
5646 gfc_copy_loopinfo_to_se (&rse, &loop);
5649 gfc_mark_ss_chain_used (rss, 1);
5650 if (loop.temp_ss == NULL)
5653 gfc_mark_ss_chain_used (lss, 1);
5657 lse.ss = loop.temp_ss;
5658 gfc_mark_ss_chain_used (lss, 3);
5659 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5662 /* Start the scalarized loop body. */
5663 gfc_start_scalarized_body (&loop, &body);
5666 gfc_init_block (&body);
5668 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5670 /* Translate the expression. */
5671 gfc_conv_expr (&rse, expr2);
5673 /* Stabilize a string length for temporaries. */
5674 if (expr2->ts.type == BT_CHARACTER)
5675 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5677 string_length = NULL_TREE;
5681 gfc_conv_tmp_array_ref (&lse);
5682 gfc_advance_se_ss_chain (&lse);
5683 if (expr2->ts.type == BT_CHARACTER)
5684 lse.string_length = string_length;
5687 gfc_conv_expr (&lse, expr1);
5689 /* Assignments of scalar derived types with allocatable components
5690 to arrays must be done with a deep copy and the rhs temporary
5691 must have its components deallocated afterwards. */
5692 scalar_to_array = (expr2->ts.type == BT_DERIVED
5693 && expr2->ts.u.derived->attr.alloc_comp
5694 && !expr_is_variable (expr2)
5695 && !gfc_is_constant_expr (expr2)
5696 && expr1->rank && !expr2->rank);
5697 if (scalar_to_array && dealloc)
5699 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5700 gfc_add_expr_to_block (&loop.post, tmp);
5703 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5704 l_is_temp || init_flag,
5705 expr_is_variable (expr2) || scalar_to_array,
5707 gfc_add_expr_to_block (&body, tmp);
5709 if (lss == gfc_ss_terminator)
5711 /* Use the scalar assignment as is. */
5712 gfc_add_block_to_block (&block, &body);
5716 gcc_assert (lse.ss == gfc_ss_terminator
5717 && rse.ss == gfc_ss_terminator);
5721 gfc_trans_scalarized_loop_boundary (&loop, &body);
5723 /* We need to copy the temporary to the actual lhs. */
5724 gfc_init_se (&lse, NULL);
5725 gfc_init_se (&rse, NULL);
5726 gfc_copy_loopinfo_to_se (&lse, &loop);
5727 gfc_copy_loopinfo_to_se (&rse, &loop);
5729 rse.ss = loop.temp_ss;
5732 gfc_conv_tmp_array_ref (&rse);
5733 gfc_advance_se_ss_chain (&rse);
5734 gfc_conv_expr (&lse, expr1);
5736 gcc_assert (lse.ss == gfc_ss_terminator
5737 && rse.ss == gfc_ss_terminator);
5739 if (expr2->ts.type == BT_CHARACTER)
5740 rse.string_length = string_length;
5742 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5743 false, false, dealloc);
5744 gfc_add_expr_to_block (&body, tmp);
5747 /* Generate the copying loops. */
5748 gfc_trans_scalarizing_loops (&loop, &body);
5750 /* Wrap the whole thing up. */
5751 gfc_add_block_to_block (&block, &loop.pre);
5752 gfc_add_block_to_block (&block, &loop.post);
5754 gfc_cleanup_loop (&loop);
5757 return gfc_finish_block (&block);
5761 /* Check whether EXPR is a copyable array. */
5764 copyable_array_p (gfc_expr * expr)
5766 if (expr->expr_type != EXPR_VARIABLE)
5769 /* First check it's an array. */
5770 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5773 if (!gfc_full_array_ref_p (expr->ref, NULL))
5776 /* Next check that it's of a simple enough type. */
5777 switch (expr->ts.type)
5789 return !expr->ts.u.derived->attr.alloc_comp;
5798 /* Translate an assignment. */
5801 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5806 /* Special case a single function returning an array. */
5807 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5809 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5814 /* Special case assigning an array to zero. */
5815 if (copyable_array_p (expr1)
5816 && is_zero_initializer_p (expr2))
5818 tmp = gfc_trans_zero_assign (expr1);
5823 /* Special case copying one array to another. */
5824 if (copyable_array_p (expr1)
5825 && copyable_array_p (expr2)
5826 && gfc_compare_types (&expr1->ts, &expr2->ts)
5827 && !gfc_check_dependency (expr1, expr2, 0))
5829 tmp = gfc_trans_array_copy (expr1, expr2);
5834 /* Special case initializing an array from a constant array constructor. */
5835 if (copyable_array_p (expr1)
5836 && expr2->expr_type == EXPR_ARRAY
5837 && gfc_compare_types (&expr1->ts, &expr2->ts))
5839 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5844 /* Fallback to the scalarizer to generate explicit loops. */
5845 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5849 gfc_trans_init_assign (gfc_code * code)
5851 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5855 gfc_trans_assign (gfc_code * code)
5857 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5861 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
5862 A MEMCPY is needed to copy the full data from the default initializer
5863 of the dynamic type. */
5866 gfc_trans_class_init_assign (gfc_code *code)
5870 gfc_se dst,src,memsz;
5871 gfc_expr *lhs,*rhs,*sz;
5873 gfc_start_block (&block);
5875 lhs = gfc_copy_expr (code->expr1);
5876 gfc_add_component_ref (lhs, "$data");
5878 rhs = gfc_copy_expr (code->expr1);
5879 gfc_add_component_ref (rhs, "$vptr");
5880 gfc_add_component_ref (rhs, "$def_init");
5882 sz = gfc_copy_expr (code->expr1);
5883 gfc_add_component_ref (sz, "$vptr");
5884 gfc_add_component_ref (sz, "$size");
5886 gfc_init_se (&dst, NULL);
5887 gfc_init_se (&src, NULL);
5888 gfc_init_se (&memsz, NULL);
5889 gfc_conv_expr (&dst, lhs);
5890 gfc_conv_expr (&src, rhs);
5891 gfc_conv_expr (&memsz, sz);
5892 gfc_add_block_to_block (&block, &src.pre);
5893 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
5894 gfc_add_expr_to_block (&block, tmp);
5896 return gfc_finish_block (&block);
5900 /* Translate an assignment to a CLASS object
5901 (pointer or ordinary assignment). */
5904 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5911 gfc_start_block (&block);
5913 if (expr2->ts.type != BT_CLASS)
5915 /* Insert an additional assignment which sets the '$vptr' field. */
5916 lhs = gfc_copy_expr (expr1);
5917 gfc_add_component_ref (lhs, "$vptr");
5918 if (expr2->ts.type == BT_DERIVED)
5922 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
5924 rhs = gfc_get_expr ();
5925 rhs->expr_type = EXPR_VARIABLE;
5926 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5930 else if (expr2->expr_type == EXPR_NULL)
5931 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5935 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5936 gfc_add_expr_to_block (&block, tmp);
5938 gfc_free_expr (lhs);
5939 gfc_free_expr (rhs);
5942 /* Do the actual CLASS assignment. */
5943 if (expr2->ts.type == BT_CLASS)
5946 gfc_add_component_ref (expr1, "$data");
5948 if (op == EXEC_ASSIGN)
5949 tmp = gfc_trans_assignment (expr1, expr2, false, true);
5950 else if (op == EXEC_POINTER_ASSIGN)
5951 tmp = gfc_trans_pointer_assignment (expr1, expr2);
5955 gfc_add_expr_to_block (&block, tmp);
5957 return gfc_finish_block (&block);