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.codimension = sym->attr.codimension;
1852 new_sym->attr.pointer = sym->attr.pointer;
1853 new_sym->attr.allocatable = sym->attr.allocatable;
1854 new_sym->attr.flavor = sym->attr.flavor;
1855 new_sym->attr.function = sym->attr.function;
1857 /* Ensure that the interface is available and that
1858 descriptors are passed for array actual arguments. */
1859 if (sym->attr.flavor == FL_PROCEDURE)
1861 new_sym->formal = expr->symtree->n.sym->formal;
1862 new_sym->attr.always_explicit
1863 = expr->symtree->n.sym->attr.always_explicit;
1866 /* Create a fake symtree for it. */
1868 new_symtree = gfc_new_symtree (&root, sym->name);
1869 new_symtree->n.sym = new_sym;
1870 gcc_assert (new_symtree == root);
1872 /* Create a dummy->actual mapping. */
1873 sm = XCNEW (gfc_interface_sym_mapping);
1874 sm->next = mapping->syms;
1876 sm->new_sym = new_symtree;
1877 sm->expr = gfc_copy_expr (expr);
1880 /* Stabilize the argument's value. */
1881 if (!sym->attr.function && se)
1882 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1884 if (sym->ts.type == BT_CHARACTER)
1886 /* Create a copy of the dummy argument's length. */
1887 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1888 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1890 /* If the length is specified as "*", record the length that
1891 the caller is passing. We should use the callee's length
1892 in all other cases. */
1893 if (!new_sym->ts.u.cl->length && se)
1895 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1896 new_sym->ts.u.cl->backend_decl = se->string_length;
1903 /* Use the passed value as-is if the argument is a function. */
1904 if (sym->attr.flavor == FL_PROCEDURE)
1907 /* If the argument is either a string or a pointer to a string,
1908 convert it to a boundless character type. */
1909 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1911 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1912 tmp = build_pointer_type (tmp);
1913 if (sym->attr.pointer)
1914 value = build_fold_indirect_ref_loc (input_location,
1918 value = fold_convert (tmp, value);
1921 /* If the argument is a scalar, a pointer to an array or an allocatable,
1923 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1924 value = build_fold_indirect_ref_loc (input_location,
1927 /* For character(*), use the actual argument's descriptor. */
1928 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1929 value = build_fold_indirect_ref_loc (input_location,
1932 /* If the argument is an array descriptor, use it to determine
1933 information about the actual argument's shape. */
1934 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1935 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1937 /* Get the actual argument's descriptor. */
1938 desc = build_fold_indirect_ref_loc (input_location,
1941 /* Create the replacement variable. */
1942 tmp = gfc_conv_descriptor_data_get (desc);
1943 value = gfc_get_interface_mapping_array (&se->pre, sym,
1946 /* Use DESC to work out the upper bounds, strides and offset. */
1947 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1950 /* Otherwise we have a packed array. */
1951 value = gfc_get_interface_mapping_array (&se->pre, sym,
1952 PACKED_FULL, se->expr);
1954 new_sym->backend_decl = value;
1958 /* Called once all dummy argument mappings have been added to MAPPING,
1959 but before the mapping is used to evaluate expressions. Pre-evaluate
1960 the length of each argument, adding any initialization code to PRE and
1961 any finalization code to POST. */
1964 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1965 stmtblock_t * pre, stmtblock_t * post)
1967 gfc_interface_sym_mapping *sym;
1971 for (sym = mapping->syms; sym; sym = sym->next)
1972 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1973 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1975 expr = sym->new_sym->n.sym->ts.u.cl->length;
1976 gfc_apply_interface_mapping_to_expr (mapping, expr);
1977 gfc_init_se (&se, NULL);
1978 gfc_conv_expr (&se, expr);
1979 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1980 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1981 gfc_add_block_to_block (pre, &se.pre);
1982 gfc_add_block_to_block (post, &se.post);
1984 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1989 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1993 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1994 gfc_constructor * c)
1996 for (; c; c = c->next)
1998 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2001 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2002 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2003 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2009 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2013 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2018 for (; ref; ref = ref->next)
2022 for (n = 0; n < ref->u.ar.dimen; n++)
2024 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2025 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2026 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2028 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2035 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2036 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2042 /* Convert intrinsic function calls into result expressions. */
2045 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2053 arg1 = expr->value.function.actual->expr;
2054 if (expr->value.function.actual->next)
2055 arg2 = expr->value.function.actual->next->expr;
2059 sym = arg1->symtree->n.sym;
2061 if (sym->attr.dummy)
2066 switch (expr->value.function.isym->id)
2069 /* TODO figure out why this condition is necessary. */
2070 if (sym->attr.function
2071 && (arg1->ts.u.cl->length == NULL
2072 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2073 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2076 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2080 if (!sym->as || sym->as->rank == 0)
2083 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2085 dup = mpz_get_si (arg2->value.integer);
2090 dup = sym->as->rank;
2094 for (; d < dup; d++)
2098 if (!sym->as->upper[d] || !sym->as->lower[d])
2100 gfc_free_expr (new_expr);
2104 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
2105 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2107 new_expr = gfc_multiply (new_expr, tmp);
2113 case GFC_ISYM_LBOUND:
2114 case GFC_ISYM_UBOUND:
2115 /* TODO These implementations of lbound and ubound do not limit if
2116 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2118 if (!sym->as || sym->as->rank == 0)
2121 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2122 d = mpz_get_si (arg2->value.integer) - 1;
2124 /* TODO: If the need arises, this could produce an array of
2128 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2130 if (sym->as->lower[d])
2131 new_expr = gfc_copy_expr (sym->as->lower[d]);
2135 if (sym->as->upper[d])
2136 new_expr = gfc_copy_expr (sym->as->upper[d]);
2144 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2148 gfc_replace_expr (expr, new_expr);
2154 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2155 gfc_interface_mapping * mapping)
2157 gfc_formal_arglist *f;
2158 gfc_actual_arglist *actual;
2160 actual = expr->value.function.actual;
2161 f = map_expr->symtree->n.sym->formal;
2163 for (; f && actual; f = f->next, actual = actual->next)
2168 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2171 if (map_expr->symtree->n.sym->attr.dimension)
2176 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2178 for (d = 0; d < as->rank; d++)
2180 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2181 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2184 expr->value.function.esym->as = as;
2187 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2189 expr->value.function.esym->ts.u.cl->length
2190 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2192 gfc_apply_interface_mapping_to_expr (mapping,
2193 expr->value.function.esym->ts.u.cl->length);
2198 /* EXPR is a copy of an expression that appeared in the interface
2199 associated with MAPPING. Walk it recursively looking for references to
2200 dummy arguments that MAPPING maps to actual arguments. Replace each such
2201 reference with a reference to the associated actual argument. */
2204 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2207 gfc_interface_sym_mapping *sym;
2208 gfc_actual_arglist *actual;
2213 /* Copying an expression does not copy its length, so do that here. */
2214 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2216 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2217 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2220 /* Apply the mapping to any references. */
2221 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2223 /* ...and to the expression's symbol, if it has one. */
2224 /* TODO Find out why the condition on expr->symtree had to be moved into
2225 the loop rather than being outside it, as originally. */
2226 for (sym = mapping->syms; sym; sym = sym->next)
2227 if (expr->symtree && sym->old == expr->symtree->n.sym)
2229 if (sym->new_sym->n.sym->backend_decl)
2230 expr->symtree = sym->new_sym;
2232 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2235 /* ...and to subexpressions in expr->value. */
2236 switch (expr->expr_type)
2241 case EXPR_SUBSTRING:
2245 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2246 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2250 for (actual = expr->value.function.actual; actual; actual = actual->next)
2251 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2253 if (expr->value.function.esym == NULL
2254 && expr->value.function.isym != NULL
2255 && expr->value.function.actual->expr->symtree
2256 && gfc_map_intrinsic_function (expr, mapping))
2259 for (sym = mapping->syms; sym; sym = sym->next)
2260 if (sym->old == expr->value.function.esym)
2262 expr->value.function.esym = sym->new_sym->n.sym;
2263 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2264 expr->value.function.esym->result = sym->new_sym->n.sym;
2269 case EXPR_STRUCTURE:
2270 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2283 /* Evaluate interface expression EXPR using MAPPING. Store the result
2287 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2288 gfc_se * se, gfc_expr * expr)
2290 expr = gfc_copy_expr (expr);
2291 gfc_apply_interface_mapping_to_expr (mapping, expr);
2292 gfc_conv_expr (se, expr);
2293 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2294 gfc_free_expr (expr);
2298 /* Returns a reference to a temporary array into which a component of
2299 an actual argument derived type array is copied and then returned
2300 after the function call. */
2302 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2303 sym_intent intent, bool formal_ptr)
2321 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2323 gfc_init_se (&lse, NULL);
2324 gfc_init_se (&rse, NULL);
2326 /* Walk the argument expression. */
2327 rss = gfc_walk_expr (expr);
2329 gcc_assert (rss != gfc_ss_terminator);
2331 /* Initialize the scalarizer. */
2332 gfc_init_loopinfo (&loop);
2333 gfc_add_ss_to_loop (&loop, rss);
2335 /* Calculate the bounds of the scalarization. */
2336 gfc_conv_ss_startstride (&loop);
2338 /* Build an ss for the temporary. */
2339 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2340 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2342 base_type = gfc_typenode_for_spec (&expr->ts);
2343 if (GFC_ARRAY_TYPE_P (base_type)
2344 || GFC_DESCRIPTOR_TYPE_P (base_type))
2345 base_type = gfc_get_element_type (base_type);
2347 loop.temp_ss = gfc_get_ss ();;
2348 loop.temp_ss->type = GFC_SS_TEMP;
2349 loop.temp_ss->data.temp.type = base_type;
2351 if (expr->ts.type == BT_CHARACTER)
2352 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2354 loop.temp_ss->string_length = NULL;
2356 parmse->string_length = loop.temp_ss->string_length;
2357 loop.temp_ss->data.temp.dimen = loop.dimen;
2358 loop.temp_ss->next = gfc_ss_terminator;
2360 /* Associate the SS with the loop. */
2361 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2363 /* Setup the scalarizing loops. */
2364 gfc_conv_loop_setup (&loop, &expr->where);
2366 /* Pass the temporary descriptor back to the caller. */
2367 info = &loop.temp_ss->data.info;
2368 parmse->expr = info->descriptor;
2370 /* Setup the gfc_se structures. */
2371 gfc_copy_loopinfo_to_se (&lse, &loop);
2372 gfc_copy_loopinfo_to_se (&rse, &loop);
2375 lse.ss = loop.temp_ss;
2376 gfc_mark_ss_chain_used (rss, 1);
2377 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2379 /* Start the scalarized loop body. */
2380 gfc_start_scalarized_body (&loop, &body);
2382 /* Translate the expression. */
2383 gfc_conv_expr (&rse, expr);
2385 gfc_conv_tmp_array_ref (&lse);
2386 gfc_advance_se_ss_chain (&lse);
2388 if (intent != INTENT_OUT)
2390 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2391 gfc_add_expr_to_block (&body, tmp);
2392 gcc_assert (rse.ss == gfc_ss_terminator);
2393 gfc_trans_scalarizing_loops (&loop, &body);
2397 /* Make sure that the temporary declaration survives by merging
2398 all the loop declarations into the current context. */
2399 for (n = 0; n < loop.dimen; n++)
2401 gfc_merge_block_scope (&body);
2402 body = loop.code[loop.order[n]];
2404 gfc_merge_block_scope (&body);
2407 /* Add the post block after the second loop, so that any
2408 freeing of allocated memory is done at the right time. */
2409 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2411 /**********Copy the temporary back again.*********/
2413 gfc_init_se (&lse, NULL);
2414 gfc_init_se (&rse, NULL);
2416 /* Walk the argument expression. */
2417 lss = gfc_walk_expr (expr);
2418 rse.ss = loop.temp_ss;
2421 /* Initialize the scalarizer. */
2422 gfc_init_loopinfo (&loop2);
2423 gfc_add_ss_to_loop (&loop2, lss);
2425 /* Calculate the bounds of the scalarization. */
2426 gfc_conv_ss_startstride (&loop2);
2428 /* Setup the scalarizing loops. */
2429 gfc_conv_loop_setup (&loop2, &expr->where);
2431 gfc_copy_loopinfo_to_se (&lse, &loop2);
2432 gfc_copy_loopinfo_to_se (&rse, &loop2);
2434 gfc_mark_ss_chain_used (lss, 1);
2435 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2437 /* Declare the variable to hold the temporary offset and start the
2438 scalarized loop body. */
2439 offset = gfc_create_var (gfc_array_index_type, NULL);
2440 gfc_start_scalarized_body (&loop2, &body);
2442 /* Build the offsets for the temporary from the loop variables. The
2443 temporary array has lbounds of zero and strides of one in all
2444 dimensions, so this is very simple. The offset is only computed
2445 outside the innermost loop, so the overall transfer could be
2446 optimized further. */
2447 info = &rse.ss->data.info;
2448 dimen = info->dimen;
2450 tmp_index = gfc_index_zero_node;
2451 for (n = dimen - 1; n > 0; n--)
2454 tmp = rse.loop->loopvar[n];
2455 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2456 tmp, rse.loop->from[n]);
2457 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2460 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2461 rse.loop->to[n-1], rse.loop->from[n-1]);
2462 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2463 tmp_str, gfc_index_one_node);
2465 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2469 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2470 tmp_index, rse.loop->from[0]);
2471 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2473 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2474 rse.loop->loopvar[0], offset);
2476 /* Now use the offset for the reference. */
2477 tmp = build_fold_indirect_ref_loc (input_location,
2479 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2481 if (expr->ts.type == BT_CHARACTER)
2482 rse.string_length = expr->ts.u.cl->backend_decl;
2484 gfc_conv_expr (&lse, expr);
2486 gcc_assert (lse.ss == gfc_ss_terminator);
2488 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2489 gfc_add_expr_to_block (&body, tmp);
2491 /* Generate the copying loops. */
2492 gfc_trans_scalarizing_loops (&loop2, &body);
2494 /* Wrap the whole thing up by adding the second loop to the post-block
2495 and following it by the post-block of the first loop. In this way,
2496 if the temporary needs freeing, it is done after use! */
2497 if (intent != INTENT_IN)
2499 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2500 gfc_add_block_to_block (&parmse->post, &loop2.post);
2503 gfc_add_block_to_block (&parmse->post, &loop.post);
2505 gfc_cleanup_loop (&loop);
2506 gfc_cleanup_loop (&loop2);
2508 /* Pass the string length to the argument expression. */
2509 if (expr->ts.type == BT_CHARACTER)
2510 parmse->string_length = expr->ts.u.cl->backend_decl;
2512 /* Determine the offset for pointer formal arguments and set the
2516 size = gfc_index_one_node;
2517 offset = gfc_index_zero_node;
2518 for (n = 0; n < dimen; n++)
2520 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2522 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2523 tmp, gfc_index_one_node);
2524 gfc_conv_descriptor_ubound_set (&parmse->pre,
2528 gfc_conv_descriptor_lbound_set (&parmse->pre,
2531 gfc_index_one_node);
2532 size = gfc_evaluate_now (size, &parmse->pre);
2533 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2535 offset = gfc_evaluate_now (offset, &parmse->pre);
2536 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2537 rse.loop->to[n], rse.loop->from[n]);
2538 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2539 tmp, gfc_index_one_node);
2540 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2544 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2548 /* We want either the address for the data or the address of the descriptor,
2549 depending on the mode of passing array arguments. */
2551 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2553 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2559 /* Generate the code for argument list functions. */
2562 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2564 /* Pass by value for g77 %VAL(arg), pass the address
2565 indirectly for %LOC, else by reference. Thus %REF
2566 is a "do-nothing" and %LOC is the same as an F95
2568 if (strncmp (name, "%VAL", 4) == 0)
2569 gfc_conv_expr (se, expr);
2570 else if (strncmp (name, "%LOC", 4) == 0)
2572 gfc_conv_expr_reference (se, expr);
2573 se->expr = gfc_build_addr_expr (NULL, se->expr);
2575 else if (strncmp (name, "%REF", 4) == 0)
2576 gfc_conv_expr_reference (se, expr);
2578 gfc_error ("Unknown argument list function at %L", &expr->where);
2582 /* Takes a derived type expression and returns the address of a temporary
2583 class object of the 'declared' type. */
2585 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2586 gfc_typespec class_ts)
2590 gfc_symbol *declared = class_ts.u.derived;
2596 /* The derived type needs to be converted to a temporary
2598 tmp = gfc_typenode_for_spec (&class_ts);
2599 var = gfc_create_var (tmp, "class");
2602 cmp = gfc_find_component (declared, "$vptr", true, true);
2603 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2604 var, cmp->backend_decl, NULL_TREE);
2606 /* Remember the vtab corresponds to the derived type
2607 not to the class declared type. */
2608 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2610 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2611 gfc_add_modify (&parmse->pre, ctree,
2612 fold_convert (TREE_TYPE (ctree), tmp));
2614 /* Now set the data field. */
2615 cmp = gfc_find_component (declared, "$data", true, true);
2616 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2617 var, cmp->backend_decl, NULL_TREE);
2618 ss = gfc_walk_expr (e);
2619 if (ss == gfc_ss_terminator)
2621 gfc_conv_expr_reference (parmse, e);
2622 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2623 gfc_add_modify (&parmse->pre, ctree, tmp);
2627 gfc_conv_expr (parmse, e);
2628 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2631 /* Pass the address of the class object. */
2632 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2636 /* The following routine generates code for the intrinsic
2637 procedures from the ISO_C_BINDING module:
2639 * C_FUNLOC (function)
2640 * C_F_POINTER (subroutine)
2641 * C_F_PROCPOINTER (subroutine)
2642 * C_ASSOCIATED (function)
2643 One exception which is not handled here is C_F_POINTER with non-scalar
2644 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2647 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2648 gfc_actual_arglist * arg)
2653 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2655 if (arg->expr->rank == 0)
2656 gfc_conv_expr_reference (se, arg->expr);
2660 /* This is really the actual arg because no formal arglist is
2661 created for C_LOC. */
2662 fsym = arg->expr->symtree->n.sym;
2664 /* We should want it to do g77 calling convention. */
2666 && !(fsym->attr.pointer || fsym->attr.allocatable)
2667 && fsym->as->type != AS_ASSUMED_SHAPE;
2668 f = f || !sym->attr.always_explicit;
2670 argss = gfc_walk_expr (arg->expr);
2671 gfc_conv_array_parameter (se, arg->expr, argss, f,
2675 /* TODO -- the following two lines shouldn't be necessary, but if
2676 they're removed, a bug is exposed later in the code path.
2677 This workaround was thus introduced, but will have to be
2678 removed; please see PR 35150 for details about the issue. */
2679 se->expr = convert (pvoid_type_node, se->expr);
2680 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2684 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2686 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2687 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2688 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2689 gfc_conv_expr_reference (se, arg->expr);
2693 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2694 && arg->next->expr->rank == 0)
2695 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2697 /* Convert c_f_pointer if fptr is a scalar
2698 and convert c_f_procpointer. */
2702 gfc_init_se (&cptrse, NULL);
2703 gfc_conv_expr (&cptrse, arg->expr);
2704 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2705 gfc_add_block_to_block (&se->post, &cptrse.post);
2707 gfc_init_se (&fptrse, NULL);
2708 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2709 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2710 fptrse.want_pointer = 1;
2712 gfc_conv_expr (&fptrse, arg->next->expr);
2713 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2714 gfc_add_block_to_block (&se->post, &fptrse.post);
2716 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2717 && arg->next->expr->symtree->n.sym->attr.dummy)
2718 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2721 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2723 fold_convert (TREE_TYPE (fptrse.expr),
2728 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2733 /* Build the addr_expr for the first argument. The argument is
2734 already an *address* so we don't need to set want_pointer in
2736 gfc_init_se (&arg1se, NULL);
2737 gfc_conv_expr (&arg1se, arg->expr);
2738 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2739 gfc_add_block_to_block (&se->post, &arg1se.post);
2741 /* See if we were given two arguments. */
2742 if (arg->next == NULL)
2743 /* Only given one arg so generate a null and do a
2744 not-equal comparison against the first arg. */
2745 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2746 fold_convert (TREE_TYPE (arg1se.expr),
2747 null_pointer_node));
2753 /* Given two arguments so build the arg2se from second arg. */
2754 gfc_init_se (&arg2se, NULL);
2755 gfc_conv_expr (&arg2se, arg->next->expr);
2756 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2757 gfc_add_block_to_block (&se->post, &arg2se.post);
2759 /* Generate test to compare that the two args are equal. */
2760 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2761 arg1se.expr, arg2se.expr);
2762 /* Generate test to ensure that the first arg is not null. */
2763 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2764 arg1se.expr, null_pointer_node);
2766 /* Finally, the generated test must check that both arg1 is not
2767 NULL and that it is equal to the second arg. */
2768 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2769 not_null_expr, eq_expr);
2775 /* Nothing was done. */
2780 /* Generate code for a procedure call. Note can return se->post != NULL.
2781 If se->direct_byref is set then se->expr contains the return parameter.
2782 Return nonzero, if the call has alternate specifiers.
2783 'expr' is only needed for procedure pointer components. */
2786 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2787 gfc_actual_arglist * arg, gfc_expr * expr,
2790 gfc_interface_mapping mapping;
2805 gfc_formal_arglist *formal;
2806 int has_alternate_specifier = 0;
2807 bool need_interface_mapping;
2814 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2815 gfc_component *comp = NULL;
2817 arglist = NULL_TREE;
2818 retargs = NULL_TREE;
2819 stringargs = NULL_TREE;
2824 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2825 && conv_isocbinding_procedure (se, sym, arg))
2828 gfc_is_proc_ptr_comp (expr, &comp);
2832 if (!sym->attr.elemental)
2834 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2835 if (se->ss->useflags)
2837 gcc_assert ((!comp && gfc_return_by_reference (sym)
2838 && sym->result->attr.dimension)
2839 || (comp && comp->attr.dimension));
2840 gcc_assert (se->loop != NULL);
2842 /* Access the previously obtained result. */
2843 gfc_conv_tmp_array_ref (se);
2844 gfc_advance_se_ss_chain (se);
2848 info = &se->ss->data.info;
2853 gfc_init_block (&post);
2854 gfc_init_interface_mapping (&mapping);
2857 formal = sym->formal;
2858 need_interface_mapping = sym->attr.dimension ||
2859 (sym->ts.type == BT_CHARACTER
2860 && sym->ts.u.cl->length
2861 && sym->ts.u.cl->length->expr_type
2866 formal = comp->formal;
2867 need_interface_mapping = comp->attr.dimension ||
2868 (comp->ts.type == BT_CHARACTER
2869 && comp->ts.u.cl->length
2870 && comp->ts.u.cl->length->expr_type
2874 /* Evaluate the arguments. */
2875 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2878 fsym = formal ? formal->sym : NULL;
2879 parm_kind = MISSING;
2883 if (se->ignore_optional)
2885 /* Some intrinsics have already been resolved to the correct
2889 else if (arg->label)
2891 has_alternate_specifier = 1;
2896 /* Pass a NULL pointer for an absent arg. */
2897 gfc_init_se (&parmse, NULL);
2898 parmse.expr = null_pointer_node;
2899 if (arg->missing_arg_type == BT_CHARACTER)
2900 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2903 else if (fsym && fsym->ts.type == BT_CLASS
2904 && e->ts.type == BT_DERIVED)
2906 /* The derived type needs to be converted to a temporary
2908 gfc_init_se (&parmse, se);
2909 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2911 else if (se->ss && se->ss->useflags)
2913 /* An elemental function inside a scalarized loop. */
2914 gfc_init_se (&parmse, se);
2915 gfc_conv_expr_reference (&parmse, e);
2916 parm_kind = ELEMENTAL;
2920 /* A scalar or transformational function. */
2921 gfc_init_se (&parmse, NULL);
2922 argss = gfc_walk_expr (e);
2924 if (argss == gfc_ss_terminator)
2926 if (e->expr_type == EXPR_VARIABLE
2927 && e->symtree->n.sym->attr.cray_pointee
2928 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2930 /* The Cray pointer needs to be converted to a pointer to
2931 a type given by the expression. */
2932 gfc_conv_expr (&parmse, e);
2933 type = build_pointer_type (TREE_TYPE (parmse.expr));
2934 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2935 parmse.expr = convert (type, tmp);
2937 else if (fsym && fsym->attr.value)
2939 if (fsym->ts.type == BT_CHARACTER
2940 && fsym->ts.is_c_interop
2941 && fsym->ns->proc_name != NULL
2942 && fsym->ns->proc_name->attr.is_bind_c)
2945 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2946 if (parmse.expr == NULL)
2947 gfc_conv_expr (&parmse, e);
2950 gfc_conv_expr (&parmse, e);
2952 else if (arg->name && arg->name[0] == '%')
2953 /* Argument list functions %VAL, %LOC and %REF are signalled
2954 through arg->name. */
2955 conv_arglist_function (&parmse, arg->expr, arg->name);
2956 else if ((e->expr_type == EXPR_FUNCTION)
2957 && ((e->value.function.esym
2958 && e->value.function.esym->result->attr.pointer)
2959 || (!e->value.function.esym
2960 && e->symtree->n.sym->attr.pointer))
2961 && fsym && fsym->attr.target)
2963 gfc_conv_expr (&parmse, e);
2964 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2966 else if (e->expr_type == EXPR_FUNCTION
2967 && e->symtree->n.sym->result
2968 && e->symtree->n.sym->result != e->symtree->n.sym
2969 && e->symtree->n.sym->result->attr.proc_pointer)
2971 /* Functions returning procedure pointers. */
2972 gfc_conv_expr (&parmse, e);
2973 if (fsym && fsym->attr.proc_pointer)
2974 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2978 gfc_conv_expr_reference (&parmse, e);
2980 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2981 allocated on entry, it must be deallocated. */
2982 if (fsym && fsym->attr.allocatable
2983 && fsym->attr.intent == INTENT_OUT)
2987 gfc_init_block (&block);
2988 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2990 gfc_add_expr_to_block (&block, tmp);
2991 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2992 parmse.expr, null_pointer_node);
2993 gfc_add_expr_to_block (&block, tmp);
2995 if (fsym->attr.optional
2996 && e->expr_type == EXPR_VARIABLE
2997 && e->symtree->n.sym->attr.optional)
2999 tmp = fold_build3 (COND_EXPR, void_type_node,
3000 gfc_conv_expr_present (e->symtree->n.sym),
3001 gfc_finish_block (&block),
3002 build_empty_stmt (input_location));
3005 tmp = gfc_finish_block (&block);
3007 gfc_add_expr_to_block (&se->pre, tmp);
3010 if (fsym && e->expr_type != EXPR_NULL
3011 && ((fsym->attr.pointer
3012 && fsym->attr.flavor != FL_PROCEDURE)
3013 || (fsym->attr.proc_pointer
3014 && !(e->expr_type == EXPR_VARIABLE
3015 && e->symtree->n.sym->attr.dummy))
3016 || (e->expr_type == EXPR_VARIABLE
3017 && gfc_is_proc_ptr_comp (e, NULL))
3018 || fsym->attr.allocatable))
3020 /* Scalar pointer dummy args require an extra level of
3021 indirection. The null pointer already contains
3022 this level of indirection. */
3023 parm_kind = SCALAR_POINTER;
3024 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3030 /* If the procedure requires an explicit interface, the actual
3031 argument is passed according to the corresponding formal
3032 argument. If the corresponding formal argument is a POINTER,
3033 ALLOCATABLE or assumed shape, we do not use g77's calling
3034 convention, and pass the address of the array descriptor
3035 instead. Otherwise we use g77's calling convention. */
3038 && !(fsym->attr.pointer || fsym->attr.allocatable)
3039 && fsym->as->type != AS_ASSUMED_SHAPE;
3041 f = f || !comp->attr.always_explicit;
3043 f = f || !sym->attr.always_explicit;
3045 if (e->expr_type == EXPR_VARIABLE
3046 && is_subref_array (e))
3047 /* The actual argument is a component reference to an
3048 array of derived types. In this case, the argument
3049 is converted to a temporary, which is passed and then
3050 written back after the procedure call. */
3051 gfc_conv_subref_array_arg (&parmse, e, f,
3052 fsym ? fsym->attr.intent : INTENT_INOUT,
3053 fsym && fsym->attr.pointer);
3055 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3058 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3059 allocated on entry, it must be deallocated. */
3060 if (fsym && fsym->attr.allocatable
3061 && fsym->attr.intent == INTENT_OUT)
3063 tmp = build_fold_indirect_ref_loc (input_location,
3065 tmp = gfc_trans_dealloc_allocated (tmp);
3066 if (fsym->attr.optional
3067 && e->expr_type == EXPR_VARIABLE
3068 && e->symtree->n.sym->attr.optional)
3069 tmp = fold_build3 (COND_EXPR, void_type_node,
3070 gfc_conv_expr_present (e->symtree->n.sym),
3071 tmp, build_empty_stmt (input_location));
3072 gfc_add_expr_to_block (&se->pre, tmp);
3077 /* The case with fsym->attr.optional is that of a user subroutine
3078 with an interface indicating an optional argument. When we call
3079 an intrinsic subroutine, however, fsym is NULL, but we might still
3080 have an optional argument, so we proceed to the substitution
3082 if (e && (fsym == NULL || fsym->attr.optional))
3084 /* If an optional argument is itself an optional dummy argument,
3085 check its presence and substitute a null if absent. This is
3086 only needed when passing an array to an elemental procedure
3087 as then array elements are accessed - or no NULL pointer is
3088 allowed and a "1" or "0" should be passed if not present.
3089 When passing a non-array-descriptor full array to a
3090 non-array-descriptor dummy, no check is needed. For
3091 array-descriptor actual to array-descriptor dummy, see
3092 PR 41911 for why a check has to be inserted.
3093 fsym == NULL is checked as intrinsics required the descriptor
3094 but do not always set fsym. */
3095 if (e->expr_type == EXPR_VARIABLE
3096 && e->symtree->n.sym->attr.optional
3097 && ((e->rank > 0 && sym->attr.elemental)
3098 || e->representation.length || e->ts.type == BT_CHARACTER
3100 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3101 || fsym->as->type == AS_DEFERRED))))
3102 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3103 e->representation.length);
3108 /* Obtain the character length of an assumed character length
3109 length procedure from the typespec. */
3110 if (fsym->ts.type == BT_CHARACTER
3111 && parmse.string_length == NULL_TREE
3112 && e->ts.type == BT_PROCEDURE
3113 && e->symtree->n.sym->ts.type == BT_CHARACTER
3114 && e->symtree->n.sym->ts.u.cl->length != NULL
3115 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3117 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3118 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3122 if (fsym && need_interface_mapping && e)
3123 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3125 gfc_add_block_to_block (&se->pre, &parmse.pre);
3126 gfc_add_block_to_block (&post, &parmse.post);
3128 /* Allocated allocatable components of derived types must be
3129 deallocated for non-variable scalars. Non-variable arrays are
3130 dealt with in trans-array.c(gfc_conv_array_parameter). */
3131 if (e && e->ts.type == BT_DERIVED
3132 && e->ts.u.derived->attr.alloc_comp
3133 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3134 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3137 tmp = build_fold_indirect_ref_loc (input_location,
3139 parm_rank = e->rank;
3147 case (SCALAR_POINTER):
3148 tmp = build_fold_indirect_ref_loc (input_location,
3153 if (e->expr_type == EXPR_OP
3154 && e->value.op.op == INTRINSIC_PARENTHESES
3155 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3158 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3159 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3160 gfc_add_expr_to_block (&se->post, local_tmp);
3163 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3165 gfc_add_expr_to_block (&se->post, tmp);
3168 /* Add argument checking of passing an unallocated/NULL actual to
3169 a nonallocatable/nonpointer dummy. */
3171 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3173 symbol_attribute *attr;
3177 if (e->expr_type == EXPR_VARIABLE)
3178 attr = &e->symtree->n.sym->attr;
3179 else if (e->expr_type == EXPR_FUNCTION)
3181 /* For intrinsic functions, the gfc_attr are not available. */
3182 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3183 goto end_pointer_check;
3185 if (e->symtree->n.sym->attr.generic)
3186 attr = &e->value.function.esym->attr;
3188 attr = &e->symtree->n.sym->result->attr;
3191 goto end_pointer_check;
3195 /* If the actual argument is an optional pointer/allocatable and
3196 the formal argument takes an nonpointer optional value,
3197 it is invalid to pass a non-present argument on, even
3198 though there is no technical reason for this in gfortran.
3199 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3200 tree present, nullptr, type;
3202 if (attr->allocatable
3203 && (fsym == NULL || !fsym->attr.allocatable))
3204 asprintf (&msg, "Allocatable actual argument '%s' is not "
3205 "allocated or not present", e->symtree->n.sym->name);
3206 else if (attr->pointer
3207 && (fsym == NULL || !fsym->attr.pointer))
3208 asprintf (&msg, "Pointer actual argument '%s' is not "
3209 "associated or not present",
3210 e->symtree->n.sym->name);
3211 else if (attr->proc_pointer
3212 && (fsym == NULL || !fsym->attr.proc_pointer))
3213 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3214 "associated or not present",
3215 e->symtree->n.sym->name);
3217 goto end_pointer_check;
3219 present = gfc_conv_expr_present (e->symtree->n.sym);
3220 type = TREE_TYPE (present);
3221 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3222 fold_convert (type, null_pointer_node));
3223 type = TREE_TYPE (parmse.expr);
3224 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3225 fold_convert (type, null_pointer_node));
3226 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3231 if (attr->allocatable
3232 && (fsym == NULL || !fsym->attr.allocatable))
3233 asprintf (&msg, "Allocatable actual argument '%s' is not "
3234 "allocated", e->symtree->n.sym->name);
3235 else if (attr->pointer
3236 && (fsym == NULL || !fsym->attr.pointer))
3237 asprintf (&msg, "Pointer actual argument '%s' is not "
3238 "associated", e->symtree->n.sym->name);
3239 else if (attr->proc_pointer
3240 && (fsym == NULL || !fsym->attr.proc_pointer))
3241 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3242 "associated", e->symtree->n.sym->name);
3244 goto end_pointer_check;
3247 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3248 fold_convert (TREE_TYPE (parmse.expr),
3249 null_pointer_node));
3252 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3259 /* Character strings are passed as two parameters, a length and a
3260 pointer - except for Bind(c) which only passes the pointer. */
3261 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3262 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
3264 arglist = gfc_chainon_list (arglist, parmse.expr);
3266 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3273 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3274 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3275 else if (ts.type == BT_CHARACTER)
3277 if (ts.u.cl->length == NULL)
3279 /* Assumed character length results are not allowed by 5.1.1.5 of the
3280 standard and are trapped in resolve.c; except in the case of SPREAD
3281 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3282 we take the character length of the first argument for the result.
3283 For dummies, we have to look through the formal argument list for
3284 this function and use the character length found there.*/
3285 if (!sym->attr.dummy)
3286 cl.backend_decl = TREE_VALUE (stringargs);
3289 formal = sym->ns->proc_name->formal;
3290 for (; formal; formal = formal->next)
3291 if (strcmp (formal->sym->name, sym->name) == 0)
3292 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3299 /* Calculate the length of the returned string. */
3300 gfc_init_se (&parmse, NULL);
3301 if (need_interface_mapping)
3302 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3304 gfc_conv_expr (&parmse, ts.u.cl->length);
3305 gfc_add_block_to_block (&se->pre, &parmse.pre);
3306 gfc_add_block_to_block (&se->post, &parmse.post);
3308 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3309 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3310 build_int_cst (gfc_charlen_type_node, 0));
3311 cl.backend_decl = tmp;
3314 /* Set up a charlen structure for it. */
3319 len = cl.backend_decl;
3322 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3323 || (!comp && gfc_return_by_reference (sym));
3326 if (se->direct_byref)
3328 /* Sometimes, too much indirection can be applied; e.g. for
3329 function_result = array_valued_recursive_function. */
3330 if (TREE_TYPE (TREE_TYPE (se->expr))
3331 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3332 && GFC_DESCRIPTOR_TYPE_P
3333 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3334 se->expr = build_fold_indirect_ref_loc (input_location,
3337 result = build_fold_indirect_ref_loc (input_location,
3339 retargs = gfc_chainon_list (retargs, se->expr);
3341 else if (comp && comp->attr.dimension)
3343 gcc_assert (se->loop && info);
3345 /* Set the type of the array. */
3346 tmp = gfc_typenode_for_spec (&comp->ts);
3347 info->dimen = se->loop->dimen;
3349 /* Evaluate the bounds of the result, if known. */
3350 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3352 /* Create a temporary to store the result. In case the function
3353 returns a pointer, the temporary will be a shallow copy and
3354 mustn't be deallocated. */
3355 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3356 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3357 NULL_TREE, false, !comp->attr.pointer,
3358 callee_alloc, &se->ss->expr->where);
3360 /* Pass the temporary as the first argument. */
3361 result = info->descriptor;
3362 tmp = gfc_build_addr_expr (NULL_TREE, result);
3363 retargs = gfc_chainon_list (retargs, tmp);
3365 else if (!comp && sym->result->attr.dimension)
3367 gcc_assert (se->loop && info);
3369 /* Set the type of the array. */
3370 tmp = gfc_typenode_for_spec (&ts);
3371 info->dimen = se->loop->dimen;
3373 /* Evaluate the bounds of the result, if known. */
3374 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3376 /* Create a temporary to store the result. In case the function
3377 returns a pointer, the temporary will be a shallow copy and
3378 mustn't be deallocated. */
3379 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3380 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3381 NULL_TREE, false, !sym->attr.pointer,
3382 callee_alloc, &se->ss->expr->where);
3384 /* Pass the temporary as the first argument. */
3385 result = info->descriptor;
3386 tmp = gfc_build_addr_expr (NULL_TREE, result);
3387 retargs = gfc_chainon_list (retargs, tmp);
3389 else if (ts.type == BT_CHARACTER)
3391 /* Pass the string length. */
3392 type = gfc_get_character_type (ts.kind, ts.u.cl);
3393 type = build_pointer_type (type);
3395 /* Return an address to a char[0:len-1]* temporary for
3396 character pointers. */
3397 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3398 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3400 var = gfc_create_var (type, "pstr");
3402 if ((!comp && sym->attr.allocatable)
3403 || (comp && comp->attr.allocatable))
3404 gfc_add_modify (&se->pre, var,
3405 fold_convert (TREE_TYPE (var),
3406 null_pointer_node));
3408 /* Provide an address expression for the function arguments. */
3409 var = gfc_build_addr_expr (NULL_TREE, var);
3412 var = gfc_conv_string_tmp (se, type, len);
3414 retargs = gfc_chainon_list (retargs, var);
3418 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3420 type = gfc_get_complex_type (ts.kind);
3421 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3422 retargs = gfc_chainon_list (retargs, var);
3425 /* Add the string length to the argument list. */
3426 if (ts.type == BT_CHARACTER)
3427 retargs = gfc_chainon_list (retargs, len);
3429 gfc_free_interface_mapping (&mapping);
3431 /* Add the return arguments. */
3432 arglist = chainon (retargs, arglist);
3434 /* Add the hidden string length parameters to the arguments. */
3435 arglist = chainon (arglist, stringargs);
3437 /* We may want to append extra arguments here. This is used e.g. for
3438 calls to libgfortran_matmul_??, which need extra information. */
3439 if (append_args != NULL_TREE)
3440 arglist = chainon (arglist, append_args);
3442 /* Generate the actual call. */
3443 conv_function_val (se, sym, expr);
3445 /* If there are alternate return labels, function type should be
3446 integer. Can't modify the type in place though, since it can be shared
3447 with other functions. For dummy arguments, the typing is done to
3448 to this result, even if it has to be repeated for each call. */
3449 if (has_alternate_specifier
3450 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3452 if (!sym->attr.dummy)
3454 TREE_TYPE (sym->backend_decl)
3455 = build_function_type (integer_type_node,
3456 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3457 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3460 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3463 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3464 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3466 /* If we have a pointer function, but we don't want a pointer, e.g.
3469 where f is pointer valued, we have to dereference the result. */
3470 if (!se->want_pointer && !byref
3471 && (sym->attr.pointer || sym->attr.allocatable)
3472 && !gfc_is_proc_ptr_comp (expr, NULL))
3473 se->expr = build_fold_indirect_ref_loc (input_location,
3476 /* f2c calling conventions require a scalar default real function to
3477 return a double precision result. Convert this back to default
3478 real. We only care about the cases that can happen in Fortran 77.
3480 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3481 && sym->ts.kind == gfc_default_real_kind
3482 && !sym->attr.always_explicit)
3483 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3485 /* A pure function may still have side-effects - it may modify its
3487 TREE_SIDE_EFFECTS (se->expr) = 1;
3489 if (!sym->attr.pure)
3490 TREE_SIDE_EFFECTS (se->expr) = 1;
3495 /* Add the function call to the pre chain. There is no expression. */
3496 gfc_add_expr_to_block (&se->pre, se->expr);
3497 se->expr = NULL_TREE;
3499 if (!se->direct_byref)
3501 if (sym->attr.dimension || (comp && comp->attr.dimension))
3503 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3505 /* Check the data pointer hasn't been modified. This would
3506 happen in a function returning a pointer. */
3507 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3508 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3510 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3513 se->expr = info->descriptor;
3514 /* Bundle in the string length. */
3515 se->string_length = len;
3517 else if (ts.type == BT_CHARACTER)
3519 /* Dereference for character pointer results. */
3520 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3521 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3522 se->expr = build_fold_indirect_ref_loc (input_location, var);
3526 se->string_length = len;
3530 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3531 se->expr = build_fold_indirect_ref_loc (input_location, var);
3536 /* Follow the function call with the argument post block. */
3539 gfc_add_block_to_block (&se->pre, &post);
3541 /* Transformational functions of derived types with allocatable
3542 components must have the result allocatable components copied. */
3543 arg = expr->value.function.actual;
3544 if (result && arg && expr->rank
3545 && expr->value.function.isym
3546 && expr->value.function.isym->transformational
3547 && arg->expr->ts.type == BT_DERIVED
3548 && arg->expr->ts.u.derived->attr.alloc_comp)
3551 /* Copy the allocatable components. We have to use a
3552 temporary here to prevent source allocatable components
3553 from being corrupted. */
3554 tmp2 = gfc_evaluate_now (result, &se->pre);
3555 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3556 result, tmp2, expr->rank);
3557 gfc_add_expr_to_block (&se->pre, tmp);
3558 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3560 gfc_add_expr_to_block (&se->pre, tmp);
3562 /* Finally free the temporary's data field. */
3563 tmp = gfc_conv_descriptor_data_get (tmp2);
3564 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3565 gfc_add_expr_to_block (&se->pre, tmp);
3569 gfc_add_block_to_block (&se->post, &post);
3571 return has_alternate_specifier;
3575 /* Fill a character string with spaces. */
3578 fill_with_spaces (tree start, tree type, tree size)
3580 stmtblock_t block, loop;
3581 tree i, el, exit_label, cond, tmp;
3583 /* For a simple char type, we can call memset(). */
3584 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3585 return build_call_expr_loc (input_location,
3586 built_in_decls[BUILT_IN_MEMSET], 3, start,
3587 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3588 lang_hooks.to_target_charset (' ')),
3591 /* Otherwise, we use a loop:
3592 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3596 /* Initialize variables. */
3597 gfc_init_block (&block);
3598 i = gfc_create_var (sizetype, "i");
3599 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3600 el = gfc_create_var (build_pointer_type (type), "el");
3601 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3602 exit_label = gfc_build_label_decl (NULL_TREE);
3603 TREE_USED (exit_label) = 1;
3607 gfc_init_block (&loop);
3609 /* Exit condition. */
3610 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3611 fold_convert (sizetype, integer_zero_node));
3612 tmp = build1_v (GOTO_EXPR, exit_label);
3613 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3614 build_empty_stmt (input_location));
3615 gfc_add_expr_to_block (&loop, tmp);
3618 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3619 build_int_cst (type,
3620 lang_hooks.to_target_charset (' ')));
3622 /* Increment loop variables. */
3623 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3624 TYPE_SIZE_UNIT (type)));
3625 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3627 TYPE_SIZE_UNIT (type)));
3629 /* Making the loop... actually loop! */
3630 tmp = gfc_finish_block (&loop);
3631 tmp = build1_v (LOOP_EXPR, tmp);
3632 gfc_add_expr_to_block (&block, tmp);
3634 /* The exit label. */
3635 tmp = build1_v (LABEL_EXPR, exit_label);
3636 gfc_add_expr_to_block (&block, tmp);
3639 return gfc_finish_block (&block);
3643 /* Generate code to copy a string. */
3646 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3647 int dkind, tree slength, tree src, int skind)
3649 tree tmp, dlen, slen;
3658 stmtblock_t tempblock;
3660 gcc_assert (dkind == skind);
3662 if (slength != NULL_TREE)
3664 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3665 ssc = string_to_single_character (slen, src, skind);
3669 slen = build_int_cst (size_type_node, 1);
3673 if (dlength != NULL_TREE)
3675 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3676 dsc = string_to_single_character (slen, dest, dkind);
3680 dlen = build_int_cst (size_type_node, 1);
3684 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3685 ssc = string_to_single_character (slen, src, skind);
3686 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3687 dsc = string_to_single_character (dlen, dest, dkind);
3690 /* Assign directly if the types are compatible. */
3691 if (dsc != NULL_TREE && ssc != NULL_TREE
3692 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3694 gfc_add_modify (block, dsc, ssc);
3698 /* Do nothing if the destination length is zero. */
3699 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3700 build_int_cst (size_type_node, 0));
3702 /* The following code was previously in _gfortran_copy_string:
3704 // The two strings may overlap so we use memmove.
3706 copy_string (GFC_INTEGER_4 destlen, char * dest,
3707 GFC_INTEGER_4 srclen, const char * src)
3709 if (srclen >= destlen)
3711 // This will truncate if too long.
3712 memmove (dest, src, destlen);
3716 memmove (dest, src, srclen);
3718 memset (&dest[srclen], ' ', destlen - srclen);
3722 We're now doing it here for better optimization, but the logic
3725 /* For non-default character kinds, we have to multiply the string
3726 length by the base type size. */
3727 chartype = gfc_get_char_type (dkind);
3728 slen = fold_build2 (MULT_EXPR, size_type_node,
3729 fold_convert (size_type_node, slen),
3730 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3731 dlen = fold_build2 (MULT_EXPR, size_type_node,
3732 fold_convert (size_type_node, dlen),
3733 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3736 dest = fold_convert (pvoid_type_node, dest);
3738 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3741 src = fold_convert (pvoid_type_node, src);
3743 src = gfc_build_addr_expr (pvoid_type_node, src);
3745 /* Truncate string if source is too long. */
3746 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3747 tmp2 = build_call_expr_loc (input_location,
3748 built_in_decls[BUILT_IN_MEMMOVE],
3749 3, dest, src, dlen);
3751 /* Else copy and pad with spaces. */
3752 tmp3 = build_call_expr_loc (input_location,
3753 built_in_decls[BUILT_IN_MEMMOVE],
3754 3, dest, src, slen);
3756 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3757 fold_convert (sizetype, slen));
3758 tmp4 = fill_with_spaces (tmp4, chartype,
3759 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3762 gfc_init_block (&tempblock);
3763 gfc_add_expr_to_block (&tempblock, tmp3);
3764 gfc_add_expr_to_block (&tempblock, tmp4);
3765 tmp3 = gfc_finish_block (&tempblock);
3767 /* The whole copy_string function is there. */
3768 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3769 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3770 build_empty_stmt (input_location));
3771 gfc_add_expr_to_block (block, tmp);
3775 /* Translate a statement function.
3776 The value of a statement function reference is obtained by evaluating the
3777 expression using the values of the actual arguments for the values of the
3778 corresponding dummy arguments. */
3781 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3785 gfc_formal_arglist *fargs;
3786 gfc_actual_arglist *args;
3789 gfc_saved_var *saved_vars;
3795 sym = expr->symtree->n.sym;
3796 args = expr->value.function.actual;
3797 gfc_init_se (&lse, NULL);
3798 gfc_init_se (&rse, NULL);
3801 for (fargs = sym->formal; fargs; fargs = fargs->next)
3803 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3804 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3806 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3808 /* Each dummy shall be specified, explicitly or implicitly, to be
3810 gcc_assert (fargs->sym->attr.dimension == 0);
3813 /* Create a temporary to hold the value. */
3814 type = gfc_typenode_for_spec (&fsym->ts);
3815 temp_vars[n] = gfc_create_var (type, fsym->name);
3817 if (fsym->ts.type == BT_CHARACTER)
3819 /* Copy string arguments. */
3822 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3823 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3825 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3826 tmp = gfc_build_addr_expr (build_pointer_type (type),
3829 gfc_conv_expr (&rse, args->expr);
3830 gfc_conv_string_parameter (&rse);
3831 gfc_add_block_to_block (&se->pre, &lse.pre);
3832 gfc_add_block_to_block (&se->pre, &rse.pre);
3834 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3835 rse.string_length, rse.expr, fsym->ts.kind);
3836 gfc_add_block_to_block (&se->pre, &lse.post);
3837 gfc_add_block_to_block (&se->pre, &rse.post);
3841 /* For everything else, just evaluate the expression. */
3842 gfc_conv_expr (&lse, args->expr);
3844 gfc_add_block_to_block (&se->pre, &lse.pre);
3845 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3846 gfc_add_block_to_block (&se->pre, &lse.post);
3852 /* Use the temporary variables in place of the real ones. */
3853 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3854 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3856 gfc_conv_expr (se, sym->value);
3858 if (sym->ts.type == BT_CHARACTER)
3860 gfc_conv_const_charlen (sym->ts.u.cl);
3862 /* Force the expression to the correct length. */
3863 if (!INTEGER_CST_P (se->string_length)
3864 || tree_int_cst_lt (se->string_length,
3865 sym->ts.u.cl->backend_decl))
3867 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3868 tmp = gfc_create_var (type, sym->name);
3869 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3870 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3871 sym->ts.kind, se->string_length, se->expr,
3875 se->string_length = sym->ts.u.cl->backend_decl;
3878 /* Restore the original variables. */
3879 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3880 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3881 gfc_free (saved_vars);
3885 /* Translate a function expression. */
3888 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3892 if (expr->value.function.isym)
3894 gfc_conv_intrinsic_function (se, expr);
3898 /* We distinguish statement functions from general functions to improve
3899 runtime performance. */
3900 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3902 gfc_conv_statement_function (se, expr);
3906 /* expr.value.function.esym is the resolved (specific) function symbol for
3907 most functions. However this isn't set for dummy procedures. */
3908 sym = expr->value.function.esym;
3910 sym = expr->symtree->n.sym;
3912 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3917 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3920 is_zero_initializer_p (gfc_expr * expr)
3922 if (expr->expr_type != EXPR_CONSTANT)
3925 /* We ignore constants with prescribed memory representations for now. */
3926 if (expr->representation.string)
3929 switch (expr->ts.type)
3932 return mpz_cmp_si (expr->value.integer, 0) == 0;
3935 return mpfr_zero_p (expr->value.real)
3936 && MPFR_SIGN (expr->value.real) >= 0;
3939 return expr->value.logical == 0;
3942 return mpfr_zero_p (mpc_realref (expr->value.complex))
3943 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3944 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3945 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3955 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3957 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3958 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3960 gfc_conv_tmp_array_ref (se);
3961 gfc_advance_se_ss_chain (se);
3965 /* Build a static initializer. EXPR is the expression for the initial value.
3966 The other parameters describe the variable of the component being
3967 initialized. EXPR may be null. */
3970 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3971 bool array, bool pointer)
3975 if (!(expr || pointer))
3978 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3979 (these are the only two iso_c_binding derived types that can be
3980 used as initialization expressions). If so, we need to modify
3981 the 'expr' to be that for a (void *). */
3982 if (expr != NULL && expr->ts.type == BT_DERIVED
3983 && expr->ts.is_iso_c && expr->ts.u.derived)
3985 gfc_symbol *derived = expr->ts.u.derived;
3987 expr = gfc_int_expr (0);
3989 /* The derived symbol has already been converted to a (void *). Use
3991 expr->ts.f90_type = derived->ts.f90_type;
3992 expr->ts.kind = derived->ts.kind;
3994 gfc_init_se (&se, NULL);
3995 gfc_conv_constant (&se, expr);
4001 /* Arrays need special handling. */
4003 return gfc_build_null_descriptor (type);
4004 /* Special case assigning an array to zero. */
4005 else if (is_zero_initializer_p (expr))
4006 return build_constructor (type, NULL);
4008 return gfc_conv_array_initializer (type, expr);
4011 return fold_convert (type, null_pointer_node);
4018 gfc_init_se (&se, NULL);
4019 gfc_conv_structure (&se, expr, 1);
4023 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4026 gfc_init_se (&se, NULL);
4027 gfc_conv_constant (&se, expr);
4034 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4046 gfc_start_block (&block);
4048 /* Initialize the scalarizer. */
4049 gfc_init_loopinfo (&loop);
4051 gfc_init_se (&lse, NULL);
4052 gfc_init_se (&rse, NULL);
4055 rss = gfc_walk_expr (expr);
4056 if (rss == gfc_ss_terminator)
4058 /* The rhs is scalar. Add a ss for the expression. */
4059 rss = gfc_get_ss ();
4060 rss->next = gfc_ss_terminator;
4061 rss->type = GFC_SS_SCALAR;
4065 /* Create a SS for the destination. */
4066 lss = gfc_get_ss ();
4067 lss->type = GFC_SS_COMPONENT;
4069 lss->shape = gfc_get_shape (cm->as->rank);
4070 lss->next = gfc_ss_terminator;
4071 lss->data.info.dimen = cm->as->rank;
4072 lss->data.info.descriptor = dest;
4073 lss->data.info.data = gfc_conv_array_data (dest);
4074 lss->data.info.offset = gfc_conv_array_offset (dest);
4075 for (n = 0; n < cm->as->rank; n++)
4077 lss->data.info.dim[n] = n;
4078 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4079 lss->data.info.stride[n] = gfc_index_one_node;
4081 mpz_init (lss->shape[n]);
4082 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4083 cm->as->lower[n]->value.integer);
4084 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4087 /* Associate the SS with the loop. */
4088 gfc_add_ss_to_loop (&loop, lss);
4089 gfc_add_ss_to_loop (&loop, rss);
4091 /* Calculate the bounds of the scalarization. */
4092 gfc_conv_ss_startstride (&loop);
4094 /* Setup the scalarizing loops. */
4095 gfc_conv_loop_setup (&loop, &expr->where);
4097 /* Setup the gfc_se structures. */
4098 gfc_copy_loopinfo_to_se (&lse, &loop);
4099 gfc_copy_loopinfo_to_se (&rse, &loop);
4102 gfc_mark_ss_chain_used (rss, 1);
4104 gfc_mark_ss_chain_used (lss, 1);
4106 /* Start the scalarized loop body. */
4107 gfc_start_scalarized_body (&loop, &body);
4109 gfc_conv_tmp_array_ref (&lse);
4110 if (cm->ts.type == BT_CHARACTER)
4111 lse.string_length = cm->ts.u.cl->backend_decl;
4113 gfc_conv_expr (&rse, expr);
4115 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4116 gfc_add_expr_to_block (&body, tmp);
4118 gcc_assert (rse.ss == gfc_ss_terminator);
4120 /* Generate the copying loops. */
4121 gfc_trans_scalarizing_loops (&loop, &body);
4123 /* Wrap the whole thing up. */
4124 gfc_add_block_to_block (&block, &loop.pre);
4125 gfc_add_block_to_block (&block, &loop.post);
4127 for (n = 0; n < cm->as->rank; n++)
4128 mpz_clear (lss->shape[n]);
4129 gfc_free (lss->shape);
4131 gfc_cleanup_loop (&loop);
4133 return gfc_finish_block (&block);
4138 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4149 gfc_expr *arg = NULL;
4151 gfc_start_block (&block);
4152 gfc_init_se (&se, NULL);
4154 /* Get the descriptor for the expressions. */
4155 rss = gfc_walk_expr (expr);
4156 se.want_pointer = 0;
4157 gfc_conv_expr_descriptor (&se, expr, rss);
4158 gfc_add_block_to_block (&block, &se.pre);
4159 gfc_add_modify (&block, dest, se.expr);
4161 /* Deal with arrays of derived types with allocatable components. */
4162 if (cm->ts.type == BT_DERIVED
4163 && cm->ts.u.derived->attr.alloc_comp)
4164 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4168 tmp = gfc_duplicate_allocatable (dest, se.expr,
4169 TREE_TYPE(cm->backend_decl),
4172 gfc_add_expr_to_block (&block, tmp);
4173 gfc_add_block_to_block (&block, &se.post);
4175 if (expr->expr_type != EXPR_VARIABLE)
4176 gfc_conv_descriptor_data_set (&block, se.expr,
4179 /* We need to know if the argument of a conversion function is a
4180 variable, so that the correct lower bound can be used. */
4181 if (expr->expr_type == EXPR_FUNCTION
4182 && expr->value.function.isym
4183 && expr->value.function.isym->conversion
4184 && expr->value.function.actual->expr
4185 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4186 arg = expr->value.function.actual->expr;
4188 /* Obtain the array spec of full array references. */
4190 as = gfc_get_full_arrayspec_from_expr (arg);
4192 as = gfc_get_full_arrayspec_from_expr (expr);
4194 /* Shift the lbound and ubound of temporaries to being unity,
4195 rather than zero, based. Always calculate the offset. */
4196 offset = gfc_conv_descriptor_offset_get (dest);
4197 gfc_add_modify (&block, offset, gfc_index_zero_node);
4198 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4200 for (n = 0; n < expr->rank; n++)
4205 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4206 TODO It looks as if gfc_conv_expr_descriptor should return
4207 the correct bounds and that the following should not be
4208 necessary. This would simplify gfc_conv_intrinsic_bound
4210 if (as && as->lower[n])
4213 gfc_init_se (&lbse, NULL);
4214 gfc_conv_expr (&lbse, as->lower[n]);
4215 gfc_add_block_to_block (&block, &lbse.pre);
4216 lbound = gfc_evaluate_now (lbse.expr, &block);
4220 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4221 lbound = gfc_conv_descriptor_lbound_get (tmp,
4225 lbound = gfc_conv_descriptor_lbound_get (dest,
4228 lbound = gfc_index_one_node;
4230 lbound = fold_convert (gfc_array_index_type, lbound);
4232 /* Shift the bounds and set the offset accordingly. */
4233 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4234 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4235 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4236 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4237 gfc_conv_descriptor_ubound_set (&block, dest,
4238 gfc_rank_cst[n], tmp);
4239 gfc_conv_descriptor_lbound_set (&block, dest,
4240 gfc_rank_cst[n], lbound);
4242 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4243 gfc_conv_descriptor_lbound_get (dest,
4245 gfc_conv_descriptor_stride_get (dest,
4247 gfc_add_modify (&block, tmp2, tmp);
4248 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4249 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4254 /* If a conversion expression has a null data pointer
4255 argument, nullify the allocatable component. */
4259 if (arg->symtree->n.sym->attr.allocatable
4260 || arg->symtree->n.sym->attr.pointer)
4262 non_null_expr = gfc_finish_block (&block);
4263 gfc_start_block (&block);
4264 gfc_conv_descriptor_data_set (&block, dest,
4266 null_expr = gfc_finish_block (&block);
4267 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4268 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4269 fold_convert (TREE_TYPE (tmp),
4270 null_pointer_node));
4271 return build3_v (COND_EXPR, tmp,
4272 null_expr, non_null_expr);
4276 return gfc_finish_block (&block);
4280 /* Assign a single component of a derived type constructor. */
4283 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4291 gfc_start_block (&block);
4293 if (cm->attr.pointer)
4295 gfc_init_se (&se, NULL);
4296 /* Pointer component. */
4297 if (cm->attr.dimension)
4299 /* Array pointer. */
4300 if (expr->expr_type == EXPR_NULL)
4301 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4304 rss = gfc_walk_expr (expr);
4305 se.direct_byref = 1;
4307 gfc_conv_expr_descriptor (&se, expr, rss);
4308 gfc_add_block_to_block (&block, &se.pre);
4309 gfc_add_block_to_block (&block, &se.post);
4314 /* Scalar pointers. */
4315 se.want_pointer = 1;
4316 gfc_conv_expr (&se, expr);
4317 gfc_add_block_to_block (&block, &se.pre);
4318 gfc_add_modify (&block, dest,
4319 fold_convert (TREE_TYPE (dest), se.expr));
4320 gfc_add_block_to_block (&block, &se.post);
4323 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4325 /* NULL initialization for CLASS components. */
4326 tmp = gfc_trans_structure_assign (dest,
4327 gfc_default_initializer (&cm->ts));
4328 gfc_add_expr_to_block (&block, tmp);
4330 else if (cm->attr.dimension)
4332 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4333 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4334 else if (cm->attr.allocatable)
4336 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4337 gfc_add_expr_to_block (&block, tmp);
4341 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4342 gfc_add_expr_to_block (&block, tmp);
4345 else if (expr->ts.type == BT_DERIVED)
4347 if (expr->expr_type != EXPR_STRUCTURE)
4349 gfc_init_se (&se, NULL);
4350 gfc_conv_expr (&se, expr);
4351 gfc_add_block_to_block (&block, &se.pre);
4352 gfc_add_modify (&block, dest,
4353 fold_convert (TREE_TYPE (dest), se.expr));
4354 gfc_add_block_to_block (&block, &se.post);
4358 /* Nested constructors. */
4359 tmp = gfc_trans_structure_assign (dest, expr);
4360 gfc_add_expr_to_block (&block, tmp);
4365 /* Scalar component. */
4366 gfc_init_se (&se, NULL);
4367 gfc_init_se (&lse, NULL);
4369 gfc_conv_expr (&se, expr);
4370 if (cm->ts.type == BT_CHARACTER)
4371 lse.string_length = cm->ts.u.cl->backend_decl;
4373 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4374 gfc_add_expr_to_block (&block, tmp);
4376 return gfc_finish_block (&block);
4379 /* Assign a derived type constructor to a variable. */
4382 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4390 gfc_start_block (&block);
4391 cm = expr->ts.u.derived->components;
4392 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4394 /* Skip absent members in default initializers. */
4398 /* Handle c_null_(fun)ptr. */
4399 if (c && c->expr && c->expr->ts.is_iso_c)
4401 field = cm->backend_decl;
4402 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4403 dest, field, NULL_TREE);
4404 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4405 fold_convert (TREE_TYPE (tmp),
4406 null_pointer_node));
4407 gfc_add_expr_to_block (&block, tmp);
4411 field = cm->backend_decl;
4412 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4413 dest, field, NULL_TREE);
4414 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4415 gfc_add_expr_to_block (&block, tmp);
4417 return gfc_finish_block (&block);
4420 /* Build an expression for a constructor. If init is nonzero then
4421 this is part of a static variable initializer. */
4424 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4431 VEC(constructor_elt,gc) *v = NULL;
4433 gcc_assert (se->ss == NULL);
4434 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4435 type = gfc_typenode_for_spec (&expr->ts);
4439 /* Create a temporary variable and fill it in. */
4440 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4441 tmp = gfc_trans_structure_assign (se->expr, expr);
4442 gfc_add_expr_to_block (&se->pre, tmp);
4446 cm = expr->ts.u.derived->components;
4448 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4450 /* Skip absent members in default initializers and allocatable
4451 components. Although the latter have a default initializer
4452 of EXPR_NULL,... by default, the static nullify is not needed
4453 since this is done every time we come into scope. */
4454 if (!c->expr || cm->attr.allocatable)
4457 if (cm->ts.type == BT_CLASS)
4459 gfc_component *data;
4460 data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
4461 if (!data->backend_decl)
4462 gfc_get_derived_type (cm->ts.u.derived);
4463 val = gfc_conv_initializer (c->expr, &cm->ts,
4464 TREE_TYPE (data->backend_decl),
4465 data->attr.dimension,
4466 data->attr.pointer);
4468 CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
4470 else if (strcmp (cm->name, "$size") == 0)
4472 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4473 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4475 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4476 && strcmp (cm->name, "$extends") == 0)
4479 vtabs = cm->initializer->symtree->n.sym;
4480 val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4481 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4485 val = gfc_conv_initializer (c->expr, &cm->ts,
4486 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4487 cm->attr.pointer || cm->attr.proc_pointer);
4489 /* Append it to the constructor list. */
4490 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4493 se->expr = build_constructor (type, v);
4495 TREE_CONSTANT (se->expr) = 1;
4499 /* Translate a substring expression. */
4502 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4508 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4510 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4511 expr->value.character.length,
4512 expr->value.character.string);
4514 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4515 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4518 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4522 /* Entry point for expression translation. Evaluates a scalar quantity.
4523 EXPR is the expression to be translated, and SE is the state structure if
4524 called from within the scalarized. */
4527 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4529 if (se->ss && se->ss->expr == expr
4530 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4532 /* Substitute a scalar expression evaluated outside the scalarization
4534 se->expr = se->ss->data.scalar.expr;
4535 se->string_length = se->ss->string_length;
4536 gfc_advance_se_ss_chain (se);
4540 /* We need to convert the expressions for the iso_c_binding derived types.
4541 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4542 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4543 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4544 updated to be an integer with a kind equal to the size of a (void *). */
4545 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4546 && expr->ts.u.derived->attr.is_iso_c)
4548 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4549 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4551 /* Set expr_type to EXPR_NULL, which will result in
4552 null_pointer_node being used below. */
4553 expr->expr_type = EXPR_NULL;
4557 /* Update the type/kind of the expression to be what the new
4558 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4559 expr->ts.type = expr->ts.u.derived->ts.type;
4560 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4561 expr->ts.kind = expr->ts.u.derived->ts.kind;
4565 switch (expr->expr_type)
4568 gfc_conv_expr_op (se, expr);
4572 gfc_conv_function_expr (se, expr);
4576 gfc_conv_constant (se, expr);
4580 gfc_conv_variable (se, expr);
4584 se->expr = null_pointer_node;
4587 case EXPR_SUBSTRING:
4588 gfc_conv_substring_expr (se, expr);
4591 case EXPR_STRUCTURE:
4592 gfc_conv_structure (se, expr, 0);
4596 gfc_conv_array_constructor_expr (se, expr);
4605 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4606 of an assignment. */
4608 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4610 gfc_conv_expr (se, expr);
4611 /* All numeric lvalues should have empty post chains. If not we need to
4612 figure out a way of rewriting an lvalue so that it has no post chain. */
4613 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4616 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4617 numeric expressions. Used for scalar values where inserting cleanup code
4620 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4624 gcc_assert (expr->ts.type != BT_CHARACTER);
4625 gfc_conv_expr (se, expr);
4628 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4629 gfc_add_modify (&se->pre, val, se->expr);
4631 gfc_add_block_to_block (&se->pre, &se->post);
4635 /* Helper to translate an expression and convert it to a particular type. */
4637 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4639 gfc_conv_expr_val (se, expr);
4640 se->expr = convert (type, se->expr);
4644 /* Converts an expression so that it can be passed by reference. Scalar
4648 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4652 if (se->ss && se->ss->expr == expr
4653 && se->ss->type == GFC_SS_REFERENCE)
4655 se->expr = se->ss->data.scalar.expr;
4656 se->string_length = se->ss->string_length;
4657 gfc_advance_se_ss_chain (se);
4661 if (expr->ts.type == BT_CHARACTER)
4663 gfc_conv_expr (se, expr);
4664 gfc_conv_string_parameter (se);
4668 if (expr->expr_type == EXPR_VARIABLE)
4670 se->want_pointer = 1;
4671 gfc_conv_expr (se, expr);
4674 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4675 gfc_add_modify (&se->pre, var, se->expr);
4676 gfc_add_block_to_block (&se->pre, &se->post);
4682 if (expr->expr_type == EXPR_FUNCTION
4683 && ((expr->value.function.esym
4684 && expr->value.function.esym->result->attr.pointer
4685 && !expr->value.function.esym->result->attr.dimension)
4686 || (!expr->value.function.esym
4687 && expr->symtree->n.sym->attr.pointer
4688 && !expr->symtree->n.sym->attr.dimension)))
4690 se->want_pointer = 1;
4691 gfc_conv_expr (se, expr);
4692 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4693 gfc_add_modify (&se->pre, var, se->expr);
4699 gfc_conv_expr (se, expr);
4701 /* Create a temporary var to hold the value. */
4702 if (TREE_CONSTANT (se->expr))
4704 tree tmp = se->expr;
4705 STRIP_TYPE_NOPS (tmp);
4706 var = build_decl (input_location,
4707 CONST_DECL, NULL, TREE_TYPE (tmp));
4708 DECL_INITIAL (var) = tmp;
4709 TREE_STATIC (var) = 1;
4714 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4715 gfc_add_modify (&se->pre, var, se->expr);
4717 gfc_add_block_to_block (&se->pre, &se->post);
4719 /* Take the address of that value. */
4720 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4725 gfc_trans_pointer_assign (gfc_code * code)
4727 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4731 /* Generate code for a pointer assignment. */
4734 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4745 gfc_start_block (&block);
4747 gfc_init_se (&lse, NULL);
4749 lss = gfc_walk_expr (expr1);
4750 rss = gfc_walk_expr (expr2);
4751 if (lss == gfc_ss_terminator)
4753 /* Scalar pointers. */
4754 lse.want_pointer = 1;
4755 gfc_conv_expr (&lse, expr1);
4756 gcc_assert (rss == gfc_ss_terminator);
4757 gfc_init_se (&rse, NULL);
4758 rse.want_pointer = 1;
4759 gfc_conv_expr (&rse, expr2);
4761 if (expr1->symtree->n.sym->attr.proc_pointer
4762 && expr1->symtree->n.sym->attr.dummy)
4763 lse.expr = build_fold_indirect_ref_loc (input_location,
4766 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4767 && expr2->symtree->n.sym->attr.dummy)
4768 rse.expr = build_fold_indirect_ref_loc (input_location,
4771 gfc_add_block_to_block (&block, &lse.pre);
4772 gfc_add_block_to_block (&block, &rse.pre);
4774 /* Check character lengths if character expression. The test is only
4775 really added if -fbounds-check is enabled. */
4776 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4777 && !expr1->symtree->n.sym->attr.proc_pointer
4778 && !gfc_is_proc_ptr_comp (expr1, NULL))
4780 gcc_assert (expr2->ts.type == BT_CHARACTER);
4781 gcc_assert (lse.string_length && rse.string_length);
4782 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4783 lse.string_length, rse.string_length,
4787 gfc_add_modify (&block, lse.expr,
4788 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4790 gfc_add_block_to_block (&block, &rse.post);
4791 gfc_add_block_to_block (&block, &lse.post);
4796 tree strlen_rhs = NULL_TREE;
4798 /* Array pointer. */
4799 gfc_conv_expr_descriptor (&lse, expr1, lss);
4800 strlen_lhs = lse.string_length;
4801 switch (expr2->expr_type)
4804 /* Just set the data pointer to null. */
4805 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4809 /* Assign directly to the pointer's descriptor. */
4810 lse.direct_byref = 1;
4811 gfc_conv_expr_descriptor (&lse, expr2, rss);
4812 strlen_rhs = lse.string_length;
4814 /* If this is a subreference array pointer assignment, use the rhs
4815 descriptor element size for the lhs span. */
4816 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4818 decl = expr1->symtree->n.sym->backend_decl;
4819 gfc_init_se (&rse, NULL);
4820 rse.descriptor_only = 1;
4821 gfc_conv_expr (&rse, expr2);
4822 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4823 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4824 if (!INTEGER_CST_P (tmp))
4825 gfc_add_block_to_block (&lse.post, &rse.pre);
4826 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4832 /* Assign to a temporary descriptor and then copy that
4833 temporary to the pointer. */
4835 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4838 lse.direct_byref = 1;
4839 gfc_conv_expr_descriptor (&lse, expr2, rss);
4840 strlen_rhs = lse.string_length;
4841 gfc_add_modify (&lse.pre, desc, tmp);
4845 gfc_add_block_to_block (&block, &lse.pre);
4847 /* Check string lengths if applicable. The check is only really added
4848 to the output code if -fbounds-check is enabled. */
4849 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4851 gcc_assert (expr2->ts.type == BT_CHARACTER);
4852 gcc_assert (strlen_lhs && strlen_rhs);
4853 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4854 strlen_lhs, strlen_rhs, &block);
4857 gfc_add_block_to_block (&block, &lse.post);
4859 return gfc_finish_block (&block);
4863 /* Makes sure se is suitable for passing as a function string parameter. */
4864 /* TODO: Need to check all callers of this function. It may be abused. */
4867 gfc_conv_string_parameter (gfc_se * se)
4871 if (TREE_CODE (se->expr) == STRING_CST)
4873 type = TREE_TYPE (TREE_TYPE (se->expr));
4874 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4878 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4880 if (TREE_CODE (se->expr) != INDIRECT_REF)
4882 type = TREE_TYPE (se->expr);
4883 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4887 type = gfc_get_character_type_len (gfc_default_character_kind,
4889 type = build_pointer_type (type);
4890 se->expr = gfc_build_addr_expr (type, se->expr);
4894 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4895 gcc_assert (se->string_length
4896 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4900 /* Generate code for assignment of scalar variables. Includes character
4901 strings and derived types with allocatable components.
4902 If you know that the LHS has no allocations, set dealloc to false. */
4905 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4906 bool l_is_temp, bool r_is_var, bool dealloc)
4912 gfc_init_block (&block);
4914 if (ts.type == BT_CHARACTER)
4919 if (lse->string_length != NULL_TREE)
4921 gfc_conv_string_parameter (lse);
4922 gfc_add_block_to_block (&block, &lse->pre);
4923 llen = lse->string_length;
4926 if (rse->string_length != NULL_TREE)
4928 gcc_assert (rse->string_length != NULL_TREE);
4929 gfc_conv_string_parameter (rse);
4930 gfc_add_block_to_block (&block, &rse->pre);
4931 rlen = rse->string_length;
4934 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4935 rse->expr, ts.kind);
4937 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4941 /* Are the rhs and the lhs the same? */
4944 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4945 gfc_build_addr_expr (NULL_TREE, lse->expr),
4946 gfc_build_addr_expr (NULL_TREE, rse->expr));
4947 cond = gfc_evaluate_now (cond, &lse->pre);
4950 /* Deallocate the lhs allocated components as long as it is not
4951 the same as the rhs. This must be done following the assignment
4952 to prevent deallocating data that could be used in the rhs
4954 if (!l_is_temp && dealloc)
4956 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4957 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4959 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4961 gfc_add_expr_to_block (&lse->post, tmp);
4964 gfc_add_block_to_block (&block, &rse->pre);
4965 gfc_add_block_to_block (&block, &lse->pre);
4967 gfc_add_modify (&block, lse->expr,
4968 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4970 /* Do a deep copy if the rhs is a variable, if it is not the
4974 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4975 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4977 gfc_add_expr_to_block (&block, tmp);
4980 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4982 gfc_add_block_to_block (&block, &lse->pre);
4983 gfc_add_block_to_block (&block, &rse->pre);
4984 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4985 gfc_add_modify (&block, lse->expr, tmp);
4989 gfc_add_block_to_block (&block, &lse->pre);
4990 gfc_add_block_to_block (&block, &rse->pre);
4992 gfc_add_modify (&block, lse->expr,
4993 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4996 gfc_add_block_to_block (&block, &lse->post);
4997 gfc_add_block_to_block (&block, &rse->post);
4999 return gfc_finish_block (&block);
5003 /* Try to translate array(:) = func (...), where func is a transformational
5004 array function, without using a temporary. Returns NULL is this isn't the
5008 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5013 bool seen_array_ref;
5015 gfc_component *comp = NULL;
5017 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5018 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5021 /* Elemental functions don't need a temporary anyway. */
5022 if (expr2->value.function.esym != NULL
5023 && expr2->value.function.esym->attr.elemental)
5026 /* Fail if rhs is not FULL or a contiguous section. */
5027 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5030 /* Fail if EXPR1 can't be expressed as a descriptor. */
5031 if (gfc_ref_needs_temporary_p (expr1->ref))
5034 /* Functions returning pointers need temporaries. */
5035 if (expr2->symtree->n.sym->attr.pointer
5036 || expr2->symtree->n.sym->attr.allocatable)
5039 /* Character array functions need temporaries unless the
5040 character lengths are the same. */
5041 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5043 if (expr1->ts.u.cl->length == NULL
5044 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5047 if (expr2->ts.u.cl->length == NULL
5048 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5051 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5052 expr2->ts.u.cl->length->value.integer) != 0)
5056 /* Check that no LHS component references appear during an array
5057 reference. This is needed because we do not have the means to
5058 span any arbitrary stride with an array descriptor. This check
5059 is not needed for the rhs because the function result has to be
5061 seen_array_ref = false;
5062 for (ref = expr1->ref; ref; ref = ref->next)
5064 if (ref->type == REF_ARRAY)
5065 seen_array_ref= true;
5066 else if (ref->type == REF_COMPONENT && seen_array_ref)
5070 /* Check for a dependency. */
5071 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5072 expr2->value.function.esym,
5073 expr2->value.function.actual,
5077 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5079 gcc_assert (expr2->value.function.isym
5080 || (gfc_is_proc_ptr_comp (expr2, &comp)
5081 && comp && comp->attr.dimension)
5082 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5083 && expr2->value.function.esym->result->attr.dimension));
5085 ss = gfc_walk_expr (expr1);
5086 gcc_assert (ss != gfc_ss_terminator);
5087 gfc_init_se (&se, NULL);
5088 gfc_start_block (&se.pre);
5089 se.want_pointer = 1;
5091 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5093 if (expr1->ts.type == BT_DERIVED
5094 && expr1->ts.u.derived->attr.alloc_comp)
5097 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5099 gfc_add_expr_to_block (&se.pre, tmp);
5102 se.direct_byref = 1;
5103 se.ss = gfc_walk_expr (expr2);
5104 gcc_assert (se.ss != gfc_ss_terminator);
5105 gfc_conv_function_expr (&se, expr2);
5106 gfc_add_block_to_block (&se.pre, &se.post);
5108 return gfc_finish_block (&se.pre);
5112 /* Try to efficiently translate array(:) = 0. Return NULL if this
5116 gfc_trans_zero_assign (gfc_expr * expr)
5118 tree dest, len, type;
5122 sym = expr->symtree->n.sym;
5123 dest = gfc_get_symbol_decl (sym);
5125 type = TREE_TYPE (dest);
5126 if (POINTER_TYPE_P (type))
5127 type = TREE_TYPE (type);
5128 if (!GFC_ARRAY_TYPE_P (type))
5131 /* Determine the length of the array. */
5132 len = GFC_TYPE_ARRAY_SIZE (type);
5133 if (!len || TREE_CODE (len) != INTEGER_CST)
5136 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5137 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5138 fold_convert (gfc_array_index_type, tmp));
5140 /* If we are zeroing a local array avoid taking its address by emitting
5142 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5143 return build2 (MODIFY_EXPR, void_type_node,
5144 dest, build_constructor (TREE_TYPE (dest), NULL));
5146 /* Convert arguments to the correct types. */
5147 dest = fold_convert (pvoid_type_node, dest);
5148 len = fold_convert (size_type_node, len);
5150 /* Construct call to __builtin_memset. */
5151 tmp = build_call_expr_loc (input_location,
5152 built_in_decls[BUILT_IN_MEMSET],
5153 3, dest, integer_zero_node, len);
5154 return fold_convert (void_type_node, tmp);
5158 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5159 that constructs the call to __builtin_memcpy. */
5162 gfc_build_memcpy_call (tree dst, tree src, tree len)
5166 /* Convert arguments to the correct types. */
5167 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5168 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5170 dst = fold_convert (pvoid_type_node, dst);
5172 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5173 src = gfc_build_addr_expr (pvoid_type_node, src);
5175 src = fold_convert (pvoid_type_node, src);
5177 len = fold_convert (size_type_node, len);
5179 /* Construct call to __builtin_memcpy. */
5180 tmp = build_call_expr_loc (input_location,
5181 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5182 return fold_convert (void_type_node, tmp);
5186 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5187 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5188 source/rhs, both are gfc_full_array_ref_p which have been checked for
5192 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5194 tree dst, dlen, dtype;
5195 tree src, slen, stype;
5198 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5199 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5201 dtype = TREE_TYPE (dst);
5202 if (POINTER_TYPE_P (dtype))
5203 dtype = TREE_TYPE (dtype);
5204 stype = TREE_TYPE (src);
5205 if (POINTER_TYPE_P (stype))
5206 stype = TREE_TYPE (stype);
5208 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5211 /* Determine the lengths of the arrays. */
5212 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5213 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5215 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5216 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5217 fold_convert (gfc_array_index_type, tmp));
5219 slen = GFC_TYPE_ARRAY_SIZE (stype);
5220 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5222 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5223 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5224 fold_convert (gfc_array_index_type, tmp));
5226 /* Sanity check that they are the same. This should always be
5227 the case, as we should already have checked for conformance. */
5228 if (!tree_int_cst_equal (slen, dlen))
5231 return gfc_build_memcpy_call (dst, src, dlen);
5235 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5236 this can't be done. EXPR1 is the destination/lhs for which
5237 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5240 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5242 unsigned HOST_WIDE_INT nelem;
5248 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5252 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5253 dtype = TREE_TYPE (dst);
5254 if (POINTER_TYPE_P (dtype))
5255 dtype = TREE_TYPE (dtype);
5256 if (!GFC_ARRAY_TYPE_P (dtype))
5259 /* Determine the lengths of the array. */
5260 len = GFC_TYPE_ARRAY_SIZE (dtype);
5261 if (!len || TREE_CODE (len) != INTEGER_CST)
5264 /* Confirm that the constructor is the same size. */
5265 if (compare_tree_int (len, nelem) != 0)
5268 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5269 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5270 fold_convert (gfc_array_index_type, tmp));
5272 stype = gfc_typenode_for_spec (&expr2->ts);
5273 src = gfc_build_constant_array_constructor (expr2, stype);
5275 stype = TREE_TYPE (src);
5276 if (POINTER_TYPE_P (stype))
5277 stype = TREE_TYPE (stype);
5279 return gfc_build_memcpy_call (dst, src, len);
5283 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5284 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5285 init_flag indicates initialization expressions and dealloc that no
5286 deallocate prior assignment is needed (if in doubt, set true). */
5289 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5295 gfc_ss *lss_section;
5302 bool scalar_to_array;
5305 /* Assignment of the form lhs = rhs. */
5306 gfc_start_block (&block);
5308 gfc_init_se (&lse, NULL);
5309 gfc_init_se (&rse, NULL);
5312 lss = gfc_walk_expr (expr1);
5314 if (lss != gfc_ss_terminator)
5316 /* Allow the scalarizer to workshare array assignments. */
5317 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5318 ompws_flags |= OMPWS_SCALARIZER_WS;
5320 /* The assignment needs scalarization. */
5323 /* Find a non-scalar SS from the lhs. */
5324 while (lss_section != gfc_ss_terminator
5325 && lss_section->type != GFC_SS_SECTION)
5326 lss_section = lss_section->next;
5328 gcc_assert (lss_section != gfc_ss_terminator);
5330 /* Initialize the scalarizer. */
5331 gfc_init_loopinfo (&loop);
5334 rss = gfc_walk_expr (expr2);
5335 if (rss == gfc_ss_terminator)
5337 /* The rhs is scalar. Add a ss for the expression. */
5338 rss = gfc_get_ss ();
5339 rss->next = gfc_ss_terminator;
5340 rss->type = GFC_SS_SCALAR;
5343 /* Associate the SS with the loop. */
5344 gfc_add_ss_to_loop (&loop, lss);
5345 gfc_add_ss_to_loop (&loop, rss);
5347 /* Calculate the bounds of the scalarization. */
5348 gfc_conv_ss_startstride (&loop);
5349 /* Resolve any data dependencies in the statement. */
5350 gfc_conv_resolve_dependencies (&loop, lss, rss);
5351 /* Setup the scalarizing loops. */
5352 gfc_conv_loop_setup (&loop, &expr2->where);
5354 /* Setup the gfc_se structures. */
5355 gfc_copy_loopinfo_to_se (&lse, &loop);
5356 gfc_copy_loopinfo_to_se (&rse, &loop);
5359 gfc_mark_ss_chain_used (rss, 1);
5360 if (loop.temp_ss == NULL)
5363 gfc_mark_ss_chain_used (lss, 1);
5367 lse.ss = loop.temp_ss;
5368 gfc_mark_ss_chain_used (lss, 3);
5369 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5372 /* Start the scalarized loop body. */
5373 gfc_start_scalarized_body (&loop, &body);
5376 gfc_init_block (&body);
5378 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5380 /* Translate the expression. */
5381 gfc_conv_expr (&rse, expr2);
5383 /* Stabilize a string length for temporaries. */
5384 if (expr2->ts.type == BT_CHARACTER)
5385 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5387 string_length = NULL_TREE;
5391 gfc_conv_tmp_array_ref (&lse);
5392 gfc_advance_se_ss_chain (&lse);
5393 if (expr2->ts.type == BT_CHARACTER)
5394 lse.string_length = string_length;
5397 gfc_conv_expr (&lse, expr1);
5399 /* Assignments of scalar derived types with allocatable components
5400 to arrays must be done with a deep copy and the rhs temporary
5401 must have its components deallocated afterwards. */
5402 scalar_to_array = (expr2->ts.type == BT_DERIVED
5403 && expr2->ts.u.derived->attr.alloc_comp
5404 && expr2->expr_type != EXPR_VARIABLE
5405 && !gfc_is_constant_expr (expr2)
5406 && expr1->rank && !expr2->rank);
5407 if (scalar_to_array && dealloc)
5409 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5410 gfc_add_expr_to_block (&loop.post, tmp);
5413 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5414 l_is_temp || init_flag,
5415 (expr2->expr_type == EXPR_VARIABLE)
5416 || scalar_to_array, dealloc);
5417 gfc_add_expr_to_block (&body, tmp);
5419 if (lss == gfc_ss_terminator)
5421 /* Use the scalar assignment as is. */
5422 gfc_add_block_to_block (&block, &body);
5426 gcc_assert (lse.ss == gfc_ss_terminator
5427 && rse.ss == gfc_ss_terminator);
5431 gfc_trans_scalarized_loop_boundary (&loop, &body);
5433 /* We need to copy the temporary to the actual lhs. */
5434 gfc_init_se (&lse, NULL);
5435 gfc_init_se (&rse, NULL);
5436 gfc_copy_loopinfo_to_se (&lse, &loop);
5437 gfc_copy_loopinfo_to_se (&rse, &loop);
5439 rse.ss = loop.temp_ss;
5442 gfc_conv_tmp_array_ref (&rse);
5443 gfc_advance_se_ss_chain (&rse);
5444 gfc_conv_expr (&lse, expr1);
5446 gcc_assert (lse.ss == gfc_ss_terminator
5447 && rse.ss == gfc_ss_terminator);
5449 if (expr2->ts.type == BT_CHARACTER)
5450 rse.string_length = string_length;
5452 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5453 false, false, dealloc);
5454 gfc_add_expr_to_block (&body, tmp);
5457 /* Generate the copying loops. */
5458 gfc_trans_scalarizing_loops (&loop, &body);
5460 /* Wrap the whole thing up. */
5461 gfc_add_block_to_block (&block, &loop.pre);
5462 gfc_add_block_to_block (&block, &loop.post);
5464 gfc_cleanup_loop (&loop);
5467 return gfc_finish_block (&block);
5471 /* Check whether EXPR is a copyable array. */
5474 copyable_array_p (gfc_expr * expr)
5476 if (expr->expr_type != EXPR_VARIABLE)
5479 /* First check it's an array. */
5480 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5483 if (!gfc_full_array_ref_p (expr->ref, NULL))
5486 /* Next check that it's of a simple enough type. */
5487 switch (expr->ts.type)
5499 return !expr->ts.u.derived->attr.alloc_comp;
5508 /* Translate an assignment. */
5511 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5516 /* Special case a single function returning an array. */
5517 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5519 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5524 /* Special case assigning an array to zero. */
5525 if (copyable_array_p (expr1)
5526 && is_zero_initializer_p (expr2))
5528 tmp = gfc_trans_zero_assign (expr1);
5533 /* Special case copying one array to another. */
5534 if (copyable_array_p (expr1)
5535 && copyable_array_p (expr2)
5536 && gfc_compare_types (&expr1->ts, &expr2->ts)
5537 && !gfc_check_dependency (expr1, expr2, 0))
5539 tmp = gfc_trans_array_copy (expr1, expr2);
5544 /* Special case initializing an array from a constant array constructor. */
5545 if (copyable_array_p (expr1)
5546 && expr2->expr_type == EXPR_ARRAY
5547 && gfc_compare_types (&expr1->ts, &expr2->ts))
5549 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5554 /* Fallback to the scalarizer to generate explicit loops. */
5555 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5559 gfc_trans_init_assign (gfc_code * code)
5561 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5565 gfc_trans_assign (gfc_code * code)
5567 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5571 /* Translate an assignment to a CLASS object
5572 (pointer or ordinary assignment). */
5575 gfc_trans_class_assign (gfc_code *code)
5582 gfc_start_block (&block);
5584 if (code->op == EXEC_INIT_ASSIGN)
5586 /* Special case for initializing a CLASS variable on allocation.
5587 A MEMCPY is needed to copy the full data of the dynamic type,
5588 which may be different from the declared type. */
5591 gfc_init_se (&dst, NULL);
5592 gfc_init_se (&src, NULL);
5593 gfc_add_component_ref (code->expr1, "$data");
5594 gfc_conv_expr (&dst, code->expr1);
5595 gfc_conv_expr (&src, code->expr2);
5596 gfc_add_block_to_block (&block, &src.pre);
5597 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5598 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5599 gfc_add_expr_to_block (&block, tmp);
5600 return gfc_finish_block (&block);
5603 if (code->expr2->ts.type != BT_CLASS)
5605 /* Insert an additional assignment which sets the '$vptr' field. */
5606 lhs = gfc_copy_expr (code->expr1);
5607 gfc_add_component_ref (lhs, "$vptr");
5608 if (code->expr2->ts.type == BT_DERIVED)
5612 vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
5615 rhs = gfc_get_expr ();
5616 rhs->expr_type = EXPR_VARIABLE;
5617 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5621 else if (code->expr2->expr_type == EXPR_NULL)
5622 rhs = gfc_int_expr (0);
5626 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5627 gfc_add_expr_to_block (&block, tmp);
5629 gfc_free_expr (lhs);
5630 gfc_free_expr (rhs);
5633 /* Do the actual CLASS assignment. */
5634 if (code->expr2->ts.type == BT_CLASS)
5635 code->op = EXEC_ASSIGN;
5637 gfc_add_component_ref (code->expr1, "$data");
5639 if (code->op == EXEC_ASSIGN)
5640 tmp = gfc_trans_assign (code);
5641 else if (code->op == EXEC_POINTER_ASSIGN)
5642 tmp = gfc_trans_pointer_assign (code);
5646 gfc_add_expr_to_block (&block, tmp);
5648 return gfc_finish_block (&block);