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"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
56 dest->loop = src->loop;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se * se, gfc_se * parent)
69 memset (se, 0, sizeof (gfc_se));
70 gfc_init_block (&se->pre);
71 gfc_init_block (&se->post);
76 gfc_copy_se_loopvars (se, parent);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se * se)
89 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se * se)
113 if (CONSTANT_CLASS_P (se->expr))
116 /* We need a temporary for this result. */
117 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118 gfc_add_modify (&se->pre, var, se->expr);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol * sym)
131 gcc_assert (sym->attr.dummy);
133 decl = gfc_get_symbol_decl (sym);
134 if (TREE_CODE (decl) != PARM_DECL)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
142 return fold_build2 (NE_EXPR, boolean_type_node, decl,
143 fold_convert (TREE_TYPE (decl), null_pointer_node));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
159 /* Create a temporary and convert it to the correct type. */
160 tmp = gfc_get_int_type (kind);
161 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
164 /* Test for a NULL value. */
165 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
166 fold_convert (TREE_TYPE (tmp), integer_one_node));
167 tmp = gfc_evaluate_now (tmp, &se->pre);
168 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
172 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
173 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
174 tmp = gfc_evaluate_now (tmp, &se->pre);
178 if (ts.type == BT_CHARACTER)
180 tmp = build_int_cst (gfc_charlen_type_node, 0);
181 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
182 present, se->string_length, tmp);
183 tmp = gfc_evaluate_now (tmp, &se->pre);
184 se->string_length = tmp;
190 /* Get the character length of an expression, looking through gfc_refs
194 gfc_get_expr_charlen (gfc_expr *e)
199 gcc_assert (e->expr_type == EXPR_VARIABLE
200 && e->ts.type == BT_CHARACTER);
202 length = NULL; /* To silence compiler warning. */
204 if (is_subref_array (e) && e->ts.u.cl->length)
207 gfc_init_se (&tmpse, NULL);
208 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
209 e->ts.u.cl->backend_decl = tmpse.expr;
213 /* First candidate: if the variable is of type CHARACTER, the
214 expression's length could be the length of the character
216 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
217 length = e->symtree->n.sym->ts.u.cl->backend_decl;
219 /* Look through the reference chain for component references. */
220 for (r = e->ref; r; r = r->next)
225 if (r->u.c.component->ts.type == BT_CHARACTER)
226 length = r->u.c.component->ts.u.cl->backend_decl;
234 /* We should never got substring references here. These will be
235 broken down by the scalarizer. */
241 gcc_assert (length != NULL);
246 /* For each character array constructor subexpression without a ts.u.cl->length,
247 replace it by its first element (if there aren't any elements, the length
248 should already be set to zero). */
251 flatten_array_ctors_without_strlen (gfc_expr* e)
253 gfc_actual_arglist* arg;
259 switch (e->expr_type)
263 flatten_array_ctors_without_strlen (e->value.op.op1);
264 flatten_array_ctors_without_strlen (e->value.op.op2);
268 /* TODO: Implement as with EXPR_FUNCTION when needed. */
272 for (arg = e->value.function.actual; arg; arg = arg->next)
273 flatten_array_ctors_without_strlen (arg->expr);
278 /* We've found what we're looking for. */
279 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
282 gcc_assert (e->value.constructor);
284 new_expr = e->value.constructor->expr;
285 e->value.constructor->expr = NULL;
287 flatten_array_ctors_without_strlen (new_expr);
288 gfc_replace_expr (e, new_expr);
292 /* Otherwise, fall through to handle constructor elements. */
294 for (c = e->value.constructor; c; c = c->next)
295 flatten_array_ctors_without_strlen (c->expr);
305 /* Generate code to initialize a string length variable. Returns the
306 value. For array constructors, cl->length might be NULL and in this case,
307 the first element of the constructor is needed. expr is the original
308 expression so we can access it but can be NULL if this is not needed. */
311 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
315 gfc_init_se (&se, NULL);
317 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
318 "flatten" array constructors by taking their first element; all elements
319 should be the same length or a cl->length should be present. */
325 expr_flat = gfc_copy_expr (expr);
326 flatten_array_ctors_without_strlen (expr_flat);
327 gfc_resolve_expr (expr_flat);
329 gfc_conv_expr (&se, expr_flat);
330 gfc_add_block_to_block (pblock, &se.pre);
331 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
333 gfc_free_expr (expr_flat);
337 /* Convert cl->length. */
339 gcc_assert (cl->length);
341 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
342 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
343 build_int_cst (gfc_charlen_type_node, 0));
344 gfc_add_block_to_block (pblock, &se.pre);
346 if (cl->backend_decl)
347 gfc_add_modify (pblock, cl->backend_decl, se.expr);
349 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
354 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
355 const char *name, locus *where)
364 type = gfc_get_character_type (kind, ref->u.ss.length);
365 type = build_pointer_type (type);
367 gfc_init_se (&start, se);
368 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
369 gfc_add_block_to_block (&se->pre, &start.pre);
371 if (integer_onep (start.expr))
372 gfc_conv_string_parameter (se);
377 /* Avoid multiple evaluation of substring start. */
378 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
379 start.expr = gfc_evaluate_now (start.expr, &se->pre);
381 /* Change the start of the string. */
382 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
385 tmp = build_fold_indirect_ref_loc (input_location,
387 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
388 se->expr = gfc_build_addr_expr (type, tmp);
391 /* Length = end + 1 - start. */
392 gfc_init_se (&end, se);
393 if (ref->u.ss.end == NULL)
394 end.expr = se->string_length;
397 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
398 gfc_add_block_to_block (&se->pre, &end.pre);
402 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
403 end.expr = gfc_evaluate_now (end.expr, &se->pre);
405 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
407 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
408 start.expr, end.expr);
410 /* Check lower bound. */
411 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
412 build_int_cst (gfc_charlen_type_node, 1));
413 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
416 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
417 "is less than one", name);
419 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
421 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
422 fold_convert (long_integer_type_node,
426 /* Check upper bound. */
427 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
429 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
432 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
433 "exceeds string length (%%ld)", name);
435 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
436 "exceeds string length (%%ld)");
437 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
438 fold_convert (long_integer_type_node, end.expr),
439 fold_convert (long_integer_type_node,
444 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
445 end.expr, start.expr);
446 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
447 build_int_cst (gfc_charlen_type_node, 1), tmp);
448 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
449 build_int_cst (gfc_charlen_type_node, 0));
450 se->string_length = tmp;
454 /* Convert a derived type component reference. */
457 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
464 c = ref->u.c.component;
466 gcc_assert (c->backend_decl);
468 field = c->backend_decl;
469 gcc_assert (TREE_CODE (field) == FIELD_DECL);
471 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
475 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
477 tmp = c->ts.u.cl->backend_decl;
478 /* Components must always be constant length. */
479 gcc_assert (tmp && INTEGER_CST_P (tmp));
480 se->string_length = tmp;
483 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
484 && c->ts.type != BT_CHARACTER)
485 || c->attr.proc_pointer)
486 se->expr = build_fold_indirect_ref_loc (input_location,
491 /* This function deals with component references to components of the
492 parent type for derived type extensons. */
494 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
502 c = ref->u.c.component;
504 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
505 parent.type = REF_COMPONENT;
508 parent.u.c.component = dt->components;
510 if (dt->backend_decl == NULL)
511 gfc_get_derived_type (dt);
513 if (dt->attr.extension && dt->components)
515 if (dt->attr.is_class)
516 cmp = dt->components;
518 cmp = dt->components->next;
519 /* Return if the component is not in the parent type. */
520 for (; cmp; cmp = cmp->next)
521 if (strcmp (c->name, cmp->name) == 0)
524 /* Otherwise build the reference and call self. */
525 gfc_conv_component_ref (se, &parent);
526 parent.u.c.sym = dt->components->ts.u.derived;
527 parent.u.c.component = c;
528 conv_parent_component_references (se, &parent);
532 /* Return the contents of a variable. Also handles reference/pointer
533 variables (all Fortran pointer references are implicit). */
536 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
543 bool alternate_entry;
546 sym = expr->symtree->n.sym;
549 /* Check that something hasn't gone horribly wrong. */
550 gcc_assert (se->ss != gfc_ss_terminator);
551 gcc_assert (se->ss->expr == expr);
553 /* A scalarized term. We already know the descriptor. */
554 se->expr = se->ss->data.info.descriptor;
555 se->string_length = se->ss->string_length;
556 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
557 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
562 tree se_expr = NULL_TREE;
564 se->expr = gfc_get_symbol_decl (sym);
566 /* Deal with references to a parent results or entries by storing
567 the current_function_decl and moving to the parent_decl. */
568 return_value = sym->attr.function && sym->result == sym;
569 alternate_entry = sym->attr.function && sym->attr.entry
570 && sym->result == sym;
571 entry_master = sym->attr.result
572 && sym->ns->proc_name->attr.entry_master
573 && !gfc_return_by_reference (sym->ns->proc_name);
574 parent_decl = DECL_CONTEXT (current_function_decl);
576 if ((se->expr == parent_decl && return_value)
577 || (sym->ns && sym->ns->proc_name
579 && sym->ns->proc_name->backend_decl == parent_decl
580 && (alternate_entry || entry_master)))
585 /* Special case for assigning the return value of a function.
586 Self recursive functions must have an explicit return value. */
587 if (return_value && (se->expr == current_function_decl || parent_flag))
588 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
590 /* Similarly for alternate entry points. */
591 else if (alternate_entry
592 && (sym->ns->proc_name->backend_decl == current_function_decl
595 gfc_entry_list *el = NULL;
597 for (el = sym->ns->entries; el; el = el->next)
600 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
605 else if (entry_master
606 && (sym->ns->proc_name->backend_decl == current_function_decl
608 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
613 /* Procedure actual arguments. */
614 else if (sym->attr.flavor == FL_PROCEDURE
615 && se->expr != current_function_decl)
617 if (!sym->attr.dummy && !sym->attr.proc_pointer)
619 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
620 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
626 /* Dereference the expression, where needed. Since characters
627 are entirely different from other types, they are treated
629 if (sym->ts.type == BT_CHARACTER)
631 /* Dereference character pointer dummy arguments
633 if ((sym->attr.pointer || sym->attr.allocatable)
635 || sym->attr.function
636 || sym->attr.result))
637 se->expr = build_fold_indirect_ref_loc (input_location,
641 else if (!sym->attr.value)
643 /* Dereference non-character scalar dummy arguments. */
644 if (sym->attr.dummy && !sym->attr.dimension)
645 se->expr = build_fold_indirect_ref_loc (input_location,
648 /* Dereference scalar hidden result. */
649 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
650 && (sym->attr.function || sym->attr.result)
651 && !sym->attr.dimension && !sym->attr.pointer
652 && !sym->attr.always_explicit)
653 se->expr = build_fold_indirect_ref_loc (input_location,
656 /* Dereference non-character pointer variables.
657 These must be dummies, results, or scalars. */
658 if ((sym->attr.pointer || sym->attr.allocatable)
660 || sym->attr.function
662 || !sym->attr.dimension))
663 se->expr = build_fold_indirect_ref_loc (input_location,
670 /* For character variables, also get the length. */
671 if (sym->ts.type == BT_CHARACTER)
673 /* If the character length of an entry isn't set, get the length from
674 the master function instead. */
675 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
676 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
678 se->string_length = sym->ts.u.cl->backend_decl;
679 gcc_assert (se->string_length);
687 /* Return the descriptor if that's what we want and this is an array
688 section reference. */
689 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
691 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
692 /* Return the descriptor for array pointers and allocations. */
694 && ref->next == NULL && (se->descriptor_only))
697 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
698 /* Return a pointer to an element. */
702 if (ref->u.c.sym->attr.extension)
703 conv_parent_component_references (se, ref);
705 gfc_conv_component_ref (se, ref);
709 gfc_conv_substring (se, ref, expr->ts.kind,
710 expr->symtree->name, &expr->where);
719 /* Pointer assignment, allocation or pass by reference. Arrays are handled
721 if (se->want_pointer)
723 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
724 gfc_conv_string_parameter (se);
726 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
731 /* Unary ops are easy... Or they would be if ! was a valid op. */
734 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
739 gcc_assert (expr->ts.type != BT_CHARACTER);
740 /* Initialize the operand. */
741 gfc_init_se (&operand, se);
742 gfc_conv_expr_val (&operand, expr->value.op.op1);
743 gfc_add_block_to_block (&se->pre, &operand.pre);
745 type = gfc_typenode_for_spec (&expr->ts);
747 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
748 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
749 All other unary operators have an equivalent GIMPLE unary operator. */
750 if (code == TRUTH_NOT_EXPR)
751 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
752 build_int_cst (type, 0));
754 se->expr = fold_build1 (code, type, operand.expr);
758 /* Expand power operator to optimal multiplications when a value is raised
759 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
760 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
761 Programming", 3rd Edition, 1998. */
763 /* This code is mostly duplicated from expand_powi in the backend.
764 We establish the "optimal power tree" lookup table with the defined size.
765 The items in the table are the exponents used to calculate the index
766 exponents. Any integer n less than the value can get an "addition chain",
767 with the first node being one. */
768 #define POWI_TABLE_SIZE 256
770 /* The table is from builtins.c. */
771 static const unsigned char powi_table[POWI_TABLE_SIZE] =
773 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
774 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
775 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
776 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
777 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
778 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
779 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
780 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
781 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
782 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
783 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
784 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
785 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
786 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
787 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
788 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
789 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
790 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
791 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
792 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
793 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
794 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
795 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
796 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
797 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
798 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
799 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
800 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
801 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
802 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
803 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
804 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
807 /* If n is larger than lookup table's max index, we use the "window
809 #define POWI_WINDOW_SIZE 3
811 /* Recursive function to expand the power operator. The temporary
812 values are put in tmpvar. The function returns tmpvar[1] ** n. */
814 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
821 if (n < POWI_TABLE_SIZE)
826 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
827 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
831 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
832 op0 = gfc_conv_powi (se, n - digit, tmpvar);
833 op1 = gfc_conv_powi (se, digit, tmpvar);
837 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
841 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
842 tmp = gfc_evaluate_now (tmp, &se->pre);
844 if (n < POWI_TABLE_SIZE)
851 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
852 return 1. Else return 0 and a call to runtime library functions
853 will have to be built. */
855 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
860 tree vartmp[POWI_TABLE_SIZE];
862 unsigned HOST_WIDE_INT n;
865 /* If exponent is too large, we won't expand it anyway, so don't bother
866 with large integer values. */
867 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
870 m = double_int_to_shwi (TREE_INT_CST (rhs));
871 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
872 of the asymmetric range of the integer type. */
873 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
875 type = TREE_TYPE (lhs);
876 sgn = tree_int_cst_sgn (rhs);
878 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
879 || optimize_size) && (m > 2 || m < -1))
885 se->expr = gfc_build_const (type, integer_one_node);
889 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
890 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
892 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
893 lhs, build_int_cst (TREE_TYPE (lhs), -1));
894 cond = fold_build2 (EQ_EXPR, boolean_type_node,
895 lhs, build_int_cst (TREE_TYPE (lhs), 1));
898 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
901 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
902 se->expr = fold_build3 (COND_EXPR, type,
903 tmp, build_int_cst (type, 1),
904 build_int_cst (type, 0));
908 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
909 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
910 build_int_cst (type, 0));
911 se->expr = fold_build3 (COND_EXPR, type,
912 cond, build_int_cst (type, 1), tmp);
916 memset (vartmp, 0, sizeof (vartmp));
920 tmp = gfc_build_const (type, integer_one_node);
921 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
924 se->expr = gfc_conv_powi (se, n, vartmp);
930 /* Power op (**). Constant integer exponent has special handling. */
933 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
935 tree gfc_int4_type_node;
942 gfc_init_se (&lse, se);
943 gfc_conv_expr_val (&lse, expr->value.op.op1);
944 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
945 gfc_add_block_to_block (&se->pre, &lse.pre);
947 gfc_init_se (&rse, se);
948 gfc_conv_expr_val (&rse, expr->value.op.op2);
949 gfc_add_block_to_block (&se->pre, &rse.pre);
951 if (expr->value.op.op2->ts.type == BT_INTEGER
952 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
953 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
956 gfc_int4_type_node = gfc_get_int_type (4);
958 kind = expr->value.op.op1->ts.kind;
959 switch (expr->value.op.op2->ts.type)
962 ikind = expr->value.op.op2->ts.kind;
967 rse.expr = convert (gfc_int4_type_node, rse.expr);
989 if (expr->value.op.op1->ts.type == BT_INTEGER)
990 lse.expr = convert (gfc_int4_type_node, lse.expr);
1015 switch (expr->value.op.op1->ts.type)
1018 if (kind == 3) /* Case 16 was not handled properly above. */
1020 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1024 /* Use builtins for real ** int4. */
1030 fndecl = built_in_decls[BUILT_IN_POWIF];
1034 fndecl = built_in_decls[BUILT_IN_POWI];
1039 fndecl = built_in_decls[BUILT_IN_POWIL];
1047 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1051 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1063 fndecl = built_in_decls[BUILT_IN_POWF];
1066 fndecl = built_in_decls[BUILT_IN_POW];
1070 fndecl = built_in_decls[BUILT_IN_POWL];
1081 fndecl = built_in_decls[BUILT_IN_CPOWF];
1084 fndecl = built_in_decls[BUILT_IN_CPOW];
1088 fndecl = built_in_decls[BUILT_IN_CPOWL];
1100 se->expr = build_call_expr_loc (input_location,
1101 fndecl, 2, lse.expr, rse.expr);
1105 /* Generate code to allocate a string temporary. */
1108 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1113 gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
1115 if (gfc_can_put_var_on_stack (len))
1117 /* Create a temporary variable to hold the result. */
1118 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1119 build_int_cst (gfc_charlen_type_node, 1));
1120 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1122 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1123 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1125 tmp = build_array_type (TREE_TYPE (type), tmp);
1127 var = gfc_create_var (tmp, "str");
1128 var = gfc_build_addr_expr (type, var);
1132 /* Allocate a temporary to hold the result. */
1133 var = gfc_create_var (type, "pstr");
1134 tmp = gfc_call_malloc (&se->pre, type,
1135 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1136 fold_convert (TREE_TYPE (len),
1137 TYPE_SIZE (type))));
1138 gfc_add_modify (&se->pre, var, tmp);
1140 /* Free the temporary afterwards. */
1141 tmp = gfc_call_free (convert (pvoid_type_node, var));
1142 gfc_add_expr_to_block (&se->post, tmp);
1149 /* Handle a string concatenation operation. A temporary will be allocated to
1153 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1156 tree len, type, var, tmp, fndecl;
1158 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1159 && expr->value.op.op2->ts.type == BT_CHARACTER);
1160 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1162 gfc_init_se (&lse, se);
1163 gfc_conv_expr (&lse, expr->value.op.op1);
1164 gfc_conv_string_parameter (&lse);
1165 gfc_init_se (&rse, se);
1166 gfc_conv_expr (&rse, expr->value.op.op2);
1167 gfc_conv_string_parameter (&rse);
1169 gfc_add_block_to_block (&se->pre, &lse.pre);
1170 gfc_add_block_to_block (&se->pre, &rse.pre);
1172 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1173 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1174 if (len == NULL_TREE)
1176 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1177 lse.string_length, rse.string_length);
1180 type = build_pointer_type (type);
1182 var = gfc_conv_string_tmp (se, type, len);
1184 /* Do the actual concatenation. */
1185 if (expr->ts.kind == 1)
1186 fndecl = gfor_fndecl_concat_string;
1187 else if (expr->ts.kind == 4)
1188 fndecl = gfor_fndecl_concat_string_char4;
1192 tmp = build_call_expr_loc (input_location,
1193 fndecl, 6, len, var, lse.string_length, lse.expr,
1194 rse.string_length, rse.expr);
1195 gfc_add_expr_to_block (&se->pre, tmp);
1197 /* Add the cleanup for the operands. */
1198 gfc_add_block_to_block (&se->pre, &rse.post);
1199 gfc_add_block_to_block (&se->pre, &lse.post);
1202 se->string_length = len;
1205 /* Translates an op expression. Common (binary) cases are handled by this
1206 function, others are passed on. Recursion is used in either case.
1207 We use the fact that (op1.ts == op2.ts) (except for the power
1209 Operators need no special handling for scalarized expressions as long as
1210 they call gfc_conv_simple_val to get their operands.
1211 Character strings get special handling. */
1214 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1216 enum tree_code code;
1225 switch (expr->value.op.op)
1227 case INTRINSIC_PARENTHESES:
1228 if ((expr->ts.type == BT_REAL
1229 || expr->ts.type == BT_COMPLEX)
1230 && gfc_option.flag_protect_parens)
1232 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1233 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1238 case INTRINSIC_UPLUS:
1239 gfc_conv_expr (se, expr->value.op.op1);
1242 case INTRINSIC_UMINUS:
1243 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1247 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1250 case INTRINSIC_PLUS:
1254 case INTRINSIC_MINUS:
1258 case INTRINSIC_TIMES:
1262 case INTRINSIC_DIVIDE:
1263 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1264 an integer, we must round towards zero, so we use a
1266 if (expr->ts.type == BT_INTEGER)
1267 code = TRUNC_DIV_EXPR;
1272 case INTRINSIC_POWER:
1273 gfc_conv_power_op (se, expr);
1276 case INTRINSIC_CONCAT:
1277 gfc_conv_concat_op (se, expr);
1281 code = TRUTH_ANDIF_EXPR;
1286 code = TRUTH_ORIF_EXPR;
1290 /* EQV and NEQV only work on logicals, but since we represent them
1291 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1293 case INTRINSIC_EQ_OS:
1301 case INTRINSIC_NE_OS:
1302 case INTRINSIC_NEQV:
1309 case INTRINSIC_GT_OS:
1316 case INTRINSIC_GE_OS:
1323 case INTRINSIC_LT_OS:
1330 case INTRINSIC_LE_OS:
1336 case INTRINSIC_USER:
1337 case INTRINSIC_ASSIGN:
1338 /* These should be converted into function calls by the frontend. */
1342 fatal_error ("Unknown intrinsic op");
1346 /* The only exception to this is **, which is handled separately anyway. */
1347 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1349 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1353 gfc_init_se (&lse, se);
1354 gfc_conv_expr (&lse, expr->value.op.op1);
1355 gfc_add_block_to_block (&se->pre, &lse.pre);
1358 gfc_init_se (&rse, se);
1359 gfc_conv_expr (&rse, expr->value.op.op2);
1360 gfc_add_block_to_block (&se->pre, &rse.pre);
1364 gfc_conv_string_parameter (&lse);
1365 gfc_conv_string_parameter (&rse);
1367 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1368 rse.string_length, rse.expr,
1369 expr->value.op.op1->ts.kind);
1370 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1371 gfc_add_block_to_block (&lse.post, &rse.post);
1374 type = gfc_typenode_for_spec (&expr->ts);
1378 /* The result of logical ops is always boolean_type_node. */
1379 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1380 se->expr = convert (type, tmp);
1383 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1385 /* Add the post blocks. */
1386 gfc_add_block_to_block (&se->post, &rse.post);
1387 gfc_add_block_to_block (&se->post, &lse.post);
1390 /* If a string's length is one, we convert it to a single character. */
1393 string_to_single_character (tree len, tree str, int kind)
1395 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1397 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1398 && TREE_INT_CST_HIGH (len) == 0)
1400 str = fold_convert (gfc_get_pchar_type (kind), str);
1401 return build_fold_indirect_ref_loc (input_location,
1410 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1413 if (sym->backend_decl)
1415 /* This becomes the nominal_type in
1416 function.c:assign_parm_find_data_types. */
1417 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1418 /* This becomes the passed_type in
1419 function.c:assign_parm_find_data_types. C promotes char to
1420 integer for argument passing. */
1421 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1423 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1428 /* If we have a constant character expression, make it into an
1430 if ((*expr)->expr_type == EXPR_CONSTANT)
1435 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1436 if ((*expr)->ts.kind != gfc_c_int_kind)
1438 /* The expr needs to be compatible with a C int. If the
1439 conversion fails, then the 2 causes an ICE. */
1440 ts.type = BT_INTEGER;
1441 ts.kind = gfc_c_int_kind;
1442 gfc_convert_type (*expr, &ts, 2);
1445 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1447 if ((*expr)->ref == NULL)
1449 se->expr = string_to_single_character
1450 (build_int_cst (integer_type_node, 1),
1451 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1453 ((*expr)->symtree->n.sym)),
1458 gfc_conv_variable (se, *expr);
1459 se->expr = string_to_single_character
1460 (build_int_cst (integer_type_node, 1),
1461 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1470 /* Compare two strings. If they are all single characters, the result is the
1471 subtraction of them. Otherwise, we build a library call. */
1474 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1480 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1481 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1483 sc1 = string_to_single_character (len1, str1, kind);
1484 sc2 = string_to_single_character (len2, str2, kind);
1486 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1488 /* Deal with single character specially. */
1489 sc1 = fold_convert (integer_type_node, sc1);
1490 sc2 = fold_convert (integer_type_node, sc2);
1491 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1495 /* Build a call for the comparison. */
1499 fndecl = gfor_fndecl_compare_string;
1501 fndecl = gfor_fndecl_compare_string_char4;
1505 tmp = build_call_expr_loc (input_location,
1506 fndecl, 4, len1, str1, len2, str2);
1513 /* Return the backend_decl for a procedure pointer component. */
1516 get_proc_ptr_comp (gfc_expr *e)
1520 gfc_init_se (&comp_se, NULL);
1521 e2 = gfc_copy_expr (e);
1522 e2->expr_type = EXPR_VARIABLE;
1523 gfc_conv_expr (&comp_se, e2);
1525 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1529 /* Select a class typebound procedure at runtime. */
1531 select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
1532 tree declared, gfc_expr *expr)
1539 gfc_class_esym_list *next_elist, *tmp_elist;
1542 /* Convert the hash expression. */
1543 gfc_init_se (&tmpse, NULL);
1544 gfc_conv_expr (&tmpse, elist->hash_value);
1545 gfc_add_block_to_block (&se->pre, &tmpse.pre);
1546 hash = gfc_evaluate_now (tmpse.expr, &se->pre);
1547 gfc_add_block_to_block (&se->post, &tmpse.post);
1549 /* Fix the function type to be that of the declared type method. */
1550 declared = gfc_create_var (TREE_TYPE (declared), "method");
1552 end_label = gfc_build_label_decl (NULL_TREE);
1554 gfc_init_block (&body);
1556 /* Go through the list of extensions. */
1557 for (; elist; elist = next_elist)
1559 /* This case has already been added. */
1560 if (elist->derived == NULL)
1563 /* Skip abstract base types. */
1564 if (elist->derived->attr.abstract)
1567 /* Run through the chain picking up all the cases that call the
1570 for (; elist; elist = elist->next)
1574 if (elist->esym != tmp_elist->esym)
1577 cval = build_int_cst (TREE_TYPE (hash),
1578 elist->derived->hash_value);
1579 /* Build a label for the hash value. */
1580 label = gfc_build_label_decl (NULL_TREE);
1581 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1582 cval, NULL_TREE, label);
1583 gfc_add_expr_to_block (&body, tmp);
1585 /* Null the reference the derived type so that this case is
1587 elist->derived = NULL;
1592 /* Get a pointer to the procedure, */
1593 tmp = gfc_get_symbol_decl (elist->esym);
1594 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1596 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1597 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1600 /* Assign the pointer to the appropriate procedure. */
1601 gfc_add_modify (&body, declared,
1602 fold_convert (TREE_TYPE (declared), tmp));
1604 /* Break to the end of the construct. */
1605 tmp = build1_v (GOTO_EXPR, end_label);
1606 gfc_add_expr_to_block (&body, tmp);
1608 /* Free the elists as we go; freeing them in gfc_free_expr causes
1609 segfaults because it occurs too early and too often. */
1611 next_elist = elist->next;
1612 if (elist->hash_value)
1613 gfc_free_expr (elist->hash_value);
1618 /* Default is an error. */
1619 label = gfc_build_label_decl (NULL_TREE);
1620 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1621 NULL_TREE, NULL_TREE, label);
1622 gfc_add_expr_to_block (&body, tmp);
1623 tmp = gfc_trans_runtime_error (true, &expr->where,
1624 "internal error: bad hash value in dynamic dispatch");
1625 gfc_add_expr_to_block (&body, tmp);
1627 /* Write the switch expression. */
1628 tmp = gfc_finish_block (&body);
1629 tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
1630 gfc_add_expr_to_block (&se->pre, tmp);
1632 tmp = build1_v (LABEL_EXPR, end_label);
1633 gfc_add_expr_to_block (&se->pre, tmp);
1635 se->expr = declared;
1641 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1645 if (expr && expr->symtree
1646 && expr->value.function.class_esym)
1648 if (!sym->backend_decl)
1649 sym->backend_decl = gfc_get_extern_function_decl (sym);
1651 tmp = sym->backend_decl;
1653 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1655 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1656 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1659 select_class_proc (se, expr->value.function.class_esym,
1664 if (gfc_is_proc_ptr_comp (expr, NULL))
1665 tmp = get_proc_ptr_comp (expr);
1666 else if (sym->attr.dummy)
1668 tmp = gfc_get_symbol_decl (sym);
1669 if (sym->attr.proc_pointer)
1670 tmp = build_fold_indirect_ref_loc (input_location,
1672 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1673 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1677 if (!sym->backend_decl)
1678 sym->backend_decl = gfc_get_extern_function_decl (sym);
1680 tmp = sym->backend_decl;
1682 if (sym->attr.cray_pointee)
1684 /* TODO - make the cray pointee a pointer to a procedure,
1685 assign the pointer to it and use it for the call. This
1687 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1688 gfc_get_symbol_decl (sym->cp_pointer));
1689 tmp = gfc_evaluate_now (tmp, &se->pre);
1692 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1694 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1695 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1702 /* Initialize MAPPING. */
1705 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1707 mapping->syms = NULL;
1708 mapping->charlens = NULL;
1712 /* Free all memory held by MAPPING (but not MAPPING itself). */
1715 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1717 gfc_interface_sym_mapping *sym;
1718 gfc_interface_sym_mapping *nextsym;
1720 gfc_charlen *nextcl;
1722 for (sym = mapping->syms; sym; sym = nextsym)
1724 nextsym = sym->next;
1725 sym->new_sym->n.sym->formal = NULL;
1726 gfc_free_symbol (sym->new_sym->n.sym);
1727 gfc_free_expr (sym->expr);
1728 gfc_free (sym->new_sym);
1731 for (cl = mapping->charlens; cl; cl = nextcl)
1734 gfc_free_expr (cl->length);
1740 /* Return a copy of gfc_charlen CL. Add the returned structure to
1741 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1743 static gfc_charlen *
1744 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1747 gfc_charlen *new_charlen;
1749 new_charlen = gfc_get_charlen ();
1750 new_charlen->next = mapping->charlens;
1751 new_charlen->length = gfc_copy_expr (cl->length);
1753 mapping->charlens = new_charlen;
1758 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1759 array variable that can be used as the actual argument for dummy
1760 argument SYM. Add any initialization code to BLOCK. PACKED is as
1761 for gfc_get_nodesc_array_type and DATA points to the first element
1762 in the passed array. */
1765 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1766 gfc_packed packed, tree data)
1771 type = gfc_typenode_for_spec (&sym->ts);
1772 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1773 !sym->attr.target && !sym->attr.pointer
1774 && !sym->attr.proc_pointer);
1776 var = gfc_create_var (type, "ifm");
1777 gfc_add_modify (block, var, fold_convert (type, data));
1783 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1784 and offset of descriptorless array type TYPE given that it has the same
1785 size as DESC. Add any set-up code to BLOCK. */
1788 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1795 offset = gfc_index_zero_node;
1796 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1798 dim = gfc_rank_cst[n];
1799 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1800 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1802 GFC_TYPE_ARRAY_LBOUND (type, n)
1803 = gfc_conv_descriptor_lbound_get (desc, dim);
1804 GFC_TYPE_ARRAY_UBOUND (type, n)
1805 = gfc_conv_descriptor_ubound_get (desc, dim);
1807 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1809 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1810 gfc_conv_descriptor_ubound_get (desc, dim),
1811 gfc_conv_descriptor_lbound_get (desc, dim));
1812 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1813 GFC_TYPE_ARRAY_LBOUND (type, n),
1815 tmp = gfc_evaluate_now (tmp, block);
1816 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1818 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1819 GFC_TYPE_ARRAY_LBOUND (type, n),
1820 GFC_TYPE_ARRAY_STRIDE (type, n));
1821 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1823 offset = gfc_evaluate_now (offset, block);
1824 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1828 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1829 in SE. The caller may still use se->expr and se->string_length after
1830 calling this function. */
1833 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1834 gfc_symbol * sym, gfc_se * se,
1837 gfc_interface_sym_mapping *sm;
1841 gfc_symbol *new_sym;
1843 gfc_symtree *new_symtree;
1845 /* Create a new symbol to represent the actual argument. */
1846 new_sym = gfc_new_symbol (sym->name, NULL);
1847 new_sym->ts = sym->ts;
1848 new_sym->as = gfc_copy_array_spec (sym->as);
1849 new_sym->attr.referenced = 1;
1850 new_sym->attr.dimension = sym->attr.dimension;
1851 new_sym->attr.pointer = sym->attr.pointer;
1852 new_sym->attr.allocatable = sym->attr.allocatable;
1853 new_sym->attr.flavor = sym->attr.flavor;
1854 new_sym->attr.function = sym->attr.function;
1856 /* Ensure that the interface is available and that
1857 descriptors are passed for array actual arguments. */
1858 if (sym->attr.flavor == FL_PROCEDURE)
1860 new_sym->formal = expr->symtree->n.sym->formal;
1861 new_sym->attr.always_explicit
1862 = expr->symtree->n.sym->attr.always_explicit;
1865 /* Create a fake symtree for it. */
1867 new_symtree = gfc_new_symtree (&root, sym->name);
1868 new_symtree->n.sym = new_sym;
1869 gcc_assert (new_symtree == root);
1871 /* Create a dummy->actual mapping. */
1872 sm = XCNEW (gfc_interface_sym_mapping);
1873 sm->next = mapping->syms;
1875 sm->new_sym = new_symtree;
1876 sm->expr = gfc_copy_expr (expr);
1879 /* Stabilize the argument's value. */
1880 if (!sym->attr.function && se)
1881 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1883 if (sym->ts.type == BT_CHARACTER)
1885 /* Create a copy of the dummy argument's length. */
1886 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1887 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1889 /* If the length is specified as "*", record the length that
1890 the caller is passing. We should use the callee's length
1891 in all other cases. */
1892 if (!new_sym->ts.u.cl->length && se)
1894 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1895 new_sym->ts.u.cl->backend_decl = se->string_length;
1902 /* Use the passed value as-is if the argument is a function. */
1903 if (sym->attr.flavor == FL_PROCEDURE)
1906 /* If the argument is either a string or a pointer to a string,
1907 convert it to a boundless character type. */
1908 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1910 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1911 tmp = build_pointer_type (tmp);
1912 if (sym->attr.pointer)
1913 value = build_fold_indirect_ref_loc (input_location,
1917 value = fold_convert (tmp, value);
1920 /* If the argument is a scalar, a pointer to an array or an allocatable,
1922 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1923 value = build_fold_indirect_ref_loc (input_location,
1926 /* For character(*), use the actual argument's descriptor. */
1927 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1928 value = build_fold_indirect_ref_loc (input_location,
1931 /* If the argument is an array descriptor, use it to determine
1932 information about the actual argument's shape. */
1933 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1934 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1936 /* Get the actual argument's descriptor. */
1937 desc = build_fold_indirect_ref_loc (input_location,
1940 /* Create the replacement variable. */
1941 tmp = gfc_conv_descriptor_data_get (desc);
1942 value = gfc_get_interface_mapping_array (&se->pre, sym,
1945 /* Use DESC to work out the upper bounds, strides and offset. */
1946 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1949 /* Otherwise we have a packed array. */
1950 value = gfc_get_interface_mapping_array (&se->pre, sym,
1951 PACKED_FULL, se->expr);
1953 new_sym->backend_decl = value;
1957 /* Called once all dummy argument mappings have been added to MAPPING,
1958 but before the mapping is used to evaluate expressions. Pre-evaluate
1959 the length of each argument, adding any initialization code to PRE and
1960 any finalization code to POST. */
1963 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1964 stmtblock_t * pre, stmtblock_t * post)
1966 gfc_interface_sym_mapping *sym;
1970 for (sym = mapping->syms; sym; sym = sym->next)
1971 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1972 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1974 expr = sym->new_sym->n.sym->ts.u.cl->length;
1975 gfc_apply_interface_mapping_to_expr (mapping, expr);
1976 gfc_init_se (&se, NULL);
1977 gfc_conv_expr (&se, expr);
1978 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1979 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1980 gfc_add_block_to_block (pre, &se.pre);
1981 gfc_add_block_to_block (post, &se.post);
1983 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1988 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1992 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1993 gfc_constructor * c)
1995 for (; c; c = c->next)
1997 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2000 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2001 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2002 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2008 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2012 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2017 for (; ref; ref = ref->next)
2021 for (n = 0; n < ref->u.ar.dimen; n++)
2023 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2024 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2025 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2027 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2034 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2035 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2041 /* Convert intrinsic function calls into result expressions. */
2044 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2052 arg1 = expr->value.function.actual->expr;
2053 if (expr->value.function.actual->next)
2054 arg2 = expr->value.function.actual->next->expr;
2058 sym = arg1->symtree->n.sym;
2060 if (sym->attr.dummy)
2065 switch (expr->value.function.isym->id)
2068 /* TODO figure out why this condition is necessary. */
2069 if (sym->attr.function
2070 && (arg1->ts.u.cl->length == NULL
2071 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2072 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2075 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2082 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2084 dup = mpz_get_si (arg2->value.integer);
2089 dup = sym->as->rank;
2093 for (; d < dup; d++)
2097 if (!sym->as->upper[d] || !sym->as->lower[d])
2099 gfc_free_expr (new_expr);
2103 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
2104 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2106 new_expr = gfc_multiply (new_expr, tmp);
2112 case GFC_ISYM_LBOUND:
2113 case GFC_ISYM_UBOUND:
2114 /* TODO These implementations of lbound and ubound do not limit if
2115 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2120 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2121 d = mpz_get_si (arg2->value.integer) - 1;
2123 /* TODO: If the need arises, this could produce an array of
2127 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2129 if (sym->as->lower[d])
2130 new_expr = gfc_copy_expr (sym->as->lower[d]);
2134 if (sym->as->upper[d])
2135 new_expr = gfc_copy_expr (sym->as->upper[d]);
2143 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2147 gfc_replace_expr (expr, new_expr);
2153 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2154 gfc_interface_mapping * mapping)
2156 gfc_formal_arglist *f;
2157 gfc_actual_arglist *actual;
2159 actual = expr->value.function.actual;
2160 f = map_expr->symtree->n.sym->formal;
2162 for (; f && actual; f = f->next, actual = actual->next)
2167 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2170 if (map_expr->symtree->n.sym->attr.dimension)
2175 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2177 for (d = 0; d < as->rank; d++)
2179 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2180 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2183 expr->value.function.esym->as = as;
2186 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2188 expr->value.function.esym->ts.u.cl->length
2189 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2191 gfc_apply_interface_mapping_to_expr (mapping,
2192 expr->value.function.esym->ts.u.cl->length);
2197 /* EXPR is a copy of an expression that appeared in the interface
2198 associated with MAPPING. Walk it recursively looking for references to
2199 dummy arguments that MAPPING maps to actual arguments. Replace each such
2200 reference with a reference to the associated actual argument. */
2203 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2206 gfc_interface_sym_mapping *sym;
2207 gfc_actual_arglist *actual;
2212 /* Copying an expression does not copy its length, so do that here. */
2213 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2215 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2216 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2219 /* Apply the mapping to any references. */
2220 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2222 /* ...and to the expression's symbol, if it has one. */
2223 /* TODO Find out why the condition on expr->symtree had to be moved into
2224 the loop rather than being outside it, as originally. */
2225 for (sym = mapping->syms; sym; sym = sym->next)
2226 if (expr->symtree && sym->old == expr->symtree->n.sym)
2228 if (sym->new_sym->n.sym->backend_decl)
2229 expr->symtree = sym->new_sym;
2231 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2234 /* ...and to subexpressions in expr->value. */
2235 switch (expr->expr_type)
2240 case EXPR_SUBSTRING:
2244 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2245 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2249 for (actual = expr->value.function.actual; actual; actual = actual->next)
2250 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2252 if (expr->value.function.esym == NULL
2253 && expr->value.function.isym != NULL
2254 && expr->value.function.actual->expr->symtree
2255 && gfc_map_intrinsic_function (expr, mapping))
2258 for (sym = mapping->syms; sym; sym = sym->next)
2259 if (sym->old == expr->value.function.esym)
2261 expr->value.function.esym = sym->new_sym->n.sym;
2262 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2263 expr->value.function.esym->result = sym->new_sym->n.sym;
2268 case EXPR_STRUCTURE:
2269 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2282 /* Evaluate interface expression EXPR using MAPPING. Store the result
2286 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2287 gfc_se * se, gfc_expr * expr)
2289 expr = gfc_copy_expr (expr);
2290 gfc_apply_interface_mapping_to_expr (mapping, expr);
2291 gfc_conv_expr (se, expr);
2292 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2293 gfc_free_expr (expr);
2297 /* Returns a reference to a temporary array into which a component of
2298 an actual argument derived type array is copied and then returned
2299 after the function call. */
2301 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2302 sym_intent intent, bool formal_ptr)
2320 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2322 gfc_init_se (&lse, NULL);
2323 gfc_init_se (&rse, NULL);
2325 /* Walk the argument expression. */
2326 rss = gfc_walk_expr (expr);
2328 gcc_assert (rss != gfc_ss_terminator);
2330 /* Initialize the scalarizer. */
2331 gfc_init_loopinfo (&loop);
2332 gfc_add_ss_to_loop (&loop, rss);
2334 /* Calculate the bounds of the scalarization. */
2335 gfc_conv_ss_startstride (&loop);
2337 /* Build an ss for the temporary. */
2338 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2339 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2341 base_type = gfc_typenode_for_spec (&expr->ts);
2342 if (GFC_ARRAY_TYPE_P (base_type)
2343 || GFC_DESCRIPTOR_TYPE_P (base_type))
2344 base_type = gfc_get_element_type (base_type);
2346 loop.temp_ss = gfc_get_ss ();;
2347 loop.temp_ss->type = GFC_SS_TEMP;
2348 loop.temp_ss->data.temp.type = base_type;
2350 if (expr->ts.type == BT_CHARACTER)
2351 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2353 loop.temp_ss->string_length = NULL;
2355 parmse->string_length = loop.temp_ss->string_length;
2356 loop.temp_ss->data.temp.dimen = loop.dimen;
2357 loop.temp_ss->next = gfc_ss_terminator;
2359 /* Associate the SS with the loop. */
2360 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2362 /* Setup the scalarizing loops. */
2363 gfc_conv_loop_setup (&loop, &expr->where);
2365 /* Pass the temporary descriptor back to the caller. */
2366 info = &loop.temp_ss->data.info;
2367 parmse->expr = info->descriptor;
2369 /* Setup the gfc_se structures. */
2370 gfc_copy_loopinfo_to_se (&lse, &loop);
2371 gfc_copy_loopinfo_to_se (&rse, &loop);
2374 lse.ss = loop.temp_ss;
2375 gfc_mark_ss_chain_used (rss, 1);
2376 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2378 /* Start the scalarized loop body. */
2379 gfc_start_scalarized_body (&loop, &body);
2381 /* Translate the expression. */
2382 gfc_conv_expr (&rse, expr);
2384 gfc_conv_tmp_array_ref (&lse);
2385 gfc_advance_se_ss_chain (&lse);
2387 if (intent != INTENT_OUT)
2389 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2390 gfc_add_expr_to_block (&body, tmp);
2391 gcc_assert (rse.ss == gfc_ss_terminator);
2392 gfc_trans_scalarizing_loops (&loop, &body);
2396 /* Make sure that the temporary declaration survives by merging
2397 all the loop declarations into the current context. */
2398 for (n = 0; n < loop.dimen; n++)
2400 gfc_merge_block_scope (&body);
2401 body = loop.code[loop.order[n]];
2403 gfc_merge_block_scope (&body);
2406 /* Add the post block after the second loop, so that any
2407 freeing of allocated memory is done at the right time. */
2408 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2410 /**********Copy the temporary back again.*********/
2412 gfc_init_se (&lse, NULL);
2413 gfc_init_se (&rse, NULL);
2415 /* Walk the argument expression. */
2416 lss = gfc_walk_expr (expr);
2417 rse.ss = loop.temp_ss;
2420 /* Initialize the scalarizer. */
2421 gfc_init_loopinfo (&loop2);
2422 gfc_add_ss_to_loop (&loop2, lss);
2424 /* Calculate the bounds of the scalarization. */
2425 gfc_conv_ss_startstride (&loop2);
2427 /* Setup the scalarizing loops. */
2428 gfc_conv_loop_setup (&loop2, &expr->where);
2430 gfc_copy_loopinfo_to_se (&lse, &loop2);
2431 gfc_copy_loopinfo_to_se (&rse, &loop2);
2433 gfc_mark_ss_chain_used (lss, 1);
2434 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2436 /* Declare the variable to hold the temporary offset and start the
2437 scalarized loop body. */
2438 offset = gfc_create_var (gfc_array_index_type, NULL);
2439 gfc_start_scalarized_body (&loop2, &body);
2441 /* Build the offsets for the temporary from the loop variables. The
2442 temporary array has lbounds of zero and strides of one in all
2443 dimensions, so this is very simple. The offset is only computed
2444 outside the innermost loop, so the overall transfer could be
2445 optimized further. */
2446 info = &rse.ss->data.info;
2447 dimen = info->dimen;
2449 tmp_index = gfc_index_zero_node;
2450 for (n = dimen - 1; n > 0; n--)
2453 tmp = rse.loop->loopvar[n];
2454 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2455 tmp, rse.loop->from[n]);
2456 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2459 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2460 rse.loop->to[n-1], rse.loop->from[n-1]);
2461 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2462 tmp_str, gfc_index_one_node);
2464 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2468 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2469 tmp_index, rse.loop->from[0]);
2470 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2472 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2473 rse.loop->loopvar[0], offset);
2475 /* Now use the offset for the reference. */
2476 tmp = build_fold_indirect_ref_loc (input_location,
2478 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2480 if (expr->ts.type == BT_CHARACTER)
2481 rse.string_length = expr->ts.u.cl->backend_decl;
2483 gfc_conv_expr (&lse, expr);
2485 gcc_assert (lse.ss == gfc_ss_terminator);
2487 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2488 gfc_add_expr_to_block (&body, tmp);
2490 /* Generate the copying loops. */
2491 gfc_trans_scalarizing_loops (&loop2, &body);
2493 /* Wrap the whole thing up by adding the second loop to the post-block
2494 and following it by the post-block of the first loop. In this way,
2495 if the temporary needs freeing, it is done after use! */
2496 if (intent != INTENT_IN)
2498 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2499 gfc_add_block_to_block (&parmse->post, &loop2.post);
2502 gfc_add_block_to_block (&parmse->post, &loop.post);
2504 gfc_cleanup_loop (&loop);
2505 gfc_cleanup_loop (&loop2);
2507 /* Pass the string length to the argument expression. */
2508 if (expr->ts.type == BT_CHARACTER)
2509 parmse->string_length = expr->ts.u.cl->backend_decl;
2511 /* Determine the offset for pointer formal arguments and set the
2515 size = gfc_index_one_node;
2516 offset = gfc_index_zero_node;
2517 for (n = 0; n < dimen; n++)
2519 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2521 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2522 tmp, gfc_index_one_node);
2523 gfc_conv_descriptor_ubound_set (&parmse->pre,
2527 gfc_conv_descriptor_lbound_set (&parmse->pre,
2530 gfc_index_one_node);
2531 size = gfc_evaluate_now (size, &parmse->pre);
2532 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2534 offset = gfc_evaluate_now (offset, &parmse->pre);
2535 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2536 rse.loop->to[n], rse.loop->from[n]);
2537 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2538 tmp, gfc_index_one_node);
2539 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2543 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2547 /* We want either the address for the data or the address of the descriptor,
2548 depending on the mode of passing array arguments. */
2550 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2552 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2558 /* Generate the code for argument list functions. */
2561 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2563 /* Pass by value for g77 %VAL(arg), pass the address
2564 indirectly for %LOC, else by reference. Thus %REF
2565 is a "do-nothing" and %LOC is the same as an F95
2567 if (strncmp (name, "%VAL", 4) == 0)
2568 gfc_conv_expr (se, expr);
2569 else if (strncmp (name, "%LOC", 4) == 0)
2571 gfc_conv_expr_reference (se, expr);
2572 se->expr = gfc_build_addr_expr (NULL, se->expr);
2574 else if (strncmp (name, "%REF", 4) == 0)
2575 gfc_conv_expr_reference (se, expr);
2577 gfc_error ("Unknown argument list function at %L", &expr->where);
2581 /* Takes a derived type expression and returns the address of a temporary
2582 class object of the 'declared' type. */
2584 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2585 gfc_typespec class_ts)
2589 gfc_symbol *declared = class_ts.u.derived;
2595 /* The derived type needs to be converted to a temporary
2597 tmp = gfc_typenode_for_spec (&class_ts);
2598 var = gfc_create_var (tmp, "class");
2601 cmp = gfc_find_component (declared, "$vptr", true, true);
2602 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2603 var, cmp->backend_decl, NULL_TREE);
2605 /* Remember the vtab corresponds to the derived type
2606 not to the class declared type. */
2607 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2609 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2610 gfc_add_modify (&parmse->pre, ctree,
2611 fold_convert (TREE_TYPE (ctree), tmp));
2613 /* Now set the data field. */
2614 cmp = gfc_find_component (declared, "$data", true, true);
2615 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2616 var, cmp->backend_decl, NULL_TREE);
2617 ss = gfc_walk_expr (e);
2618 if (ss == gfc_ss_terminator)
2620 gfc_conv_expr_reference (parmse, e);
2621 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2622 gfc_add_modify (&parmse->pre, ctree, tmp);
2626 gfc_conv_expr (parmse, e);
2627 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2630 /* Pass the address of the class object. */
2631 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2635 /* The following routine generates code for the intrinsic
2636 procedures from the ISO_C_BINDING module:
2638 * C_FUNLOC (function)
2639 * C_F_POINTER (subroutine)
2640 * C_F_PROCPOINTER (subroutine)
2641 * C_ASSOCIATED (function)
2642 One exception which is not handled here is C_F_POINTER with non-scalar
2643 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2646 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2647 gfc_actual_arglist * arg)
2652 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2654 if (arg->expr->rank == 0)
2655 gfc_conv_expr_reference (se, arg->expr);
2659 /* This is really the actual arg because no formal arglist is
2660 created for C_LOC. */
2661 fsym = arg->expr->symtree->n.sym;
2663 /* We should want it to do g77 calling convention. */
2665 && !(fsym->attr.pointer || fsym->attr.allocatable)
2666 && fsym->as->type != AS_ASSUMED_SHAPE;
2667 f = f || !sym->attr.always_explicit;
2669 argss = gfc_walk_expr (arg->expr);
2670 gfc_conv_array_parameter (se, arg->expr, argss, f,
2674 /* TODO -- the following two lines shouldn't be necessary, but if
2675 they're removed, a bug is exposed later in the code path.
2676 This workaround was thus introduced, but will have to be
2677 removed; please see PR 35150 for details about the issue. */
2678 se->expr = convert (pvoid_type_node, se->expr);
2679 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2683 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2685 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2686 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2687 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2688 gfc_conv_expr_reference (se, arg->expr);
2692 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2693 && arg->next->expr->rank == 0)
2694 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2696 /* Convert c_f_pointer if fptr is a scalar
2697 and convert c_f_procpointer. */
2701 gfc_init_se (&cptrse, NULL);
2702 gfc_conv_expr (&cptrse, arg->expr);
2703 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2704 gfc_add_block_to_block (&se->post, &cptrse.post);
2706 gfc_init_se (&fptrse, NULL);
2707 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2708 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2709 fptrse.want_pointer = 1;
2711 gfc_conv_expr (&fptrse, arg->next->expr);
2712 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2713 gfc_add_block_to_block (&se->post, &fptrse.post);
2715 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2716 && arg->next->expr->symtree->n.sym->attr.dummy)
2717 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2720 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2722 fold_convert (TREE_TYPE (fptrse.expr),
2727 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2732 /* Build the addr_expr for the first argument. The argument is
2733 already an *address* so we don't need to set want_pointer in
2735 gfc_init_se (&arg1se, NULL);
2736 gfc_conv_expr (&arg1se, arg->expr);
2737 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2738 gfc_add_block_to_block (&se->post, &arg1se.post);
2740 /* See if we were given two arguments. */
2741 if (arg->next == NULL)
2742 /* Only given one arg so generate a null and do a
2743 not-equal comparison against the first arg. */
2744 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2745 fold_convert (TREE_TYPE (arg1se.expr),
2746 null_pointer_node));
2752 /* Given two arguments so build the arg2se from second arg. */
2753 gfc_init_se (&arg2se, NULL);
2754 gfc_conv_expr (&arg2se, arg->next->expr);
2755 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2756 gfc_add_block_to_block (&se->post, &arg2se.post);
2758 /* Generate test to compare that the two args are equal. */
2759 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2760 arg1se.expr, arg2se.expr);
2761 /* Generate test to ensure that the first arg is not null. */
2762 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2763 arg1se.expr, null_pointer_node);
2765 /* Finally, the generated test must check that both arg1 is not
2766 NULL and that it is equal to the second arg. */
2767 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2768 not_null_expr, eq_expr);
2774 /* Nothing was done. */
2779 /* Generate code for a procedure call. Note can return se->post != NULL.
2780 If se->direct_byref is set then se->expr contains the return parameter.
2781 Return nonzero, if the call has alternate specifiers.
2782 'expr' is only needed for procedure pointer components. */
2785 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2786 gfc_actual_arglist * arg, gfc_expr * expr,
2789 gfc_interface_mapping mapping;
2804 gfc_formal_arglist *formal;
2805 int has_alternate_specifier = 0;
2806 bool need_interface_mapping;
2813 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2814 gfc_component *comp = NULL;
2816 arglist = NULL_TREE;
2817 retargs = NULL_TREE;
2818 stringargs = NULL_TREE;
2823 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2824 && conv_isocbinding_procedure (se, sym, arg))
2827 gfc_is_proc_ptr_comp (expr, &comp);
2831 if (!sym->attr.elemental)
2833 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2834 if (se->ss->useflags)
2836 gcc_assert ((!comp && gfc_return_by_reference (sym)
2837 && sym->result->attr.dimension)
2838 || (comp && comp->attr.dimension));
2839 gcc_assert (se->loop != NULL);
2841 /* Access the previously obtained result. */
2842 gfc_conv_tmp_array_ref (se);
2843 gfc_advance_se_ss_chain (se);
2847 info = &se->ss->data.info;
2852 gfc_init_block (&post);
2853 gfc_init_interface_mapping (&mapping);
2856 formal = sym->formal;
2857 need_interface_mapping = sym->attr.dimension ||
2858 (sym->ts.type == BT_CHARACTER
2859 && sym->ts.u.cl->length
2860 && sym->ts.u.cl->length->expr_type
2865 formal = comp->formal;
2866 need_interface_mapping = comp->attr.dimension ||
2867 (comp->ts.type == BT_CHARACTER
2868 && comp->ts.u.cl->length
2869 && comp->ts.u.cl->length->expr_type
2873 /* Evaluate the arguments. */
2874 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2877 fsym = formal ? formal->sym : NULL;
2878 parm_kind = MISSING;
2882 if (se->ignore_optional)
2884 /* Some intrinsics have already been resolved to the correct
2888 else if (arg->label)
2890 has_alternate_specifier = 1;
2895 /* Pass a NULL pointer for an absent arg. */
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);
2902 else if (fsym && fsym->ts.type == BT_CLASS
2903 && e->ts.type == BT_DERIVED)
2905 /* The derived type needs to be converted to a temporary
2907 gfc_init_se (&parmse, se);
2908 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2910 else if (se->ss && se->ss->useflags)
2912 /* An elemental function inside a scalarized loop. */
2913 gfc_init_se (&parmse, se);
2914 gfc_conv_expr_reference (&parmse, e);
2915 parm_kind = ELEMENTAL;
2919 /* A scalar or transformational function. */
2920 gfc_init_se (&parmse, NULL);
2921 argss = gfc_walk_expr (e);
2923 if (argss == gfc_ss_terminator)
2925 if (e->expr_type == EXPR_VARIABLE
2926 && e->symtree->n.sym->attr.cray_pointee
2927 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2929 /* The Cray pointer needs to be converted to a pointer to
2930 a type given by the expression. */
2931 gfc_conv_expr (&parmse, e);
2932 type = build_pointer_type (TREE_TYPE (parmse.expr));
2933 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2934 parmse.expr = convert (type, tmp);
2936 else if (fsym && fsym->attr.value)
2938 if (fsym->ts.type == BT_CHARACTER
2939 && fsym->ts.is_c_interop
2940 && fsym->ns->proc_name != NULL
2941 && fsym->ns->proc_name->attr.is_bind_c)
2944 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2945 if (parmse.expr == NULL)
2946 gfc_conv_expr (&parmse, e);
2949 gfc_conv_expr (&parmse, e);
2951 else if (arg->name && arg->name[0] == '%')
2952 /* Argument list functions %VAL, %LOC and %REF are signalled
2953 through arg->name. */
2954 conv_arglist_function (&parmse, arg->expr, arg->name);
2955 else if ((e->expr_type == EXPR_FUNCTION)
2956 && ((e->value.function.esym
2957 && e->value.function.esym->result->attr.pointer)
2958 || (!e->value.function.esym
2959 && e->symtree->n.sym->attr.pointer))
2960 && fsym && fsym->attr.target)
2962 gfc_conv_expr (&parmse, e);
2963 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2965 else if (e->expr_type == EXPR_FUNCTION
2966 && e->symtree->n.sym->result
2967 && e->symtree->n.sym->result != e->symtree->n.sym
2968 && e->symtree->n.sym->result->attr.proc_pointer)
2970 /* Functions returning procedure pointers. */
2971 gfc_conv_expr (&parmse, e);
2972 if (fsym && fsym->attr.proc_pointer)
2973 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2977 gfc_conv_expr_reference (&parmse, e);
2979 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2980 allocated on entry, it must be deallocated. */
2981 if (fsym && fsym->attr.allocatable
2982 && fsym->attr.intent == INTENT_OUT)
2986 gfc_init_block (&block);
2987 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2989 gfc_add_expr_to_block (&block, tmp);
2990 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2991 parmse.expr, null_pointer_node);
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 (COND_EXPR, void_type_node,
2999 gfc_conv_expr_present (e->symtree->n.sym),
3000 gfc_finish_block (&block),
3001 build_empty_stmt (input_location));
3004 tmp = gfc_finish_block (&block);
3006 gfc_add_expr_to_block (&se->pre, tmp);
3009 if (fsym && e->expr_type != EXPR_NULL
3010 && ((fsym->attr.pointer
3011 && fsym->attr.flavor != FL_PROCEDURE)
3012 || (fsym->attr.proc_pointer
3013 && !(e->expr_type == EXPR_VARIABLE
3014 && e->symtree->n.sym->attr.dummy))
3015 || (e->expr_type == EXPR_VARIABLE
3016 && gfc_is_proc_ptr_comp (e, NULL))
3017 || fsym->attr.allocatable))
3019 /* Scalar pointer dummy args require an extra level of
3020 indirection. The null pointer already contains
3021 this level of indirection. */
3022 parm_kind = SCALAR_POINTER;
3023 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3029 /* If the procedure requires an explicit interface, the actual
3030 argument is passed according to the corresponding formal
3031 argument. If the corresponding formal argument is a POINTER,
3032 ALLOCATABLE or assumed shape, we do not use g77's calling
3033 convention, and pass the address of the array descriptor
3034 instead. Otherwise we use g77's calling convention. */
3037 && !(fsym->attr.pointer || fsym->attr.allocatable)
3038 && fsym->as->type != AS_ASSUMED_SHAPE;
3040 f = f || !comp->attr.always_explicit;
3042 f = f || !sym->attr.always_explicit;
3044 if (e->expr_type == EXPR_VARIABLE
3045 && is_subref_array (e))
3046 /* The actual argument is a component reference to an
3047 array of derived types. In this case, the argument
3048 is converted to a temporary, which is passed and then
3049 written back after the procedure call. */
3050 gfc_conv_subref_array_arg (&parmse, e, f,
3051 fsym ? fsym->attr.intent : INTENT_INOUT,
3052 fsym && fsym->attr.pointer);
3054 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3057 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3058 allocated on entry, it must be deallocated. */
3059 if (fsym && fsym->attr.allocatable
3060 && fsym->attr.intent == INTENT_OUT)
3062 tmp = build_fold_indirect_ref_loc (input_location,
3064 tmp = gfc_trans_dealloc_allocated (tmp);
3065 if (fsym->attr.optional
3066 && e->expr_type == EXPR_VARIABLE
3067 && e->symtree->n.sym->attr.optional)
3068 tmp = fold_build3 (COND_EXPR, void_type_node,
3069 gfc_conv_expr_present (e->symtree->n.sym),
3070 tmp, build_empty_stmt (input_location));
3071 gfc_add_expr_to_block (&se->pre, tmp);
3076 /* The case with fsym->attr.optional is that of a user subroutine
3077 with an interface indicating an optional argument. When we call
3078 an intrinsic subroutine, however, fsym is NULL, but we might still
3079 have an optional argument, so we proceed to the substitution
3081 if (e && (fsym == NULL || fsym->attr.optional))
3083 /* If an optional argument is itself an optional dummy argument,
3084 check its presence and substitute a null if absent. This is
3085 only needed when passing an array to an elemental procedure
3086 as then array elements are accessed - or no NULL pointer is
3087 allowed and a "1" or "0" should be passed if not present.
3088 When passing a non-array-descriptor full array to a
3089 non-array-descriptor dummy, no check is needed. For
3090 array-descriptor actual to array-descriptor dummy, see
3091 PR 41911 for why a check has to be inserted.
3092 fsym == NULL is checked as intrinsics required the descriptor
3093 but do not always set fsym. */
3094 if (e->expr_type == EXPR_VARIABLE
3095 && e->symtree->n.sym->attr.optional
3096 && ((e->rank > 0 && sym->attr.elemental)
3097 || e->representation.length || e->ts.type == BT_CHARACTER
3099 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3100 || fsym->as->type == AS_DEFERRED))))
3101 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3102 e->representation.length);
3107 /* Obtain the character length of an assumed character length
3108 length procedure from the typespec. */
3109 if (fsym->ts.type == BT_CHARACTER
3110 && parmse.string_length == NULL_TREE
3111 && e->ts.type == BT_PROCEDURE
3112 && e->symtree->n.sym->ts.type == BT_CHARACTER
3113 && e->symtree->n.sym->ts.u.cl->length != NULL
3114 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3116 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3117 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3121 if (fsym && need_interface_mapping && e)
3122 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3124 gfc_add_block_to_block (&se->pre, &parmse.pre);
3125 gfc_add_block_to_block (&post, &parmse.post);
3127 /* Allocated allocatable components of derived types must be
3128 deallocated for non-variable scalars. Non-variable arrays are
3129 dealt with in trans-array.c(gfc_conv_array_parameter). */
3130 if (e && e->ts.type == BT_DERIVED
3131 && e->ts.u.derived->attr.alloc_comp
3132 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3133 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3136 tmp = build_fold_indirect_ref_loc (input_location,
3138 parm_rank = e->rank;
3146 case (SCALAR_POINTER):
3147 tmp = build_fold_indirect_ref_loc (input_location,
3152 if (e->expr_type == EXPR_OP
3153 && e->value.op.op == INTRINSIC_PARENTHESES
3154 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3157 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3158 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3159 gfc_add_expr_to_block (&se->post, local_tmp);
3162 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3164 gfc_add_expr_to_block (&se->post, tmp);
3167 /* Add argument checking of passing an unallocated/NULL actual to
3168 a nonallocatable/nonpointer dummy. */
3170 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3172 symbol_attribute *attr;
3176 if (e->expr_type == EXPR_VARIABLE)
3177 attr = &e->symtree->n.sym->attr;
3178 else if (e->expr_type == EXPR_FUNCTION)
3180 /* For intrinsic functions, the gfc_attr are not available. */
3181 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3182 goto end_pointer_check;
3184 if (e->symtree->n.sym->attr.generic)
3185 attr = &e->value.function.esym->attr;
3187 attr = &e->symtree->n.sym->result->attr;
3190 goto end_pointer_check;
3194 /* If the actual argument is an optional pointer/allocatable and
3195 the formal argument takes an nonpointer optional value,
3196 it is invalid to pass a non-present argument on, even
3197 though there is no technical reason for this in gfortran.
3198 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3199 tree present, nullptr, type;
3201 if (attr->allocatable
3202 && (fsym == NULL || !fsym->attr.allocatable))
3203 asprintf (&msg, "Allocatable actual argument '%s' is not "
3204 "allocated or not present", e->symtree->n.sym->name);
3205 else if (attr->pointer
3206 && (fsym == NULL || !fsym->attr.pointer))
3207 asprintf (&msg, "Pointer actual argument '%s' is not "
3208 "associated or not present",
3209 e->symtree->n.sym->name);
3210 else if (attr->proc_pointer
3211 && (fsym == NULL || !fsym->attr.proc_pointer))
3212 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3213 "associated or not present",
3214 e->symtree->n.sym->name);
3216 goto end_pointer_check;
3218 present = gfc_conv_expr_present (e->symtree->n.sym);
3219 type = TREE_TYPE (present);
3220 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3221 fold_convert (type, null_pointer_node));
3222 type = TREE_TYPE (parmse.expr);
3223 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3224 fold_convert (type, null_pointer_node));
3225 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3230 if (attr->allocatable
3231 && (fsym == NULL || !fsym->attr.allocatable))
3232 asprintf (&msg, "Allocatable actual argument '%s' is not "
3233 "allocated", e->symtree->n.sym->name);
3234 else if (attr->pointer
3235 && (fsym == NULL || !fsym->attr.pointer))
3236 asprintf (&msg, "Pointer actual argument '%s' is not "
3237 "associated", e->symtree->n.sym->name);
3238 else if (attr->proc_pointer
3239 && (fsym == NULL || !fsym->attr.proc_pointer))
3240 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3241 "associated", e->symtree->n.sym->name);
3243 goto end_pointer_check;
3246 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3247 fold_convert (TREE_TYPE (parmse.expr),
3248 null_pointer_node));
3251 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3258 /* Character strings are passed as two parameters, a length and a
3259 pointer - except for Bind(c) which only passes the pointer. */
3260 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3261 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
3263 arglist = gfc_chainon_list (arglist, parmse.expr);
3265 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3272 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3273 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3274 else if (ts.type == BT_CHARACTER)
3276 if (ts.u.cl->length == NULL)
3278 /* Assumed character length results are not allowed by 5.1.1.5 of the
3279 standard and are trapped in resolve.c; except in the case of SPREAD
3280 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3281 we take the character length of the first argument for the result.
3282 For dummies, we have to look through the formal argument list for
3283 this function and use the character length found there.*/
3284 if (!sym->attr.dummy)
3285 cl.backend_decl = TREE_VALUE (stringargs);
3288 formal = sym->ns->proc_name->formal;
3289 for (; formal; formal = formal->next)
3290 if (strcmp (formal->sym->name, sym->name) == 0)
3291 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3298 /* Calculate the length of the returned string. */
3299 gfc_init_se (&parmse, NULL);
3300 if (need_interface_mapping)
3301 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3303 gfc_conv_expr (&parmse, ts.u.cl->length);
3304 gfc_add_block_to_block (&se->pre, &parmse.pre);
3305 gfc_add_block_to_block (&se->post, &parmse.post);
3307 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3308 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3309 build_int_cst (gfc_charlen_type_node, 0));
3310 cl.backend_decl = tmp;
3313 /* Set up a charlen structure for it. */
3318 len = cl.backend_decl;
3321 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3322 || (!comp && gfc_return_by_reference (sym));
3325 if (se->direct_byref)
3327 /* Sometimes, too much indirection can be applied; e.g. for
3328 function_result = array_valued_recursive_function. */
3329 if (TREE_TYPE (TREE_TYPE (se->expr))
3330 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3331 && GFC_DESCRIPTOR_TYPE_P
3332 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3333 se->expr = build_fold_indirect_ref_loc (input_location,
3336 result = build_fold_indirect_ref_loc (input_location,
3338 retargs = gfc_chainon_list (retargs, se->expr);
3340 else if (comp && comp->attr.dimension)
3342 gcc_assert (se->loop && info);
3344 /* Set the type of the array. */
3345 tmp = gfc_typenode_for_spec (&comp->ts);
3346 info->dimen = se->loop->dimen;
3348 /* Evaluate the bounds of the result, if known. */
3349 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3351 /* Create a temporary to store the result. In case the function
3352 returns a pointer, the temporary will be a shallow copy and
3353 mustn't be deallocated. */
3354 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3355 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3356 NULL_TREE, false, !comp->attr.pointer,
3357 callee_alloc, &se->ss->expr->where);
3359 /* Pass the temporary as the first argument. */
3360 result = info->descriptor;
3361 tmp = gfc_build_addr_expr (NULL_TREE, result);
3362 retargs = gfc_chainon_list (retargs, tmp);
3364 else if (!comp && sym->result->attr.dimension)
3366 gcc_assert (se->loop && info);
3368 /* Set the type of the array. */
3369 tmp = gfc_typenode_for_spec (&ts);
3370 info->dimen = se->loop->dimen;
3372 /* Evaluate the bounds of the result, if known. */
3373 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3375 /* Create a temporary to store the result. In case the function
3376 returns a pointer, the temporary will be a shallow copy and
3377 mustn't be deallocated. */
3378 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3379 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3380 NULL_TREE, false, !sym->attr.pointer,
3381 callee_alloc, &se->ss->expr->where);
3383 /* Pass the temporary as the first argument. */
3384 result = info->descriptor;
3385 tmp = gfc_build_addr_expr (NULL_TREE, result);
3386 retargs = gfc_chainon_list (retargs, tmp);
3388 else if (ts.type == BT_CHARACTER)
3390 /* Pass the string length. */
3391 type = gfc_get_character_type (ts.kind, ts.u.cl);
3392 type = build_pointer_type (type);
3394 /* Return an address to a char[0:len-1]* temporary for
3395 character pointers. */
3396 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3397 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3399 var = gfc_create_var (type, "pstr");
3401 if ((!comp && sym->attr.allocatable)
3402 || (comp && comp->attr.allocatable))
3403 gfc_add_modify (&se->pre, var,
3404 fold_convert (TREE_TYPE (var),
3405 null_pointer_node));
3407 /* Provide an address expression for the function arguments. */
3408 var = gfc_build_addr_expr (NULL_TREE, var);
3411 var = gfc_conv_string_tmp (se, type, len);
3413 retargs = gfc_chainon_list (retargs, var);
3417 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3419 type = gfc_get_complex_type (ts.kind);
3420 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3421 retargs = gfc_chainon_list (retargs, var);
3424 /* Add the string length to the argument list. */
3425 if (ts.type == BT_CHARACTER)
3426 retargs = gfc_chainon_list (retargs, len);
3428 gfc_free_interface_mapping (&mapping);
3430 /* Add the return arguments. */
3431 arglist = chainon (retargs, arglist);
3433 /* Add the hidden string length parameters to the arguments. */
3434 arglist = chainon (arglist, stringargs);
3436 /* We may want to append extra arguments here. This is used e.g. for
3437 calls to libgfortran_matmul_??, which need extra information. */
3438 if (append_args != NULL_TREE)
3439 arglist = chainon (arglist, append_args);
3441 /* Generate the actual call. */
3442 conv_function_val (se, sym, expr);
3444 /* If there are alternate return labels, function type should be
3445 integer. Can't modify the type in place though, since it can be shared
3446 with other functions. For dummy arguments, the typing is done to
3447 to this result, even if it has to be repeated for each call. */
3448 if (has_alternate_specifier
3449 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3451 if (!sym->attr.dummy)
3453 TREE_TYPE (sym->backend_decl)
3454 = build_function_type (integer_type_node,
3455 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3456 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3459 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3462 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3463 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3465 /* If we have a pointer function, but we don't want a pointer, e.g.
3468 where f is pointer valued, we have to dereference the result. */
3469 if (!se->want_pointer && !byref
3470 && (sym->attr.pointer || sym->attr.allocatable)
3471 && !gfc_is_proc_ptr_comp (expr, NULL))
3472 se->expr = build_fold_indirect_ref_loc (input_location,
3475 /* f2c calling conventions require a scalar default real function to
3476 return a double precision result. Convert this back to default
3477 real. We only care about the cases that can happen in Fortran 77.
3479 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3480 && sym->ts.kind == gfc_default_real_kind
3481 && !sym->attr.always_explicit)
3482 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3484 /* A pure function may still have side-effects - it may modify its
3486 TREE_SIDE_EFFECTS (se->expr) = 1;
3488 if (!sym->attr.pure)
3489 TREE_SIDE_EFFECTS (se->expr) = 1;
3494 /* Add the function call to the pre chain. There is no expression. */
3495 gfc_add_expr_to_block (&se->pre, se->expr);
3496 se->expr = NULL_TREE;
3498 if (!se->direct_byref)
3500 if (sym->attr.dimension || (comp && comp->attr.dimension))
3502 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3504 /* Check the data pointer hasn't been modified. This would
3505 happen in a function returning a pointer. */
3506 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3507 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3509 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3512 se->expr = info->descriptor;
3513 /* Bundle in the string length. */
3514 se->string_length = len;
3516 else if (ts.type == BT_CHARACTER)
3518 /* Dereference for character pointer results. */
3519 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3520 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3521 se->expr = build_fold_indirect_ref_loc (input_location, var);
3525 se->string_length = len;
3529 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3530 se->expr = build_fold_indirect_ref_loc (input_location, var);
3535 /* Follow the function call with the argument post block. */
3538 gfc_add_block_to_block (&se->pre, &post);
3540 /* Transformational functions of derived types with allocatable
3541 components must have the result allocatable components copied. */
3542 arg = expr->value.function.actual;
3543 if (result && arg && expr->rank
3544 && expr->value.function.isym
3545 && expr->value.function.isym->transformational
3546 && arg->expr->ts.type == BT_DERIVED
3547 && arg->expr->ts.u.derived->attr.alloc_comp)
3550 /* Copy the allocatable components. We have to use a
3551 temporary here to prevent source allocatable components
3552 from being corrupted. */
3553 tmp2 = gfc_evaluate_now (result, &se->pre);
3554 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3555 result, tmp2, expr->rank);
3556 gfc_add_expr_to_block (&se->pre, tmp);
3557 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3559 gfc_add_expr_to_block (&se->pre, tmp);
3561 /* Finally free the temporary's data field. */
3562 tmp = gfc_conv_descriptor_data_get (tmp2);
3563 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3564 gfc_add_expr_to_block (&se->pre, tmp);
3568 gfc_add_block_to_block (&se->post, &post);
3570 return has_alternate_specifier;
3574 /* Fill a character string with spaces. */
3577 fill_with_spaces (tree start, tree type, tree size)
3579 stmtblock_t block, loop;
3580 tree i, el, exit_label, cond, tmp;
3582 /* For a simple char type, we can call memset(). */
3583 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3584 return build_call_expr_loc (input_location,
3585 built_in_decls[BUILT_IN_MEMSET], 3, start,
3586 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3587 lang_hooks.to_target_charset (' ')),
3590 /* Otherwise, we use a loop:
3591 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3595 /* Initialize variables. */
3596 gfc_init_block (&block);
3597 i = gfc_create_var (sizetype, "i");
3598 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3599 el = gfc_create_var (build_pointer_type (type), "el");
3600 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3601 exit_label = gfc_build_label_decl (NULL_TREE);
3602 TREE_USED (exit_label) = 1;
3606 gfc_init_block (&loop);
3608 /* Exit condition. */
3609 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3610 fold_convert (sizetype, integer_zero_node));
3611 tmp = build1_v (GOTO_EXPR, exit_label);
3612 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3613 build_empty_stmt (input_location));
3614 gfc_add_expr_to_block (&loop, tmp);
3617 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3618 build_int_cst (type,
3619 lang_hooks.to_target_charset (' ')));
3621 /* Increment loop variables. */
3622 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3623 TYPE_SIZE_UNIT (type)));
3624 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3626 TYPE_SIZE_UNIT (type)));
3628 /* Making the loop... actually loop! */
3629 tmp = gfc_finish_block (&loop);
3630 tmp = build1_v (LOOP_EXPR, tmp);
3631 gfc_add_expr_to_block (&block, tmp);
3633 /* The exit label. */
3634 tmp = build1_v (LABEL_EXPR, exit_label);
3635 gfc_add_expr_to_block (&block, tmp);
3638 return gfc_finish_block (&block);
3642 /* Generate code to copy a string. */
3645 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3646 int dkind, tree slength, tree src, int skind)
3648 tree tmp, dlen, slen;
3657 stmtblock_t tempblock;
3659 gcc_assert (dkind == skind);
3661 if (slength != NULL_TREE)
3663 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3664 ssc = string_to_single_character (slen, src, skind);
3668 slen = build_int_cst (size_type_node, 1);
3672 if (dlength != NULL_TREE)
3674 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3675 dsc = string_to_single_character (slen, dest, dkind);
3679 dlen = build_int_cst (size_type_node, 1);
3683 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3684 ssc = string_to_single_character (slen, src, skind);
3685 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3686 dsc = string_to_single_character (dlen, dest, dkind);
3689 /* Assign directly if the types are compatible. */
3690 if (dsc != NULL_TREE && ssc != NULL_TREE
3691 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3693 gfc_add_modify (block, dsc, ssc);
3697 /* Do nothing if the destination length is zero. */
3698 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3699 build_int_cst (size_type_node, 0));
3701 /* The following code was previously in _gfortran_copy_string:
3703 // The two strings may overlap so we use memmove.
3705 copy_string (GFC_INTEGER_4 destlen, char * dest,
3706 GFC_INTEGER_4 srclen, const char * src)
3708 if (srclen >= destlen)
3710 // This will truncate if too long.
3711 memmove (dest, src, destlen);
3715 memmove (dest, src, srclen);
3717 memset (&dest[srclen], ' ', destlen - srclen);
3721 We're now doing it here for better optimization, but the logic
3724 /* For non-default character kinds, we have to multiply the string
3725 length by the base type size. */
3726 chartype = gfc_get_char_type (dkind);
3727 slen = fold_build2 (MULT_EXPR, size_type_node,
3728 fold_convert (size_type_node, slen),
3729 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3730 dlen = fold_build2 (MULT_EXPR, size_type_node,
3731 fold_convert (size_type_node, dlen),
3732 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3735 dest = fold_convert (pvoid_type_node, dest);
3737 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3740 src = fold_convert (pvoid_type_node, src);
3742 src = gfc_build_addr_expr (pvoid_type_node, src);
3744 /* Truncate string if source is too long. */
3745 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3746 tmp2 = build_call_expr_loc (input_location,
3747 built_in_decls[BUILT_IN_MEMMOVE],
3748 3, dest, src, dlen);
3750 /* Else copy and pad with spaces. */
3751 tmp3 = build_call_expr_loc (input_location,
3752 built_in_decls[BUILT_IN_MEMMOVE],
3753 3, dest, src, slen);
3755 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3756 fold_convert (sizetype, slen));
3757 tmp4 = fill_with_spaces (tmp4, chartype,
3758 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3761 gfc_init_block (&tempblock);
3762 gfc_add_expr_to_block (&tempblock, tmp3);
3763 gfc_add_expr_to_block (&tempblock, tmp4);
3764 tmp3 = gfc_finish_block (&tempblock);
3766 /* The whole copy_string function is there. */
3767 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3768 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3769 build_empty_stmt (input_location));
3770 gfc_add_expr_to_block (block, tmp);
3774 /* Translate a statement function.
3775 The value of a statement function reference is obtained by evaluating the
3776 expression using the values of the actual arguments for the values of the
3777 corresponding dummy arguments. */
3780 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3784 gfc_formal_arglist *fargs;
3785 gfc_actual_arglist *args;
3788 gfc_saved_var *saved_vars;
3794 sym = expr->symtree->n.sym;
3795 args = expr->value.function.actual;
3796 gfc_init_se (&lse, NULL);
3797 gfc_init_se (&rse, NULL);
3800 for (fargs = sym->formal; fargs; fargs = fargs->next)
3802 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3803 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3805 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3807 /* Each dummy shall be specified, explicitly or implicitly, to be
3809 gcc_assert (fargs->sym->attr.dimension == 0);
3812 /* Create a temporary to hold the value. */
3813 type = gfc_typenode_for_spec (&fsym->ts);
3814 temp_vars[n] = gfc_create_var (type, fsym->name);
3816 if (fsym->ts.type == BT_CHARACTER)
3818 /* Copy string arguments. */
3821 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3822 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3824 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3825 tmp = gfc_build_addr_expr (build_pointer_type (type),
3828 gfc_conv_expr (&rse, args->expr);
3829 gfc_conv_string_parameter (&rse);
3830 gfc_add_block_to_block (&se->pre, &lse.pre);
3831 gfc_add_block_to_block (&se->pre, &rse.pre);
3833 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3834 rse.string_length, rse.expr, fsym->ts.kind);
3835 gfc_add_block_to_block (&se->pre, &lse.post);
3836 gfc_add_block_to_block (&se->pre, &rse.post);
3840 /* For everything else, just evaluate the expression. */
3841 gfc_conv_expr (&lse, args->expr);
3843 gfc_add_block_to_block (&se->pre, &lse.pre);
3844 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3845 gfc_add_block_to_block (&se->pre, &lse.post);
3851 /* Use the temporary variables in place of the real ones. */
3852 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3853 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3855 gfc_conv_expr (se, sym->value);
3857 if (sym->ts.type == BT_CHARACTER)
3859 gfc_conv_const_charlen (sym->ts.u.cl);
3861 /* Force the expression to the correct length. */
3862 if (!INTEGER_CST_P (se->string_length)
3863 || tree_int_cst_lt (se->string_length,
3864 sym->ts.u.cl->backend_decl))
3866 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3867 tmp = gfc_create_var (type, sym->name);
3868 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3869 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3870 sym->ts.kind, se->string_length, se->expr,
3874 se->string_length = sym->ts.u.cl->backend_decl;
3877 /* Restore the original variables. */
3878 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3879 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3880 gfc_free (saved_vars);
3884 /* Translate a function expression. */
3887 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3891 if (expr->value.function.isym)
3893 gfc_conv_intrinsic_function (se, expr);
3897 /* We distinguish statement functions from general functions to improve
3898 runtime performance. */
3899 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3901 gfc_conv_statement_function (se, expr);
3905 /* expr.value.function.esym is the resolved (specific) function symbol for
3906 most functions. However this isn't set for dummy procedures. */
3907 sym = expr->value.function.esym;
3909 sym = expr->symtree->n.sym;
3911 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3916 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3919 is_zero_initializer_p (gfc_expr * expr)
3921 if (expr->expr_type != EXPR_CONSTANT)
3924 /* We ignore constants with prescribed memory representations for now. */
3925 if (expr->representation.string)
3928 switch (expr->ts.type)
3931 return mpz_cmp_si (expr->value.integer, 0) == 0;
3934 return mpfr_zero_p (expr->value.real)
3935 && MPFR_SIGN (expr->value.real) >= 0;
3938 return expr->value.logical == 0;
3941 return mpfr_zero_p (mpc_realref (expr->value.complex))
3942 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3943 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3944 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3954 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3956 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3957 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3959 gfc_conv_tmp_array_ref (se);
3960 gfc_advance_se_ss_chain (se);
3964 /* Build a static initializer. EXPR is the expression for the initial value.
3965 The other parameters describe the variable of the component being
3966 initialized. EXPR may be null. */
3969 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3970 bool array, bool pointer)
3974 if (!(expr || pointer))
3977 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3978 (these are the only two iso_c_binding derived types that can be
3979 used as initialization expressions). If so, we need to modify
3980 the 'expr' to be that for a (void *). */
3981 if (expr != NULL && expr->ts.type == BT_DERIVED
3982 && expr->ts.is_iso_c && expr->ts.u.derived)
3984 gfc_symbol *derived = expr->ts.u.derived;
3986 expr = gfc_int_expr (0);
3988 /* The derived symbol has already been converted to a (void *). Use
3990 expr->ts.f90_type = derived->ts.f90_type;
3991 expr->ts.kind = derived->ts.kind;
3993 gfc_init_se (&se, NULL);
3994 gfc_conv_constant (&se, expr);
4000 /* Arrays need special handling. */
4002 return gfc_build_null_descriptor (type);
4003 /* Special case assigning an array to zero. */
4004 else if (is_zero_initializer_p (expr))
4005 return build_constructor (type, NULL);
4007 return gfc_conv_array_initializer (type, expr);
4010 return fold_convert (type, null_pointer_node);
4017 gfc_init_se (&se, NULL);
4018 gfc_conv_structure (&se, expr, 1);
4022 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4025 gfc_init_se (&se, NULL);
4026 gfc_conv_constant (&se, expr);
4033 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4045 gfc_start_block (&block);
4047 /* Initialize the scalarizer. */
4048 gfc_init_loopinfo (&loop);
4050 gfc_init_se (&lse, NULL);
4051 gfc_init_se (&rse, NULL);
4054 rss = gfc_walk_expr (expr);
4055 if (rss == gfc_ss_terminator)
4057 /* The rhs is scalar. Add a ss for the expression. */
4058 rss = gfc_get_ss ();
4059 rss->next = gfc_ss_terminator;
4060 rss->type = GFC_SS_SCALAR;
4064 /* Create a SS for the destination. */
4065 lss = gfc_get_ss ();
4066 lss->type = GFC_SS_COMPONENT;
4068 lss->shape = gfc_get_shape (cm->as->rank);
4069 lss->next = gfc_ss_terminator;
4070 lss->data.info.dimen = cm->as->rank;
4071 lss->data.info.descriptor = dest;
4072 lss->data.info.data = gfc_conv_array_data (dest);
4073 lss->data.info.offset = gfc_conv_array_offset (dest);
4074 for (n = 0; n < cm->as->rank; n++)
4076 lss->data.info.dim[n] = n;
4077 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4078 lss->data.info.stride[n] = gfc_index_one_node;
4080 mpz_init (lss->shape[n]);
4081 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4082 cm->as->lower[n]->value.integer);
4083 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4086 /* Associate the SS with the loop. */
4087 gfc_add_ss_to_loop (&loop, lss);
4088 gfc_add_ss_to_loop (&loop, rss);
4090 /* Calculate the bounds of the scalarization. */
4091 gfc_conv_ss_startstride (&loop);
4093 /* Setup the scalarizing loops. */
4094 gfc_conv_loop_setup (&loop, &expr->where);
4096 /* Setup the gfc_se structures. */
4097 gfc_copy_loopinfo_to_se (&lse, &loop);
4098 gfc_copy_loopinfo_to_se (&rse, &loop);
4101 gfc_mark_ss_chain_used (rss, 1);
4103 gfc_mark_ss_chain_used (lss, 1);
4105 /* Start the scalarized loop body. */
4106 gfc_start_scalarized_body (&loop, &body);
4108 gfc_conv_tmp_array_ref (&lse);
4109 if (cm->ts.type == BT_CHARACTER)
4110 lse.string_length = cm->ts.u.cl->backend_decl;
4112 gfc_conv_expr (&rse, expr);
4114 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4115 gfc_add_expr_to_block (&body, tmp);
4117 gcc_assert (rse.ss == gfc_ss_terminator);
4119 /* Generate the copying loops. */
4120 gfc_trans_scalarizing_loops (&loop, &body);
4122 /* Wrap the whole thing up. */
4123 gfc_add_block_to_block (&block, &loop.pre);
4124 gfc_add_block_to_block (&block, &loop.post);
4126 for (n = 0; n < cm->as->rank; n++)
4127 mpz_clear (lss->shape[n]);
4128 gfc_free (lss->shape);
4130 gfc_cleanup_loop (&loop);
4132 return gfc_finish_block (&block);
4137 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4148 gfc_expr *arg = NULL;
4150 gfc_start_block (&block);
4151 gfc_init_se (&se, NULL);
4153 /* Get the descriptor for the expressions. */
4154 rss = gfc_walk_expr (expr);
4155 se.want_pointer = 0;
4156 gfc_conv_expr_descriptor (&se, expr, rss);
4157 gfc_add_block_to_block (&block, &se.pre);
4158 gfc_add_modify (&block, dest, se.expr);
4160 /* Deal with arrays of derived types with allocatable components. */
4161 if (cm->ts.type == BT_DERIVED
4162 && cm->ts.u.derived->attr.alloc_comp)
4163 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4167 tmp = gfc_duplicate_allocatable (dest, se.expr,
4168 TREE_TYPE(cm->backend_decl),
4171 gfc_add_expr_to_block (&block, tmp);
4172 gfc_add_block_to_block (&block, &se.post);
4174 if (expr->expr_type != EXPR_VARIABLE)
4175 gfc_conv_descriptor_data_set (&block, se.expr,
4178 /* We need to know if the argument of a conversion function is a
4179 variable, so that the correct lower bound can be used. */
4180 if (expr->expr_type == EXPR_FUNCTION
4181 && expr->value.function.isym
4182 && expr->value.function.isym->conversion
4183 && expr->value.function.actual->expr
4184 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4185 arg = expr->value.function.actual->expr;
4187 /* Obtain the array spec of full array references. */
4189 as = gfc_get_full_arrayspec_from_expr (arg);
4191 as = gfc_get_full_arrayspec_from_expr (expr);
4193 /* Shift the lbound and ubound of temporaries to being unity,
4194 rather than zero, based. Always calculate the offset. */
4195 offset = gfc_conv_descriptor_offset_get (dest);
4196 gfc_add_modify (&block, offset, gfc_index_zero_node);
4197 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4199 for (n = 0; n < expr->rank; n++)
4204 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4205 TODO It looks as if gfc_conv_expr_descriptor should return
4206 the correct bounds and that the following should not be
4207 necessary. This would simplify gfc_conv_intrinsic_bound
4209 if (as && as->lower[n])
4212 gfc_init_se (&lbse, NULL);
4213 gfc_conv_expr (&lbse, as->lower[n]);
4214 gfc_add_block_to_block (&block, &lbse.pre);
4215 lbound = gfc_evaluate_now (lbse.expr, &block);
4219 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4220 lbound = gfc_conv_descriptor_lbound_get (tmp,
4224 lbound = gfc_conv_descriptor_lbound_get (dest,
4227 lbound = gfc_index_one_node;
4229 lbound = fold_convert (gfc_array_index_type, lbound);
4231 /* Shift the bounds and set the offset accordingly. */
4232 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4233 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4234 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4235 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4236 gfc_conv_descriptor_ubound_set (&block, dest,
4237 gfc_rank_cst[n], tmp);
4238 gfc_conv_descriptor_lbound_set (&block, dest,
4239 gfc_rank_cst[n], lbound);
4241 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4242 gfc_conv_descriptor_lbound_get (dest,
4244 gfc_conv_descriptor_stride_get (dest,
4246 gfc_add_modify (&block, tmp2, tmp);
4247 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4248 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4253 /* If a conversion expression has a null data pointer
4254 argument, nullify the allocatable component. */
4258 if (arg->symtree->n.sym->attr.allocatable
4259 || arg->symtree->n.sym->attr.pointer)
4261 non_null_expr = gfc_finish_block (&block);
4262 gfc_start_block (&block);
4263 gfc_conv_descriptor_data_set (&block, dest,
4265 null_expr = gfc_finish_block (&block);
4266 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4267 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4268 fold_convert (TREE_TYPE (tmp),
4269 null_pointer_node));
4270 return build3_v (COND_EXPR, tmp,
4271 null_expr, non_null_expr);
4275 return gfc_finish_block (&block);
4279 /* Assign a single component of a derived type constructor. */
4282 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4290 gfc_start_block (&block);
4292 if (cm->attr.pointer)
4294 gfc_init_se (&se, NULL);
4295 /* Pointer component. */
4296 if (cm->attr.dimension)
4298 /* Array pointer. */
4299 if (expr->expr_type == EXPR_NULL)
4300 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4303 rss = gfc_walk_expr (expr);
4304 se.direct_byref = 1;
4306 gfc_conv_expr_descriptor (&se, expr, rss);
4307 gfc_add_block_to_block (&block, &se.pre);
4308 gfc_add_block_to_block (&block, &se.post);
4313 /* Scalar pointers. */
4314 se.want_pointer = 1;
4315 gfc_conv_expr (&se, expr);
4316 gfc_add_block_to_block (&block, &se.pre);
4317 gfc_add_modify (&block, dest,
4318 fold_convert (TREE_TYPE (dest), se.expr));
4319 gfc_add_block_to_block (&block, &se.post);
4322 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4324 /* NULL initialization for CLASS components. */
4325 tmp = gfc_trans_structure_assign (dest,
4326 gfc_default_initializer (&cm->ts));
4327 gfc_add_expr_to_block (&block, tmp);
4329 else if (cm->attr.dimension)
4331 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4332 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4333 else if (cm->attr.allocatable)
4335 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4336 gfc_add_expr_to_block (&block, tmp);
4340 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4341 gfc_add_expr_to_block (&block, tmp);
4344 else if (expr->ts.type == BT_DERIVED)
4346 if (expr->expr_type != EXPR_STRUCTURE)
4348 gfc_init_se (&se, NULL);
4349 gfc_conv_expr (&se, expr);
4350 gfc_add_block_to_block (&block, &se.pre);
4351 gfc_add_modify (&block, dest,
4352 fold_convert (TREE_TYPE (dest), se.expr));
4353 gfc_add_block_to_block (&block, &se.post);
4357 /* Nested constructors. */
4358 tmp = gfc_trans_structure_assign (dest, expr);
4359 gfc_add_expr_to_block (&block, tmp);
4364 /* Scalar component. */
4365 gfc_init_se (&se, NULL);
4366 gfc_init_se (&lse, NULL);
4368 gfc_conv_expr (&se, expr);
4369 if (cm->ts.type == BT_CHARACTER)
4370 lse.string_length = cm->ts.u.cl->backend_decl;
4372 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4373 gfc_add_expr_to_block (&block, tmp);
4375 return gfc_finish_block (&block);
4378 /* Assign a derived type constructor to a variable. */
4381 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4389 gfc_start_block (&block);
4390 cm = expr->ts.u.derived->components;
4391 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4393 /* Skip absent members in default initializers. */
4397 /* Handle c_null_(fun)ptr. */
4398 if (c && c->expr && c->expr->ts.is_iso_c)
4400 field = cm->backend_decl;
4401 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4402 dest, field, NULL_TREE);
4403 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4404 fold_convert (TREE_TYPE (tmp),
4405 null_pointer_node));
4406 gfc_add_expr_to_block (&block, tmp);
4410 field = cm->backend_decl;
4411 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4412 dest, field, NULL_TREE);
4413 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4414 gfc_add_expr_to_block (&block, tmp);
4416 return gfc_finish_block (&block);
4419 /* Build an expression for a constructor. If init is nonzero then
4420 this is part of a static variable initializer. */
4423 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4430 VEC(constructor_elt,gc) *v = NULL;
4432 gcc_assert (se->ss == NULL);
4433 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4434 type = gfc_typenode_for_spec (&expr->ts);
4438 /* Create a temporary variable and fill it in. */
4439 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4440 tmp = gfc_trans_structure_assign (se->expr, expr);
4441 gfc_add_expr_to_block (&se->pre, tmp);
4445 cm = expr->ts.u.derived->components;
4447 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4449 /* Skip absent members in default initializers and allocatable
4450 components. Although the latter have a default initializer
4451 of EXPR_NULL,... by default, the static nullify is not needed
4452 since this is done every time we come into scope. */
4453 if (!c->expr || cm->attr.allocatable)
4456 if (cm->ts.type == BT_CLASS)
4458 gfc_component *data;
4459 data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
4460 if (!data->backend_decl)
4461 gfc_get_derived_type (cm->ts.u.derived);
4462 val = gfc_conv_initializer (c->expr, &cm->ts,
4463 TREE_TYPE (data->backend_decl),
4464 data->attr.dimension,
4465 data->attr.pointer);
4467 CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
4469 else if (strcmp (cm->name, "$size") == 0)
4471 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4472 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4474 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4475 && strcmp (cm->name, "$extends") == 0)
4478 vtabs = cm->initializer->symtree->n.sym;
4479 val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4480 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4484 val = gfc_conv_initializer (c->expr, &cm->ts,
4485 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4486 cm->attr.pointer || cm->attr.proc_pointer);
4488 /* Append it to the constructor list. */
4489 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4492 se->expr = build_constructor (type, v);
4494 TREE_CONSTANT (se->expr) = 1;
4498 /* Translate a substring expression. */
4501 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4507 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4509 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4510 expr->value.character.length,
4511 expr->value.character.string);
4513 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4514 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4517 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4521 /* Entry point for expression translation. Evaluates a scalar quantity.
4522 EXPR is the expression to be translated, and SE is the state structure if
4523 called from within the scalarized. */
4526 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4528 if (se->ss && se->ss->expr == expr
4529 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4531 /* Substitute a scalar expression evaluated outside the scalarization
4533 se->expr = se->ss->data.scalar.expr;
4534 se->string_length = se->ss->string_length;
4535 gfc_advance_se_ss_chain (se);
4539 /* We need to convert the expressions for the iso_c_binding derived types.
4540 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4541 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4542 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4543 updated to be an integer with a kind equal to the size of a (void *). */
4544 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4545 && expr->ts.u.derived->attr.is_iso_c)
4547 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4548 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4550 /* Set expr_type to EXPR_NULL, which will result in
4551 null_pointer_node being used below. */
4552 expr->expr_type = EXPR_NULL;
4556 /* Update the type/kind of the expression to be what the new
4557 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4558 expr->ts.type = expr->ts.u.derived->ts.type;
4559 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4560 expr->ts.kind = expr->ts.u.derived->ts.kind;
4564 switch (expr->expr_type)
4567 gfc_conv_expr_op (se, expr);
4571 gfc_conv_function_expr (se, expr);
4575 gfc_conv_constant (se, expr);
4579 gfc_conv_variable (se, expr);
4583 se->expr = null_pointer_node;
4586 case EXPR_SUBSTRING:
4587 gfc_conv_substring_expr (se, expr);
4590 case EXPR_STRUCTURE:
4591 gfc_conv_structure (se, expr, 0);
4595 gfc_conv_array_constructor_expr (se, expr);
4604 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4605 of an assignment. */
4607 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4609 gfc_conv_expr (se, expr);
4610 /* All numeric lvalues should have empty post chains. If not we need to
4611 figure out a way of rewriting an lvalue so that it has no post chain. */
4612 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4615 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4616 numeric expressions. Used for scalar values where inserting cleanup code
4619 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4623 gcc_assert (expr->ts.type != BT_CHARACTER);
4624 gfc_conv_expr (se, expr);
4627 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4628 gfc_add_modify (&se->pre, val, se->expr);
4630 gfc_add_block_to_block (&se->pre, &se->post);
4634 /* Helper to translate an expression and convert it to a particular type. */
4636 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4638 gfc_conv_expr_val (se, expr);
4639 se->expr = convert (type, se->expr);
4643 /* Converts an expression so that it can be passed by reference. Scalar
4647 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4651 if (se->ss && se->ss->expr == expr
4652 && se->ss->type == GFC_SS_REFERENCE)
4654 se->expr = se->ss->data.scalar.expr;
4655 se->string_length = se->ss->string_length;
4656 gfc_advance_se_ss_chain (se);
4660 if (expr->ts.type == BT_CHARACTER)
4662 gfc_conv_expr (se, expr);
4663 gfc_conv_string_parameter (se);
4667 if (expr->expr_type == EXPR_VARIABLE)
4669 se->want_pointer = 1;
4670 gfc_conv_expr (se, expr);
4673 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4674 gfc_add_modify (&se->pre, var, se->expr);
4675 gfc_add_block_to_block (&se->pre, &se->post);
4681 if (expr->expr_type == EXPR_FUNCTION
4682 && ((expr->value.function.esym
4683 && expr->value.function.esym->result->attr.pointer
4684 && !expr->value.function.esym->result->attr.dimension)
4685 || (!expr->value.function.esym
4686 && expr->symtree->n.sym->attr.pointer
4687 && !expr->symtree->n.sym->attr.dimension)))
4689 se->want_pointer = 1;
4690 gfc_conv_expr (se, expr);
4691 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4692 gfc_add_modify (&se->pre, var, se->expr);
4698 gfc_conv_expr (se, expr);
4700 /* Create a temporary var to hold the value. */
4701 if (TREE_CONSTANT (se->expr))
4703 tree tmp = se->expr;
4704 STRIP_TYPE_NOPS (tmp);
4705 var = build_decl (input_location,
4706 CONST_DECL, NULL, TREE_TYPE (tmp));
4707 DECL_INITIAL (var) = tmp;
4708 TREE_STATIC (var) = 1;
4713 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4714 gfc_add_modify (&se->pre, var, se->expr);
4716 gfc_add_block_to_block (&se->pre, &se->post);
4718 /* Take the address of that value. */
4719 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4724 gfc_trans_pointer_assign (gfc_code * code)
4726 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4730 /* Generate code for a pointer assignment. */
4733 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4744 gfc_start_block (&block);
4746 gfc_init_se (&lse, NULL);
4748 lss = gfc_walk_expr (expr1);
4749 rss = gfc_walk_expr (expr2);
4750 if (lss == gfc_ss_terminator)
4752 /* Scalar pointers. */
4753 lse.want_pointer = 1;
4754 gfc_conv_expr (&lse, expr1);
4755 gcc_assert (rss == gfc_ss_terminator);
4756 gfc_init_se (&rse, NULL);
4757 rse.want_pointer = 1;
4758 gfc_conv_expr (&rse, expr2);
4760 if (expr1->symtree->n.sym->attr.proc_pointer
4761 && expr1->symtree->n.sym->attr.dummy)
4762 lse.expr = build_fold_indirect_ref_loc (input_location,
4765 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4766 && expr2->symtree->n.sym->attr.dummy)
4767 rse.expr = build_fold_indirect_ref_loc (input_location,
4770 gfc_add_block_to_block (&block, &lse.pre);
4771 gfc_add_block_to_block (&block, &rse.pre);
4773 /* Check character lengths if character expression. The test is only
4774 really added if -fbounds-check is enabled. */
4775 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4776 && !expr1->symtree->n.sym->attr.proc_pointer
4777 && !gfc_is_proc_ptr_comp (expr1, NULL))
4779 gcc_assert (expr2->ts.type == BT_CHARACTER);
4780 gcc_assert (lse.string_length && rse.string_length);
4781 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4782 lse.string_length, rse.string_length,
4786 gfc_add_modify (&block, lse.expr,
4787 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4789 gfc_add_block_to_block (&block, &rse.post);
4790 gfc_add_block_to_block (&block, &lse.post);
4795 tree strlen_rhs = NULL_TREE;
4797 /* Array pointer. */
4798 gfc_conv_expr_descriptor (&lse, expr1, lss);
4799 strlen_lhs = lse.string_length;
4800 switch (expr2->expr_type)
4803 /* Just set the data pointer to null. */
4804 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4808 /* Assign directly to the pointer's descriptor. */
4809 lse.direct_byref = 1;
4810 gfc_conv_expr_descriptor (&lse, expr2, rss);
4811 strlen_rhs = lse.string_length;
4813 /* If this is a subreference array pointer assignment, use the rhs
4814 descriptor element size for the lhs span. */
4815 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4817 decl = expr1->symtree->n.sym->backend_decl;
4818 gfc_init_se (&rse, NULL);
4819 rse.descriptor_only = 1;
4820 gfc_conv_expr (&rse, expr2);
4821 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4822 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4823 if (!INTEGER_CST_P (tmp))
4824 gfc_add_block_to_block (&lse.post, &rse.pre);
4825 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4831 /* Assign to a temporary descriptor and then copy that
4832 temporary to the pointer. */
4834 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4837 lse.direct_byref = 1;
4838 gfc_conv_expr_descriptor (&lse, expr2, rss);
4839 strlen_rhs = lse.string_length;
4840 gfc_add_modify (&lse.pre, desc, tmp);
4844 gfc_add_block_to_block (&block, &lse.pre);
4846 /* Check string lengths if applicable. The check is only really added
4847 to the output code if -fbounds-check is enabled. */
4848 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4850 gcc_assert (expr2->ts.type == BT_CHARACTER);
4851 gcc_assert (strlen_lhs && strlen_rhs);
4852 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4853 strlen_lhs, strlen_rhs, &block);
4856 gfc_add_block_to_block (&block, &lse.post);
4858 return gfc_finish_block (&block);
4862 /* Makes sure se is suitable for passing as a function string parameter. */
4863 /* TODO: Need to check all callers of this function. It may be abused. */
4866 gfc_conv_string_parameter (gfc_se * se)
4870 if (TREE_CODE (se->expr) == STRING_CST)
4872 type = TREE_TYPE (TREE_TYPE (se->expr));
4873 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4877 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4879 if (TREE_CODE (se->expr) != INDIRECT_REF)
4881 type = TREE_TYPE (se->expr);
4882 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4886 type = gfc_get_character_type_len (gfc_default_character_kind,
4888 type = build_pointer_type (type);
4889 se->expr = gfc_build_addr_expr (type, se->expr);
4893 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4894 gcc_assert (se->string_length
4895 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4899 /* Generate code for assignment of scalar variables. Includes character
4900 strings and derived types with allocatable components.
4901 If you know that the LHS has no allocations, set dealloc to false. */
4904 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4905 bool l_is_temp, bool r_is_var, bool dealloc)
4911 gfc_init_block (&block);
4913 if (ts.type == BT_CHARACTER)
4918 if (lse->string_length != NULL_TREE)
4920 gfc_conv_string_parameter (lse);
4921 gfc_add_block_to_block (&block, &lse->pre);
4922 llen = lse->string_length;
4925 if (rse->string_length != NULL_TREE)
4927 gcc_assert (rse->string_length != NULL_TREE);
4928 gfc_conv_string_parameter (rse);
4929 gfc_add_block_to_block (&block, &rse->pre);
4930 rlen = rse->string_length;
4933 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4934 rse->expr, ts.kind);
4936 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4940 /* Are the rhs and the lhs the same? */
4943 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4944 gfc_build_addr_expr (NULL_TREE, lse->expr),
4945 gfc_build_addr_expr (NULL_TREE, rse->expr));
4946 cond = gfc_evaluate_now (cond, &lse->pre);
4949 /* Deallocate the lhs allocated components as long as it is not
4950 the same as the rhs. This must be done following the assignment
4951 to prevent deallocating data that could be used in the rhs
4953 if (!l_is_temp && dealloc)
4955 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4956 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4958 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4960 gfc_add_expr_to_block (&lse->post, tmp);
4963 gfc_add_block_to_block (&block, &rse->pre);
4964 gfc_add_block_to_block (&block, &lse->pre);
4966 gfc_add_modify (&block, lse->expr,
4967 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4969 /* Do a deep copy if the rhs is a variable, if it is not the
4973 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4974 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4976 gfc_add_expr_to_block (&block, tmp);
4979 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4981 gfc_add_block_to_block (&block, &lse->pre);
4982 gfc_add_block_to_block (&block, &rse->pre);
4983 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4984 gfc_add_modify (&block, lse->expr, tmp);
4988 gfc_add_block_to_block (&block, &lse->pre);
4989 gfc_add_block_to_block (&block, &rse->pre);
4991 gfc_add_modify (&block, lse->expr,
4992 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4995 gfc_add_block_to_block (&block, &lse->post);
4996 gfc_add_block_to_block (&block, &rse->post);
4998 return gfc_finish_block (&block);
5002 /* Try to translate array(:) = func (...), where func is a transformational
5003 array function, without using a temporary. Returns NULL is this isn't the
5007 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5012 bool seen_array_ref;
5014 gfc_component *comp = NULL;
5016 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5017 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5020 /* Elemental functions don't need a temporary anyway. */
5021 if (expr2->value.function.esym != NULL
5022 && expr2->value.function.esym->attr.elemental)
5025 /* Fail if rhs is not FULL or a contiguous section. */
5026 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5029 /* Fail if EXPR1 can't be expressed as a descriptor. */
5030 if (gfc_ref_needs_temporary_p (expr1->ref))
5033 /* Functions returning pointers need temporaries. */
5034 if (expr2->symtree->n.sym->attr.pointer
5035 || expr2->symtree->n.sym->attr.allocatable)
5038 /* Character array functions need temporaries unless the
5039 character lengths are the same. */
5040 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5042 if (expr1->ts.u.cl->length == NULL
5043 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5046 if (expr2->ts.u.cl->length == NULL
5047 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5050 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5051 expr2->ts.u.cl->length->value.integer) != 0)
5055 /* Check that no LHS component references appear during an array
5056 reference. This is needed because we do not have the means to
5057 span any arbitrary stride with an array descriptor. This check
5058 is not needed for the rhs because the function result has to be
5060 seen_array_ref = false;
5061 for (ref = expr1->ref; ref; ref = ref->next)
5063 if (ref->type == REF_ARRAY)
5064 seen_array_ref= true;
5065 else if (ref->type == REF_COMPONENT && seen_array_ref)
5069 /* Check for a dependency. */
5070 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5071 expr2->value.function.esym,
5072 expr2->value.function.actual,
5076 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5078 gcc_assert (expr2->value.function.isym
5079 || (gfc_is_proc_ptr_comp (expr2, &comp)
5080 && comp && comp->attr.dimension)
5081 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5082 && expr2->value.function.esym->result->attr.dimension));
5084 ss = gfc_walk_expr (expr1);
5085 gcc_assert (ss != gfc_ss_terminator);
5086 gfc_init_se (&se, NULL);
5087 gfc_start_block (&se.pre);
5088 se.want_pointer = 1;
5090 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5092 if (expr1->ts.type == BT_DERIVED
5093 && expr1->ts.u.derived->attr.alloc_comp)
5096 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5098 gfc_add_expr_to_block (&se.pre, tmp);
5101 se.direct_byref = 1;
5102 se.ss = gfc_walk_expr (expr2);
5103 gcc_assert (se.ss != gfc_ss_terminator);
5104 gfc_conv_function_expr (&se, expr2);
5105 gfc_add_block_to_block (&se.pre, &se.post);
5107 return gfc_finish_block (&se.pre);
5111 /* Try to efficiently translate array(:) = 0. Return NULL if this
5115 gfc_trans_zero_assign (gfc_expr * expr)
5117 tree dest, len, type;
5121 sym = expr->symtree->n.sym;
5122 dest = gfc_get_symbol_decl (sym);
5124 type = TREE_TYPE (dest);
5125 if (POINTER_TYPE_P (type))
5126 type = TREE_TYPE (type);
5127 if (!GFC_ARRAY_TYPE_P (type))
5130 /* Determine the length of the array. */
5131 len = GFC_TYPE_ARRAY_SIZE (type);
5132 if (!len || TREE_CODE (len) != INTEGER_CST)
5135 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5136 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5137 fold_convert (gfc_array_index_type, tmp));
5139 /* If we are zeroing a local array avoid taking its address by emitting
5141 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5142 return build2 (MODIFY_EXPR, void_type_node,
5143 dest, build_constructor (TREE_TYPE (dest), NULL));
5145 /* Convert arguments to the correct types. */
5146 dest = fold_convert (pvoid_type_node, dest);
5147 len = fold_convert (size_type_node, len);
5149 /* Construct call to __builtin_memset. */
5150 tmp = build_call_expr_loc (input_location,
5151 built_in_decls[BUILT_IN_MEMSET],
5152 3, dest, integer_zero_node, len);
5153 return fold_convert (void_type_node, tmp);
5157 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5158 that constructs the call to __builtin_memcpy. */
5161 gfc_build_memcpy_call (tree dst, tree src, tree len)
5165 /* Convert arguments to the correct types. */
5166 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5167 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5169 dst = fold_convert (pvoid_type_node, dst);
5171 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5172 src = gfc_build_addr_expr (pvoid_type_node, src);
5174 src = fold_convert (pvoid_type_node, src);
5176 len = fold_convert (size_type_node, len);
5178 /* Construct call to __builtin_memcpy. */
5179 tmp = build_call_expr_loc (input_location,
5180 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5181 return fold_convert (void_type_node, tmp);
5185 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5186 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5187 source/rhs, both are gfc_full_array_ref_p which have been checked for
5191 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5193 tree dst, dlen, dtype;
5194 tree src, slen, stype;
5197 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5198 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5200 dtype = TREE_TYPE (dst);
5201 if (POINTER_TYPE_P (dtype))
5202 dtype = TREE_TYPE (dtype);
5203 stype = TREE_TYPE (src);
5204 if (POINTER_TYPE_P (stype))
5205 stype = TREE_TYPE (stype);
5207 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5210 /* Determine the lengths of the arrays. */
5211 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5212 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5214 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5215 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5216 fold_convert (gfc_array_index_type, tmp));
5218 slen = GFC_TYPE_ARRAY_SIZE (stype);
5219 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5221 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5222 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5223 fold_convert (gfc_array_index_type, tmp));
5225 /* Sanity check that they are the same. This should always be
5226 the case, as we should already have checked for conformance. */
5227 if (!tree_int_cst_equal (slen, dlen))
5230 return gfc_build_memcpy_call (dst, src, dlen);
5234 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5235 this can't be done. EXPR1 is the destination/lhs for which
5236 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5239 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5241 unsigned HOST_WIDE_INT nelem;
5247 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5251 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5252 dtype = TREE_TYPE (dst);
5253 if (POINTER_TYPE_P (dtype))
5254 dtype = TREE_TYPE (dtype);
5255 if (!GFC_ARRAY_TYPE_P (dtype))
5258 /* Determine the lengths of the array. */
5259 len = GFC_TYPE_ARRAY_SIZE (dtype);
5260 if (!len || TREE_CODE (len) != INTEGER_CST)
5263 /* Confirm that the constructor is the same size. */
5264 if (compare_tree_int (len, nelem) != 0)
5267 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5268 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5269 fold_convert (gfc_array_index_type, tmp));
5271 stype = gfc_typenode_for_spec (&expr2->ts);
5272 src = gfc_build_constant_array_constructor (expr2, stype);
5274 stype = TREE_TYPE (src);
5275 if (POINTER_TYPE_P (stype))
5276 stype = TREE_TYPE (stype);
5278 return gfc_build_memcpy_call (dst, src, len);
5282 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5283 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5284 init_flag indicates initialization expressions and dealloc that no
5285 deallocate prior assignment is needed (if in doubt, set true). */
5288 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5294 gfc_ss *lss_section;
5301 bool scalar_to_array;
5304 /* Assignment of the form lhs = rhs. */
5305 gfc_start_block (&block);
5307 gfc_init_se (&lse, NULL);
5308 gfc_init_se (&rse, NULL);
5311 lss = gfc_walk_expr (expr1);
5313 if (lss != gfc_ss_terminator)
5315 /* Allow the scalarizer to workshare array assignments. */
5316 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5317 ompws_flags |= OMPWS_SCALARIZER_WS;
5319 /* The assignment needs scalarization. */
5322 /* Find a non-scalar SS from the lhs. */
5323 while (lss_section != gfc_ss_terminator
5324 && lss_section->type != GFC_SS_SECTION)
5325 lss_section = lss_section->next;
5327 gcc_assert (lss_section != gfc_ss_terminator);
5329 /* Initialize the scalarizer. */
5330 gfc_init_loopinfo (&loop);
5333 rss = gfc_walk_expr (expr2);
5334 if (rss == gfc_ss_terminator)
5336 /* The rhs is scalar. Add a ss for the expression. */
5337 rss = gfc_get_ss ();
5338 rss->next = gfc_ss_terminator;
5339 rss->type = GFC_SS_SCALAR;
5342 /* Associate the SS with the loop. */
5343 gfc_add_ss_to_loop (&loop, lss);
5344 gfc_add_ss_to_loop (&loop, rss);
5346 /* Calculate the bounds of the scalarization. */
5347 gfc_conv_ss_startstride (&loop);
5348 /* Resolve any data dependencies in the statement. */
5349 gfc_conv_resolve_dependencies (&loop, lss, rss);
5350 /* Setup the scalarizing loops. */
5351 gfc_conv_loop_setup (&loop, &expr2->where);
5353 /* Setup the gfc_se structures. */
5354 gfc_copy_loopinfo_to_se (&lse, &loop);
5355 gfc_copy_loopinfo_to_se (&rse, &loop);
5358 gfc_mark_ss_chain_used (rss, 1);
5359 if (loop.temp_ss == NULL)
5362 gfc_mark_ss_chain_used (lss, 1);
5366 lse.ss = loop.temp_ss;
5367 gfc_mark_ss_chain_used (lss, 3);
5368 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5371 /* Start the scalarized loop body. */
5372 gfc_start_scalarized_body (&loop, &body);
5375 gfc_init_block (&body);
5377 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5379 /* Translate the expression. */
5380 gfc_conv_expr (&rse, expr2);
5382 /* Stabilize a string length for temporaries. */
5383 if (expr2->ts.type == BT_CHARACTER)
5384 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5386 string_length = NULL_TREE;
5390 gfc_conv_tmp_array_ref (&lse);
5391 gfc_advance_se_ss_chain (&lse);
5392 if (expr2->ts.type == BT_CHARACTER)
5393 lse.string_length = string_length;
5396 gfc_conv_expr (&lse, expr1);
5398 /* Assignments of scalar derived types with allocatable components
5399 to arrays must be done with a deep copy and the rhs temporary
5400 must have its components deallocated afterwards. */
5401 scalar_to_array = (expr2->ts.type == BT_DERIVED
5402 && expr2->ts.u.derived->attr.alloc_comp
5403 && expr2->expr_type != EXPR_VARIABLE
5404 && !gfc_is_constant_expr (expr2)
5405 && expr1->rank && !expr2->rank);
5406 if (scalar_to_array && dealloc)
5408 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5409 gfc_add_expr_to_block (&loop.post, tmp);
5412 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5413 l_is_temp || init_flag,
5414 (expr2->expr_type == EXPR_VARIABLE)
5415 || scalar_to_array, dealloc);
5416 gfc_add_expr_to_block (&body, tmp);
5418 if (lss == gfc_ss_terminator)
5420 /* Use the scalar assignment as is. */
5421 gfc_add_block_to_block (&block, &body);
5425 gcc_assert (lse.ss == gfc_ss_terminator
5426 && rse.ss == gfc_ss_terminator);
5430 gfc_trans_scalarized_loop_boundary (&loop, &body);
5432 /* We need to copy the temporary to the actual lhs. */
5433 gfc_init_se (&lse, NULL);
5434 gfc_init_se (&rse, NULL);
5435 gfc_copy_loopinfo_to_se (&lse, &loop);
5436 gfc_copy_loopinfo_to_se (&rse, &loop);
5438 rse.ss = loop.temp_ss;
5441 gfc_conv_tmp_array_ref (&rse);
5442 gfc_advance_se_ss_chain (&rse);
5443 gfc_conv_expr (&lse, expr1);
5445 gcc_assert (lse.ss == gfc_ss_terminator
5446 && rse.ss == gfc_ss_terminator);
5448 if (expr2->ts.type == BT_CHARACTER)
5449 rse.string_length = string_length;
5451 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5452 false, false, dealloc);
5453 gfc_add_expr_to_block (&body, tmp);
5456 /* Generate the copying loops. */
5457 gfc_trans_scalarizing_loops (&loop, &body);
5459 /* Wrap the whole thing up. */
5460 gfc_add_block_to_block (&block, &loop.pre);
5461 gfc_add_block_to_block (&block, &loop.post);
5463 gfc_cleanup_loop (&loop);
5466 return gfc_finish_block (&block);
5470 /* Check whether EXPR is a copyable array. */
5473 copyable_array_p (gfc_expr * expr)
5475 if (expr->expr_type != EXPR_VARIABLE)
5478 /* First check it's an array. */
5479 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5482 if (!gfc_full_array_ref_p (expr->ref, NULL))
5485 /* Next check that it's of a simple enough type. */
5486 switch (expr->ts.type)
5498 return !expr->ts.u.derived->attr.alloc_comp;
5507 /* Translate an assignment. */
5510 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5515 /* Special case a single function returning an array. */
5516 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5518 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5523 /* Special case assigning an array to zero. */
5524 if (copyable_array_p (expr1)
5525 && is_zero_initializer_p (expr2))
5527 tmp = gfc_trans_zero_assign (expr1);
5532 /* Special case copying one array to another. */
5533 if (copyable_array_p (expr1)
5534 && copyable_array_p (expr2)
5535 && gfc_compare_types (&expr1->ts, &expr2->ts)
5536 && !gfc_check_dependency (expr1, expr2, 0))
5538 tmp = gfc_trans_array_copy (expr1, expr2);
5543 /* Special case initializing an array from a constant array constructor. */
5544 if (copyable_array_p (expr1)
5545 && expr2->expr_type == EXPR_ARRAY
5546 && gfc_compare_types (&expr1->ts, &expr2->ts))
5548 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5553 /* Fallback to the scalarizer to generate explicit loops. */
5554 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5558 gfc_trans_init_assign (gfc_code * code)
5560 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5564 gfc_trans_assign (gfc_code * code)
5566 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5570 /* Translate an assignment to a CLASS object
5571 (pointer or ordinary assignment). */
5574 gfc_trans_class_assign (gfc_code *code)
5581 gfc_start_block (&block);
5583 if (code->op == EXEC_INIT_ASSIGN)
5585 /* Special case for initializing a CLASS variable on allocation.
5586 A MEMCPY is needed to copy the full data of the dynamic type,
5587 which may be different from the declared type. */
5590 gfc_init_se (&dst, NULL);
5591 gfc_init_se (&src, NULL);
5592 gfc_add_component_ref (code->expr1, "$data");
5593 gfc_conv_expr (&dst, code->expr1);
5594 gfc_conv_expr (&src, code->expr2);
5595 gfc_add_block_to_block (&block, &src.pre);
5596 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5597 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5598 gfc_add_expr_to_block (&block, tmp);
5599 return gfc_finish_block (&block);
5602 if (code->expr2->ts.type != BT_CLASS)
5604 /* Insert an additional assignment which sets the '$vptr' field. */
5605 lhs = gfc_copy_expr (code->expr1);
5606 gfc_add_component_ref (lhs, "$vptr");
5607 if (code->expr2->ts.type == BT_DERIVED)
5611 vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
5614 rhs = gfc_get_expr ();
5615 rhs->expr_type = EXPR_VARIABLE;
5616 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5620 else if (code->expr2->expr_type == EXPR_NULL)
5621 rhs = gfc_int_expr (0);
5625 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5626 gfc_add_expr_to_block (&block, tmp);
5628 gfc_free_expr (lhs);
5629 gfc_free_expr (rhs);
5632 /* Do the actual CLASS assignment. */
5633 if (code->expr2->ts.type == BT_CLASS)
5634 code->op = EXEC_ASSIGN;
5636 gfc_add_component_ref (code->expr1, "$data");
5638 if (code->op == EXEC_ASSIGN)
5639 tmp = gfc_trans_assign (code);
5640 else if (code->op == EXEC_POINTER_ASSIGN)
5641 tmp = gfc_trans_pointer_assign (code);
5645 gfc_add_expr_to_block (&block, tmp);
5647 return gfc_finish_block (&block);