1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Fortran 2008 allows to pass null pointers and non-associated pointers
145 as actual argument to denote absent dummies. For array descriptors,
146 we thus also need to check the array descriptor. */
147 if (!sym->attr.pointer && !sym->attr.allocatable
148 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
149 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
152 tmp = build_fold_indirect_ref_loc (input_location, decl);
153 tmp = gfc_conv_array_data (tmp);
154 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
155 fold_convert (TREE_TYPE (tmp), null_pointer_node));
156 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
157 boolean_type_node, cond, tmp);
164 /* Converts a missing, dummy argument into a null or zero. */
167 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
172 present = gfc_conv_expr_present (arg->symtree->n.sym);
176 /* Create a temporary and convert it to the correct type. */
177 tmp = gfc_get_int_type (kind);
178 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
181 /* Test for a NULL value. */
182 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
183 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
184 tmp = gfc_evaluate_now (tmp, &se->pre);
185 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
189 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
191 build_zero_cst (TREE_TYPE (se->expr)));
192 tmp = gfc_evaluate_now (tmp, &se->pre);
196 if (ts.type == BT_CHARACTER)
198 tmp = build_int_cst (gfc_charlen_type_node, 0);
199 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
200 present, se->string_length, tmp);
201 tmp = gfc_evaluate_now (tmp, &se->pre);
202 se->string_length = tmp;
208 /* Get the character length of an expression, looking through gfc_refs
212 gfc_get_expr_charlen (gfc_expr *e)
217 gcc_assert (e->expr_type == EXPR_VARIABLE
218 && e->ts.type == BT_CHARACTER);
220 length = NULL; /* To silence compiler warning. */
222 if (is_subref_array (e) && e->ts.u.cl->length)
225 gfc_init_se (&tmpse, NULL);
226 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
227 e->ts.u.cl->backend_decl = tmpse.expr;
231 /* First candidate: if the variable is of type CHARACTER, the
232 expression's length could be the length of the character
234 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
235 length = e->symtree->n.sym->ts.u.cl->backend_decl;
237 /* Look through the reference chain for component references. */
238 for (r = e->ref; r; r = r->next)
243 if (r->u.c.component->ts.type == BT_CHARACTER)
244 length = r->u.c.component->ts.u.cl->backend_decl;
252 /* We should never got substring references here. These will be
253 broken down by the scalarizer. */
259 gcc_assert (length != NULL);
264 /* For each character array constructor subexpression without a ts.u.cl->length,
265 replace it by its first element (if there aren't any elements, the length
266 should already be set to zero). */
269 flatten_array_ctors_without_strlen (gfc_expr* e)
271 gfc_actual_arglist* arg;
277 switch (e->expr_type)
281 flatten_array_ctors_without_strlen (e->value.op.op1);
282 flatten_array_ctors_without_strlen (e->value.op.op2);
286 /* TODO: Implement as with EXPR_FUNCTION when needed. */
290 for (arg = e->value.function.actual; arg; arg = arg->next)
291 flatten_array_ctors_without_strlen (arg->expr);
296 /* We've found what we're looking for. */
297 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
302 gcc_assert (e->value.constructor);
304 c = gfc_constructor_first (e->value.constructor);
308 flatten_array_ctors_without_strlen (new_expr);
309 gfc_replace_expr (e, new_expr);
313 /* Otherwise, fall through to handle constructor elements. */
315 for (c = gfc_constructor_first (e->value.constructor);
316 c; c = gfc_constructor_next (c))
317 flatten_array_ctors_without_strlen (c->expr);
327 /* Generate code to initialize a string length variable. Returns the
328 value. For array constructors, cl->length might be NULL and in this case,
329 the first element of the constructor is needed. expr is the original
330 expression so we can access it but can be NULL if this is not needed. */
333 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
337 gfc_init_se (&se, NULL);
341 && TREE_CODE (cl->backend_decl) == VAR_DECL)
344 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
345 "flatten" array constructors by taking their first element; all elements
346 should be the same length or a cl->length should be present. */
351 expr_flat = gfc_copy_expr (expr);
352 flatten_array_ctors_without_strlen (expr_flat);
353 gfc_resolve_expr (expr_flat);
355 gfc_conv_expr (&se, expr_flat);
356 gfc_add_block_to_block (pblock, &se.pre);
357 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
359 gfc_free_expr (expr_flat);
363 /* Convert cl->length. */
365 gcc_assert (cl->length);
367 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
368 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
369 se.expr, build_int_cst (gfc_charlen_type_node, 0));
370 gfc_add_block_to_block (pblock, &se.pre);
372 if (cl->backend_decl)
373 gfc_add_modify (pblock, cl->backend_decl, se.expr);
375 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
380 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
381 const char *name, locus *where)
390 type = gfc_get_character_type (kind, ref->u.ss.length);
391 type = build_pointer_type (type);
393 gfc_init_se (&start, se);
394 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
395 gfc_add_block_to_block (&se->pre, &start.pre);
397 if (integer_onep (start.expr))
398 gfc_conv_string_parameter (se);
403 /* Avoid multiple evaluation of substring start. */
404 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
405 start.expr = gfc_evaluate_now (start.expr, &se->pre);
407 /* Change the start of the string. */
408 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
411 tmp = build_fold_indirect_ref_loc (input_location,
413 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
414 se->expr = gfc_build_addr_expr (type, tmp);
417 /* Length = end + 1 - start. */
418 gfc_init_se (&end, se);
419 if (ref->u.ss.end == NULL)
420 end.expr = se->string_length;
423 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
424 gfc_add_block_to_block (&se->pre, &end.pre);
428 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
429 end.expr = gfc_evaluate_now (end.expr, &se->pre);
431 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
433 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
434 boolean_type_node, start.expr,
437 /* Check lower bound. */
438 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
440 build_int_cst (gfc_charlen_type_node, 1));
441 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
442 boolean_type_node, nonempty, fault);
444 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
445 "is less than one", name);
447 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
449 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
450 fold_convert (long_integer_type_node,
454 /* Check upper bound. */
455 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
456 end.expr, se->string_length);
457 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
458 boolean_type_node, nonempty, fault);
460 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
461 "exceeds string length (%%ld)", name);
463 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
464 "exceeds string length (%%ld)");
465 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
466 fold_convert (long_integer_type_node, end.expr),
467 fold_convert (long_integer_type_node,
472 /* If the start and end expressions are equal, the length is one. */
474 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
475 tmp = build_int_cst (gfc_charlen_type_node, 1);
478 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
479 end.expr, start.expr);
480 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
481 build_int_cst (gfc_charlen_type_node, 1), tmp);
482 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
483 tmp, build_int_cst (gfc_charlen_type_node, 0));
486 se->string_length = tmp;
490 /* Convert a derived type component reference. */
493 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
500 c = ref->u.c.component;
502 gcc_assert (c->backend_decl);
504 field = c->backend_decl;
505 gcc_assert (TREE_CODE (field) == FIELD_DECL);
507 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
508 decl, field, NULL_TREE);
512 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
514 tmp = c->ts.u.cl->backend_decl;
515 /* Components must always be constant length. */
516 gcc_assert (tmp && INTEGER_CST_P (tmp));
517 se->string_length = tmp;
520 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
521 && c->ts.type != BT_CHARACTER)
522 || c->attr.proc_pointer)
523 se->expr = build_fold_indirect_ref_loc (input_location,
528 /* This function deals with component references to components of the
529 parent type for derived type extensons. */
531 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
539 c = ref->u.c.component;
541 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
542 parent.type = REF_COMPONENT;
545 parent.u.c.component = dt->components;
547 if (dt->backend_decl == NULL)
548 gfc_get_derived_type (dt);
550 if (dt->attr.extension && dt->components)
552 if (dt->attr.is_class)
553 cmp = dt->components;
555 cmp = dt->components->next;
556 /* Return if the component is not in the parent type. */
557 for (; cmp; cmp = cmp->next)
558 if (strcmp (c->name, cmp->name) == 0)
561 /* Otherwise build the reference and call self. */
562 gfc_conv_component_ref (se, &parent);
563 parent.u.c.sym = dt->components->ts.u.derived;
564 parent.u.c.component = c;
565 conv_parent_component_references (se, &parent);
569 /* Return the contents of a variable. Also handles reference/pointer
570 variables (all Fortran pointer references are implicit). */
573 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
577 tree parent_decl = NULL_TREE;
580 bool alternate_entry;
583 sym = expr->symtree->n.sym;
586 /* Check that something hasn't gone horribly wrong. */
587 gcc_assert (se->ss != gfc_ss_terminator);
588 gcc_assert (se->ss->expr == expr);
590 /* A scalarized term. We already know the descriptor. */
591 se->expr = se->ss->data.info.descriptor;
592 se->string_length = se->ss->string_length;
593 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
594 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
599 tree se_expr = NULL_TREE;
601 se->expr = gfc_get_symbol_decl (sym);
603 /* Deal with references to a parent results or entries by storing
604 the current_function_decl and moving to the parent_decl. */
605 return_value = sym->attr.function && sym->result == sym;
606 alternate_entry = sym->attr.function && sym->attr.entry
607 && sym->result == sym;
608 entry_master = sym->attr.result
609 && sym->ns->proc_name->attr.entry_master
610 && !gfc_return_by_reference (sym->ns->proc_name);
611 if (current_function_decl)
612 parent_decl = DECL_CONTEXT (current_function_decl);
614 if ((se->expr == parent_decl && return_value)
615 || (sym->ns && sym->ns->proc_name
617 && sym->ns->proc_name->backend_decl == parent_decl
618 && (alternate_entry || entry_master)))
623 /* Special case for assigning the return value of a function.
624 Self recursive functions must have an explicit return value. */
625 if (return_value && (se->expr == current_function_decl || parent_flag))
626 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
628 /* Similarly for alternate entry points. */
629 else if (alternate_entry
630 && (sym->ns->proc_name->backend_decl == current_function_decl
633 gfc_entry_list *el = NULL;
635 for (el = sym->ns->entries; el; el = el->next)
638 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
643 else if (entry_master
644 && (sym->ns->proc_name->backend_decl == current_function_decl
646 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
651 /* Procedure actual arguments. */
652 else if (sym->attr.flavor == FL_PROCEDURE
653 && se->expr != current_function_decl)
655 if (!sym->attr.dummy && !sym->attr.proc_pointer)
657 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
658 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
664 /* Dereference the expression, where needed. Since characters
665 are entirely different from other types, they are treated
667 if (sym->ts.type == BT_CHARACTER)
669 /* Dereference character pointer dummy arguments
671 if ((sym->attr.pointer || sym->attr.allocatable)
673 || sym->attr.function
674 || sym->attr.result))
675 se->expr = build_fold_indirect_ref_loc (input_location,
679 else if (!sym->attr.value)
681 /* Dereference non-character scalar dummy arguments. */
682 if (sym->attr.dummy && !sym->attr.dimension)
683 se->expr = build_fold_indirect_ref_loc (input_location,
686 /* Dereference scalar hidden result. */
687 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
688 && (sym->attr.function || sym->attr.result)
689 && !sym->attr.dimension && !sym->attr.pointer
690 && !sym->attr.always_explicit)
691 se->expr = build_fold_indirect_ref_loc (input_location,
694 /* Dereference non-character pointer variables.
695 These must be dummies, results, or scalars. */
696 if ((sym->attr.pointer || sym->attr.allocatable
697 || gfc_is_associate_pointer (sym))
699 || sym->attr.function
701 || !sym->attr.dimension))
702 se->expr = build_fold_indirect_ref_loc (input_location,
709 /* For character variables, also get the length. */
710 if (sym->ts.type == BT_CHARACTER)
712 /* If the character length of an entry isn't set, get the length from
713 the master function instead. */
714 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
715 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
717 se->string_length = sym->ts.u.cl->backend_decl;
718 gcc_assert (se->string_length);
726 /* Return the descriptor if that's what we want and this is an array
727 section reference. */
728 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
730 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
731 /* Return the descriptor for array pointers and allocations. */
733 && ref->next == NULL && (se->descriptor_only))
736 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
737 /* Return a pointer to an element. */
741 if (ref->u.c.sym->attr.extension)
742 conv_parent_component_references (se, ref);
744 gfc_conv_component_ref (se, ref);
748 gfc_conv_substring (se, ref, expr->ts.kind,
749 expr->symtree->name, &expr->where);
758 /* Pointer assignment, allocation or pass by reference. Arrays are handled
760 if (se->want_pointer)
762 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
763 gfc_conv_string_parameter (se);
765 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
770 /* Unary ops are easy... Or they would be if ! was a valid op. */
773 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
778 gcc_assert (expr->ts.type != BT_CHARACTER);
779 /* Initialize the operand. */
780 gfc_init_se (&operand, se);
781 gfc_conv_expr_val (&operand, expr->value.op.op1);
782 gfc_add_block_to_block (&se->pre, &operand.pre);
784 type = gfc_typenode_for_spec (&expr->ts);
786 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
787 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
788 All other unary operators have an equivalent GIMPLE unary operator. */
789 if (code == TRUTH_NOT_EXPR)
790 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
791 build_int_cst (type, 0));
793 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
797 /* Expand power operator to optimal multiplications when a value is raised
798 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
799 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
800 Programming", 3rd Edition, 1998. */
802 /* This code is mostly duplicated from expand_powi in the backend.
803 We establish the "optimal power tree" lookup table with the defined size.
804 The items in the table are the exponents used to calculate the index
805 exponents. Any integer n less than the value can get an "addition chain",
806 with the first node being one. */
807 #define POWI_TABLE_SIZE 256
809 /* The table is from builtins.c. */
810 static const unsigned char powi_table[POWI_TABLE_SIZE] =
812 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
813 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
814 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
815 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
816 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
817 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
818 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
819 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
820 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
821 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
822 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
823 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
824 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
825 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
826 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
827 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
828 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
829 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
830 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
831 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
832 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
833 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
834 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
835 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
836 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
837 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
838 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
839 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
840 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
841 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
842 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
843 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
846 /* If n is larger than lookup table's max index, we use the "window
848 #define POWI_WINDOW_SIZE 3
850 /* Recursive function to expand the power operator. The temporary
851 values are put in tmpvar. The function returns tmpvar[1] ** n. */
853 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
860 if (n < POWI_TABLE_SIZE)
865 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
866 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
870 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
871 op0 = gfc_conv_powi (se, n - digit, tmpvar);
872 op1 = gfc_conv_powi (se, digit, tmpvar);
876 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
880 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
881 tmp = gfc_evaluate_now (tmp, &se->pre);
883 if (n < POWI_TABLE_SIZE)
890 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
891 return 1. Else return 0 and a call to runtime library functions
892 will have to be built. */
894 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
899 tree vartmp[POWI_TABLE_SIZE];
901 unsigned HOST_WIDE_INT n;
904 /* If exponent is too large, we won't expand it anyway, so don't bother
905 with large integer values. */
906 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
909 m = double_int_to_shwi (TREE_INT_CST (rhs));
910 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
911 of the asymmetric range of the integer type. */
912 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
914 type = TREE_TYPE (lhs);
915 sgn = tree_int_cst_sgn (rhs);
917 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
918 || optimize_size) && (m > 2 || m < -1))
924 se->expr = gfc_build_const (type, integer_one_node);
928 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
929 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
931 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
932 lhs, build_int_cst (TREE_TYPE (lhs), -1));
933 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
934 lhs, build_int_cst (TREE_TYPE (lhs), 1));
937 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
940 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
941 boolean_type_node, tmp, cond);
942 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
943 tmp, build_int_cst (type, 1),
944 build_int_cst (type, 0));
948 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
949 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
950 build_int_cst (type, -1),
951 build_int_cst (type, 0));
952 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
953 cond, build_int_cst (type, 1), tmp);
957 memset (vartmp, 0, sizeof (vartmp));
961 tmp = gfc_build_const (type, integer_one_node);
962 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
966 se->expr = gfc_conv_powi (se, n, vartmp);
972 /* Power op (**). Constant integer exponent has special handling. */
975 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
977 tree gfc_int4_type_node;
980 int res_ikind_1, res_ikind_2;
985 gfc_init_se (&lse, se);
986 gfc_conv_expr_val (&lse, expr->value.op.op1);
987 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
988 gfc_add_block_to_block (&se->pre, &lse.pre);
990 gfc_init_se (&rse, se);
991 gfc_conv_expr_val (&rse, expr->value.op.op2);
992 gfc_add_block_to_block (&se->pre, &rse.pre);
994 if (expr->value.op.op2->ts.type == BT_INTEGER
995 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
996 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
999 gfc_int4_type_node = gfc_get_int_type (4);
1001 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1002 library routine. But in the end, we have to convert the result back
1003 if this case applies -- with res_ikind_K, we keep track whether operand K
1004 falls into this case. */
1008 kind = expr->value.op.op1->ts.kind;
1009 switch (expr->value.op.op2->ts.type)
1012 ikind = expr->value.op.op2->ts.kind;
1017 rse.expr = convert (gfc_int4_type_node, rse.expr);
1018 res_ikind_2 = ikind;
1040 if (expr->value.op.op1->ts.type == BT_INTEGER)
1042 lse.expr = convert (gfc_int4_type_node, lse.expr);
1069 switch (expr->value.op.op1->ts.type)
1072 if (kind == 3) /* Case 16 was not handled properly above. */
1074 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1078 /* Use builtins for real ** int4. */
1084 fndecl = built_in_decls[BUILT_IN_POWIF];
1088 fndecl = built_in_decls[BUILT_IN_POWI];
1092 fndecl = built_in_decls[BUILT_IN_POWIL];
1096 /* Use the __builtin_powil() only if real(kind=16) is
1097 actually the C long double type. */
1098 if (!gfc_real16_is_float128)
1099 fndecl = built_in_decls[BUILT_IN_POWIL];
1107 /* If we don't have a good builtin for this, go for the
1108 library function. */
1110 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1114 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1123 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1127 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1135 se->expr = build_call_expr_loc (input_location,
1136 fndecl, 2, lse.expr, rse.expr);
1138 /* Convert the result back if it is of wrong integer kind. */
1139 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1141 /* We want the maximum of both operand kinds as result. */
1142 if (res_ikind_1 < res_ikind_2)
1143 res_ikind_1 = res_ikind_2;
1144 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1149 /* Generate code to allocate a string temporary. */
1152 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1157 if (gfc_can_put_var_on_stack (len))
1159 /* Create a temporary variable to hold the result. */
1160 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1161 gfc_charlen_type_node, len,
1162 build_int_cst (gfc_charlen_type_node, 1));
1163 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1165 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1166 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1168 tmp = build_array_type (TREE_TYPE (type), tmp);
1170 var = gfc_create_var (tmp, "str");
1171 var = gfc_build_addr_expr (type, var);
1175 /* Allocate a temporary to hold the result. */
1176 var = gfc_create_var (type, "pstr");
1177 tmp = gfc_call_malloc (&se->pre, type,
1178 fold_build2_loc (input_location, MULT_EXPR,
1179 TREE_TYPE (len), len,
1180 fold_convert (TREE_TYPE (len),
1181 TYPE_SIZE (type))));
1182 gfc_add_modify (&se->pre, var, tmp);
1184 /* Free the temporary afterwards. */
1185 tmp = gfc_call_free (convert (pvoid_type_node, var));
1186 gfc_add_expr_to_block (&se->post, tmp);
1193 /* Handle a string concatenation operation. A temporary will be allocated to
1197 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1200 tree len, type, var, tmp, fndecl;
1202 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1203 && expr->value.op.op2->ts.type == BT_CHARACTER);
1204 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1206 gfc_init_se (&lse, se);
1207 gfc_conv_expr (&lse, expr->value.op.op1);
1208 gfc_conv_string_parameter (&lse);
1209 gfc_init_se (&rse, se);
1210 gfc_conv_expr (&rse, expr->value.op.op2);
1211 gfc_conv_string_parameter (&rse);
1213 gfc_add_block_to_block (&se->pre, &lse.pre);
1214 gfc_add_block_to_block (&se->pre, &rse.pre);
1216 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1217 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1218 if (len == NULL_TREE)
1220 len = fold_build2_loc (input_location, PLUS_EXPR,
1221 TREE_TYPE (lse.string_length),
1222 lse.string_length, rse.string_length);
1225 type = build_pointer_type (type);
1227 var = gfc_conv_string_tmp (se, type, len);
1229 /* Do the actual concatenation. */
1230 if (expr->ts.kind == 1)
1231 fndecl = gfor_fndecl_concat_string;
1232 else if (expr->ts.kind == 4)
1233 fndecl = gfor_fndecl_concat_string_char4;
1237 tmp = build_call_expr_loc (input_location,
1238 fndecl, 6, len, var, lse.string_length, lse.expr,
1239 rse.string_length, rse.expr);
1240 gfc_add_expr_to_block (&se->pre, tmp);
1242 /* Add the cleanup for the operands. */
1243 gfc_add_block_to_block (&se->pre, &rse.post);
1244 gfc_add_block_to_block (&se->pre, &lse.post);
1247 se->string_length = len;
1250 /* Translates an op expression. Common (binary) cases are handled by this
1251 function, others are passed on. Recursion is used in either case.
1252 We use the fact that (op1.ts == op2.ts) (except for the power
1254 Operators need no special handling for scalarized expressions as long as
1255 they call gfc_conv_simple_val to get their operands.
1256 Character strings get special handling. */
1259 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1261 enum tree_code code;
1270 switch (expr->value.op.op)
1272 case INTRINSIC_PARENTHESES:
1273 if ((expr->ts.type == BT_REAL
1274 || expr->ts.type == BT_COMPLEX)
1275 && gfc_option.flag_protect_parens)
1277 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1278 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1283 case INTRINSIC_UPLUS:
1284 gfc_conv_expr (se, expr->value.op.op1);
1287 case INTRINSIC_UMINUS:
1288 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1292 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1295 case INTRINSIC_PLUS:
1299 case INTRINSIC_MINUS:
1303 case INTRINSIC_TIMES:
1307 case INTRINSIC_DIVIDE:
1308 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1309 an integer, we must round towards zero, so we use a
1311 if (expr->ts.type == BT_INTEGER)
1312 code = TRUNC_DIV_EXPR;
1317 case INTRINSIC_POWER:
1318 gfc_conv_power_op (se, expr);
1321 case INTRINSIC_CONCAT:
1322 gfc_conv_concat_op (se, expr);
1326 code = TRUTH_ANDIF_EXPR;
1331 code = TRUTH_ORIF_EXPR;
1335 /* EQV and NEQV only work on logicals, but since we represent them
1336 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1338 case INTRINSIC_EQ_OS:
1346 case INTRINSIC_NE_OS:
1347 case INTRINSIC_NEQV:
1354 case INTRINSIC_GT_OS:
1361 case INTRINSIC_GE_OS:
1368 case INTRINSIC_LT_OS:
1375 case INTRINSIC_LE_OS:
1381 case INTRINSIC_USER:
1382 case INTRINSIC_ASSIGN:
1383 /* These should be converted into function calls by the frontend. */
1387 fatal_error ("Unknown intrinsic op");
1391 /* The only exception to this is **, which is handled separately anyway. */
1392 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1394 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1398 gfc_init_se (&lse, se);
1399 gfc_conv_expr (&lse, expr->value.op.op1);
1400 gfc_add_block_to_block (&se->pre, &lse.pre);
1403 gfc_init_se (&rse, se);
1404 gfc_conv_expr (&rse, expr->value.op.op2);
1405 gfc_add_block_to_block (&se->pre, &rse.pre);
1409 gfc_conv_string_parameter (&lse);
1410 gfc_conv_string_parameter (&rse);
1412 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1413 rse.string_length, rse.expr,
1414 expr->value.op.op1->ts.kind,
1416 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1417 gfc_add_block_to_block (&lse.post, &rse.post);
1420 type = gfc_typenode_for_spec (&expr->ts);
1424 /* The result of logical ops is always boolean_type_node. */
1425 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1426 lse.expr, rse.expr);
1427 se->expr = convert (type, tmp);
1430 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1432 /* Add the post blocks. */
1433 gfc_add_block_to_block (&se->post, &rse.post);
1434 gfc_add_block_to_block (&se->post, &lse.post);
1437 /* If a string's length is one, we convert it to a single character. */
1440 gfc_string_to_single_character (tree len, tree str, int kind)
1443 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1444 || !POINTER_TYPE_P (TREE_TYPE (str)))
1447 if (TREE_INT_CST_LOW (len) == 1)
1449 str = fold_convert (gfc_get_pchar_type (kind), str);
1450 return build_fold_indirect_ref_loc (input_location, str);
1454 && TREE_CODE (str) == ADDR_EXPR
1455 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1456 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1457 && array_ref_low_bound (TREE_OPERAND (str, 0))
1458 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1459 && TREE_INT_CST_LOW (len) > 1
1460 && TREE_INT_CST_LOW (len)
1461 == (unsigned HOST_WIDE_INT)
1462 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1464 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1465 ret = build_fold_indirect_ref_loc (input_location, ret);
1466 if (TREE_CODE (ret) == INTEGER_CST)
1468 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1469 int i, length = TREE_STRING_LENGTH (string_cst);
1470 const char *ptr = TREE_STRING_POINTER (string_cst);
1472 for (i = 1; i < length; i++)
1485 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1488 if (sym->backend_decl)
1490 /* This becomes the nominal_type in
1491 function.c:assign_parm_find_data_types. */
1492 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1493 /* This becomes the passed_type in
1494 function.c:assign_parm_find_data_types. C promotes char to
1495 integer for argument passing. */
1496 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1498 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1503 /* If we have a constant character expression, make it into an
1505 if ((*expr)->expr_type == EXPR_CONSTANT)
1510 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1511 (int)(*expr)->value.character.string[0]);
1512 if ((*expr)->ts.kind != gfc_c_int_kind)
1514 /* The expr needs to be compatible with a C int. If the
1515 conversion fails, then the 2 causes an ICE. */
1516 ts.type = BT_INTEGER;
1517 ts.kind = gfc_c_int_kind;
1518 gfc_convert_type (*expr, &ts, 2);
1521 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1523 if ((*expr)->ref == NULL)
1525 se->expr = gfc_string_to_single_character
1526 (build_int_cst (integer_type_node, 1),
1527 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1529 ((*expr)->symtree->n.sym)),
1534 gfc_conv_variable (se, *expr);
1535 se->expr = gfc_string_to_single_character
1536 (build_int_cst (integer_type_node, 1),
1537 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1545 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1546 if STR is a string literal, otherwise return -1. */
1549 gfc_optimize_len_trim (tree len, tree str, int kind)
1552 && TREE_CODE (str) == ADDR_EXPR
1553 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1554 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1555 && array_ref_low_bound (TREE_OPERAND (str, 0))
1556 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1557 && TREE_INT_CST_LOW (len) >= 1
1558 && TREE_INT_CST_LOW (len)
1559 == (unsigned HOST_WIDE_INT)
1560 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1562 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1563 folded = build_fold_indirect_ref_loc (input_location, folded);
1564 if (TREE_CODE (folded) == INTEGER_CST)
1566 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1567 int length = TREE_STRING_LENGTH (string_cst);
1568 const char *ptr = TREE_STRING_POINTER (string_cst);
1570 for (; length > 0; length--)
1571 if (ptr[length - 1] != ' ')
1580 /* Compare two strings. If they are all single characters, the result is the
1581 subtraction of them. Otherwise, we build a library call. */
1584 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1585 enum tree_code code)
1591 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1592 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1594 sc1 = gfc_string_to_single_character (len1, str1, kind);
1595 sc2 = gfc_string_to_single_character (len2, str2, kind);
1597 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1599 /* Deal with single character specially. */
1600 sc1 = fold_convert (integer_type_node, sc1);
1601 sc2 = fold_convert (integer_type_node, sc2);
1602 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1606 if ((code == EQ_EXPR || code == NE_EXPR)
1608 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1610 /* If one string is a string literal with LEN_TRIM longer
1611 than the length of the second string, the strings
1613 int len = gfc_optimize_len_trim (len1, str1, kind);
1614 if (len > 0 && compare_tree_int (len2, len) < 0)
1615 return integer_one_node;
1616 len = gfc_optimize_len_trim (len2, str2, kind);
1617 if (len > 0 && compare_tree_int (len1, len) < 0)
1618 return integer_one_node;
1621 /* Build a call for the comparison. */
1623 fndecl = gfor_fndecl_compare_string;
1625 fndecl = gfor_fndecl_compare_string_char4;
1629 return build_call_expr_loc (input_location, fndecl, 4,
1630 len1, str1, len2, str2);
1634 /* Return the backend_decl for a procedure pointer component. */
1637 get_proc_ptr_comp (gfc_expr *e)
1643 gfc_init_se (&comp_se, NULL);
1644 e2 = gfc_copy_expr (e);
1645 /* We have to restore the expr type later so that gfc_free_expr frees
1646 the exact same thing that was allocated.
1647 TODO: This is ugly. */
1648 old_type = e2->expr_type;
1649 e2->expr_type = EXPR_VARIABLE;
1650 gfc_conv_expr (&comp_se, e2);
1651 e2->expr_type = old_type;
1653 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1658 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1662 if (gfc_is_proc_ptr_comp (expr, NULL))
1663 tmp = get_proc_ptr_comp (expr);
1664 else if (sym->attr.dummy)
1666 tmp = gfc_get_symbol_decl (sym);
1667 if (sym->attr.proc_pointer)
1668 tmp = build_fold_indirect_ref_loc (input_location,
1670 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1671 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1675 if (!sym->backend_decl)
1676 sym->backend_decl = gfc_get_extern_function_decl (sym);
1678 tmp = sym->backend_decl;
1680 if (sym->attr.cray_pointee)
1682 /* TODO - make the cray pointee a pointer to a procedure,
1683 assign the pointer to it and use it for the call. This
1685 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1686 gfc_get_symbol_decl (sym->cp_pointer));
1687 tmp = gfc_evaluate_now (tmp, &se->pre);
1690 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1692 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1693 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1700 /* Initialize MAPPING. */
1703 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1705 mapping->syms = NULL;
1706 mapping->charlens = NULL;
1710 /* Free all memory held by MAPPING (but not MAPPING itself). */
1713 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1715 gfc_interface_sym_mapping *sym;
1716 gfc_interface_sym_mapping *nextsym;
1718 gfc_charlen *nextcl;
1720 for (sym = mapping->syms; sym; sym = nextsym)
1722 nextsym = sym->next;
1723 sym->new_sym->n.sym->formal = NULL;
1724 gfc_free_symbol (sym->new_sym->n.sym);
1725 gfc_free_expr (sym->expr);
1726 gfc_free (sym->new_sym);
1729 for (cl = mapping->charlens; cl; cl = nextcl)
1732 gfc_free_expr (cl->length);
1738 /* Return a copy of gfc_charlen CL. Add the returned structure to
1739 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1741 static gfc_charlen *
1742 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1745 gfc_charlen *new_charlen;
1747 new_charlen = gfc_get_charlen ();
1748 new_charlen->next = mapping->charlens;
1749 new_charlen->length = gfc_copy_expr (cl->length);
1751 mapping->charlens = new_charlen;
1756 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1757 array variable that can be used as the actual argument for dummy
1758 argument SYM. Add any initialization code to BLOCK. PACKED is as
1759 for gfc_get_nodesc_array_type and DATA points to the first element
1760 in the passed array. */
1763 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1764 gfc_packed packed, tree data)
1769 type = gfc_typenode_for_spec (&sym->ts);
1770 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1771 !sym->attr.target && !sym->attr.pointer
1772 && !sym->attr.proc_pointer);
1774 var = gfc_create_var (type, "ifm");
1775 gfc_add_modify (block, var, fold_convert (type, data));
1781 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1782 and offset of descriptorless array type TYPE given that it has the same
1783 size as DESC. Add any set-up code to BLOCK. */
1786 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1793 offset = gfc_index_zero_node;
1794 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1796 dim = gfc_rank_cst[n];
1797 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1798 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1800 GFC_TYPE_ARRAY_LBOUND (type, n)
1801 = gfc_conv_descriptor_lbound_get (desc, dim);
1802 GFC_TYPE_ARRAY_UBOUND (type, n)
1803 = gfc_conv_descriptor_ubound_get (desc, dim);
1805 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1807 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1808 gfc_array_index_type,
1809 gfc_conv_descriptor_ubound_get (desc, dim),
1810 gfc_conv_descriptor_lbound_get (desc, dim));
1811 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1812 gfc_array_index_type,
1813 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1814 tmp = gfc_evaluate_now (tmp, block);
1815 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1817 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1818 GFC_TYPE_ARRAY_LBOUND (type, n),
1819 GFC_TYPE_ARRAY_STRIDE (type, n));
1820 offset = fold_build2_loc (input_location, MINUS_EXPR,
1821 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.contiguous = sym->attr.contiguous;
1852 new_sym->attr.codimension = sym->attr.codimension;
1853 new_sym->attr.pointer = sym->attr.pointer;
1854 new_sym->attr.allocatable = sym->attr.allocatable;
1855 new_sym->attr.flavor = sym->attr.flavor;
1856 new_sym->attr.function = sym->attr.function;
1858 /* Ensure that the interface is available and that
1859 descriptors are passed for array actual arguments. */
1860 if (sym->attr.flavor == FL_PROCEDURE)
1862 new_sym->formal = expr->symtree->n.sym->formal;
1863 new_sym->attr.always_explicit
1864 = expr->symtree->n.sym->attr.always_explicit;
1867 /* Create a fake symtree for it. */
1869 new_symtree = gfc_new_symtree (&root, sym->name);
1870 new_symtree->n.sym = new_sym;
1871 gcc_assert (new_symtree == root);
1873 /* Create a dummy->actual mapping. */
1874 sm = XCNEW (gfc_interface_sym_mapping);
1875 sm->next = mapping->syms;
1877 sm->new_sym = new_symtree;
1878 sm->expr = gfc_copy_expr (expr);
1881 /* Stabilize the argument's value. */
1882 if (!sym->attr.function && se)
1883 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1885 if (sym->ts.type == BT_CHARACTER)
1887 /* Create a copy of the dummy argument's length. */
1888 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1889 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1891 /* If the length is specified as "*", record the length that
1892 the caller is passing. We should use the callee's length
1893 in all other cases. */
1894 if (!new_sym->ts.u.cl->length && se)
1896 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1897 new_sym->ts.u.cl->backend_decl = se->string_length;
1904 /* Use the passed value as-is if the argument is a function. */
1905 if (sym->attr.flavor == FL_PROCEDURE)
1908 /* If the argument is either a string or a pointer to a string,
1909 convert it to a boundless character type. */
1910 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1912 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1913 tmp = build_pointer_type (tmp);
1914 if (sym->attr.pointer)
1915 value = build_fold_indirect_ref_loc (input_location,
1919 value = fold_convert (tmp, value);
1922 /* If the argument is a scalar, a pointer to an array or an allocatable,
1924 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1925 value = build_fold_indirect_ref_loc (input_location,
1928 /* For character(*), use the actual argument's descriptor. */
1929 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1930 value = build_fold_indirect_ref_loc (input_location,
1933 /* If the argument is an array descriptor, use it to determine
1934 information about the actual argument's shape. */
1935 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1936 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1938 /* Get the actual argument's descriptor. */
1939 desc = build_fold_indirect_ref_loc (input_location,
1942 /* Create the replacement variable. */
1943 tmp = gfc_conv_descriptor_data_get (desc);
1944 value = gfc_get_interface_mapping_array (&se->pre, sym,
1947 /* Use DESC to work out the upper bounds, strides and offset. */
1948 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1951 /* Otherwise we have a packed array. */
1952 value = gfc_get_interface_mapping_array (&se->pre, sym,
1953 PACKED_FULL, se->expr);
1955 new_sym->backend_decl = value;
1959 /* Called once all dummy argument mappings have been added to MAPPING,
1960 but before the mapping is used to evaluate expressions. Pre-evaluate
1961 the length of each argument, adding any initialization code to PRE and
1962 any finalization code to POST. */
1965 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1966 stmtblock_t * pre, stmtblock_t * post)
1968 gfc_interface_sym_mapping *sym;
1972 for (sym = mapping->syms; sym; sym = sym->next)
1973 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1974 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1976 expr = sym->new_sym->n.sym->ts.u.cl->length;
1977 gfc_apply_interface_mapping_to_expr (mapping, expr);
1978 gfc_init_se (&se, NULL);
1979 gfc_conv_expr (&se, expr);
1980 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1981 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1982 gfc_add_block_to_block (pre, &se.pre);
1983 gfc_add_block_to_block (post, &se.post);
1985 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1990 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1994 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1995 gfc_constructor_base base)
1998 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2000 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2003 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2004 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2005 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2011 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2015 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2020 for (; ref; ref = ref->next)
2024 for (n = 0; n < ref->u.ar.dimen; n++)
2026 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2027 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2028 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2030 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2037 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2038 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2044 /* Convert intrinsic function calls into result expressions. */
2047 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2055 arg1 = expr->value.function.actual->expr;
2056 if (expr->value.function.actual->next)
2057 arg2 = expr->value.function.actual->next->expr;
2061 sym = arg1->symtree->n.sym;
2063 if (sym->attr.dummy)
2068 switch (expr->value.function.isym->id)
2071 /* TODO figure out why this condition is necessary. */
2072 if (sym->attr.function
2073 && (arg1->ts.u.cl->length == NULL
2074 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2075 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2078 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2082 if (!sym->as || sym->as->rank == 0)
2085 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2087 dup = mpz_get_si (arg2->value.integer);
2092 dup = sym->as->rank;
2096 for (; d < dup; d++)
2100 if (!sym->as->upper[d] || !sym->as->lower[d])
2102 gfc_free_expr (new_expr);
2106 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2107 gfc_get_int_expr (gfc_default_integer_kind,
2109 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2111 new_expr = gfc_multiply (new_expr, tmp);
2117 case GFC_ISYM_LBOUND:
2118 case GFC_ISYM_UBOUND:
2119 /* TODO These implementations of lbound and ubound do not limit if
2120 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2122 if (!sym->as || sym->as->rank == 0)
2125 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2126 d = mpz_get_si (arg2->value.integer) - 1;
2128 /* TODO: If the need arises, this could produce an array of
2132 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2134 if (sym->as->lower[d])
2135 new_expr = gfc_copy_expr (sym->as->lower[d]);
2139 if (sym->as->upper[d])
2140 new_expr = gfc_copy_expr (sym->as->upper[d]);
2148 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2152 gfc_replace_expr (expr, new_expr);
2158 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2159 gfc_interface_mapping * mapping)
2161 gfc_formal_arglist *f;
2162 gfc_actual_arglist *actual;
2164 actual = expr->value.function.actual;
2165 f = map_expr->symtree->n.sym->formal;
2167 for (; f && actual; f = f->next, actual = actual->next)
2172 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2175 if (map_expr->symtree->n.sym->attr.dimension)
2180 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2182 for (d = 0; d < as->rank; d++)
2184 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2185 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2188 expr->value.function.esym->as = as;
2191 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2193 expr->value.function.esym->ts.u.cl->length
2194 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2196 gfc_apply_interface_mapping_to_expr (mapping,
2197 expr->value.function.esym->ts.u.cl->length);
2202 /* EXPR is a copy of an expression that appeared in the interface
2203 associated with MAPPING. Walk it recursively looking for references to
2204 dummy arguments that MAPPING maps to actual arguments. Replace each such
2205 reference with a reference to the associated actual argument. */
2208 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2211 gfc_interface_sym_mapping *sym;
2212 gfc_actual_arglist *actual;
2217 /* Copying an expression does not copy its length, so do that here. */
2218 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2220 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2221 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2224 /* Apply the mapping to any references. */
2225 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2227 /* ...and to the expression's symbol, if it has one. */
2228 /* TODO Find out why the condition on expr->symtree had to be moved into
2229 the loop rather than being outside it, as originally. */
2230 for (sym = mapping->syms; sym; sym = sym->next)
2231 if (expr->symtree && sym->old == expr->symtree->n.sym)
2233 if (sym->new_sym->n.sym->backend_decl)
2234 expr->symtree = sym->new_sym;
2236 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2239 /* ...and to subexpressions in expr->value. */
2240 switch (expr->expr_type)
2245 case EXPR_SUBSTRING:
2249 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2250 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2254 for (actual = expr->value.function.actual; actual; actual = actual->next)
2255 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2257 if (expr->value.function.esym == NULL
2258 && expr->value.function.isym != NULL
2259 && expr->value.function.actual->expr->symtree
2260 && gfc_map_intrinsic_function (expr, mapping))
2263 for (sym = mapping->syms; sym; sym = sym->next)
2264 if (sym->old == expr->value.function.esym)
2266 expr->value.function.esym = sym->new_sym->n.sym;
2267 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2268 expr->value.function.esym->result = sym->new_sym->n.sym;
2273 case EXPR_STRUCTURE:
2274 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2287 /* Evaluate interface expression EXPR using MAPPING. Store the result
2291 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2292 gfc_se * se, gfc_expr * expr)
2294 expr = gfc_copy_expr (expr);
2295 gfc_apply_interface_mapping_to_expr (mapping, expr);
2296 gfc_conv_expr (se, expr);
2297 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2298 gfc_free_expr (expr);
2302 /* Returns a reference to a temporary array into which a component of
2303 an actual argument derived type array is copied and then returned
2304 after the function call. */
2306 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2307 sym_intent intent, bool formal_ptr)
2325 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2327 gfc_init_se (&lse, NULL);
2328 gfc_init_se (&rse, NULL);
2330 /* Walk the argument expression. */
2331 rss = gfc_walk_expr (expr);
2333 gcc_assert (rss != gfc_ss_terminator);
2335 /* Initialize the scalarizer. */
2336 gfc_init_loopinfo (&loop);
2337 gfc_add_ss_to_loop (&loop, rss);
2339 /* Calculate the bounds of the scalarization. */
2340 gfc_conv_ss_startstride (&loop);
2342 /* Build an ss for the temporary. */
2343 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2344 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2346 base_type = gfc_typenode_for_spec (&expr->ts);
2347 if (GFC_ARRAY_TYPE_P (base_type)
2348 || GFC_DESCRIPTOR_TYPE_P (base_type))
2349 base_type = gfc_get_element_type (base_type);
2351 loop.temp_ss = gfc_get_ss ();;
2352 loop.temp_ss->type = GFC_SS_TEMP;
2353 loop.temp_ss->data.temp.type = base_type;
2355 if (expr->ts.type == BT_CHARACTER)
2356 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2358 loop.temp_ss->string_length = NULL;
2360 parmse->string_length = loop.temp_ss->string_length;
2361 loop.temp_ss->data.temp.dimen = loop.dimen;
2362 loop.temp_ss->next = gfc_ss_terminator;
2364 /* Associate the SS with the loop. */
2365 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2367 /* Setup the scalarizing loops. */
2368 gfc_conv_loop_setup (&loop, &expr->where);
2370 /* Pass the temporary descriptor back to the caller. */
2371 info = &loop.temp_ss->data.info;
2372 parmse->expr = info->descriptor;
2374 /* Setup the gfc_se structures. */
2375 gfc_copy_loopinfo_to_se (&lse, &loop);
2376 gfc_copy_loopinfo_to_se (&rse, &loop);
2379 lse.ss = loop.temp_ss;
2380 gfc_mark_ss_chain_used (rss, 1);
2381 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2383 /* Start the scalarized loop body. */
2384 gfc_start_scalarized_body (&loop, &body);
2386 /* Translate the expression. */
2387 gfc_conv_expr (&rse, expr);
2389 gfc_conv_tmp_array_ref (&lse);
2391 if (intent != INTENT_OUT)
2393 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2394 gfc_add_expr_to_block (&body, tmp);
2395 gcc_assert (rse.ss == gfc_ss_terminator);
2396 gfc_trans_scalarizing_loops (&loop, &body);
2400 /* Make sure that the temporary declaration survives by merging
2401 all the loop declarations into the current context. */
2402 for (n = 0; n < loop.dimen; n++)
2404 gfc_merge_block_scope (&body);
2405 body = loop.code[loop.order[n]];
2407 gfc_merge_block_scope (&body);
2410 /* Add the post block after the second loop, so that any
2411 freeing of allocated memory is done at the right time. */
2412 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2414 /**********Copy the temporary back again.*********/
2416 gfc_init_se (&lse, NULL);
2417 gfc_init_se (&rse, NULL);
2419 /* Walk the argument expression. */
2420 lss = gfc_walk_expr (expr);
2421 rse.ss = loop.temp_ss;
2424 /* Initialize the scalarizer. */
2425 gfc_init_loopinfo (&loop2);
2426 gfc_add_ss_to_loop (&loop2, lss);
2428 /* Calculate the bounds of the scalarization. */
2429 gfc_conv_ss_startstride (&loop2);
2431 /* Setup the scalarizing loops. */
2432 gfc_conv_loop_setup (&loop2, &expr->where);
2434 gfc_copy_loopinfo_to_se (&lse, &loop2);
2435 gfc_copy_loopinfo_to_se (&rse, &loop2);
2437 gfc_mark_ss_chain_used (lss, 1);
2438 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2440 /* Declare the variable to hold the temporary offset and start the
2441 scalarized loop body. */
2442 offset = gfc_create_var (gfc_array_index_type, NULL);
2443 gfc_start_scalarized_body (&loop2, &body);
2445 /* Build the offsets for the temporary from the loop variables. The
2446 temporary array has lbounds of zero and strides of one in all
2447 dimensions, so this is very simple. The offset is only computed
2448 outside the innermost loop, so the overall transfer could be
2449 optimized further. */
2450 info = &rse.ss->data.info;
2451 dimen = info->dimen;
2453 tmp_index = gfc_index_zero_node;
2454 for (n = dimen - 1; n > 0; n--)
2457 tmp = rse.loop->loopvar[n];
2458 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2459 tmp, rse.loop->from[n]);
2460 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2463 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2464 gfc_array_index_type,
2465 rse.loop->to[n-1], rse.loop->from[n-1]);
2466 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2467 gfc_array_index_type,
2468 tmp_str, gfc_index_one_node);
2470 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2471 gfc_array_index_type, tmp, tmp_str);
2474 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2475 gfc_array_index_type,
2476 tmp_index, rse.loop->from[0]);
2477 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2479 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2480 gfc_array_index_type,
2481 rse.loop->loopvar[0], offset);
2483 /* Now use the offset for the reference. */
2484 tmp = build_fold_indirect_ref_loc (input_location,
2486 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2488 if (expr->ts.type == BT_CHARACTER)
2489 rse.string_length = expr->ts.u.cl->backend_decl;
2491 gfc_conv_expr (&lse, expr);
2493 gcc_assert (lse.ss == gfc_ss_terminator);
2495 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2496 gfc_add_expr_to_block (&body, tmp);
2498 /* Generate the copying loops. */
2499 gfc_trans_scalarizing_loops (&loop2, &body);
2501 /* Wrap the whole thing up by adding the second loop to the post-block
2502 and following it by the post-block of the first loop. In this way,
2503 if the temporary needs freeing, it is done after use! */
2504 if (intent != INTENT_IN)
2506 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2507 gfc_add_block_to_block (&parmse->post, &loop2.post);
2510 gfc_add_block_to_block (&parmse->post, &loop.post);
2512 gfc_cleanup_loop (&loop);
2513 gfc_cleanup_loop (&loop2);
2515 /* Pass the string length to the argument expression. */
2516 if (expr->ts.type == BT_CHARACTER)
2517 parmse->string_length = expr->ts.u.cl->backend_decl;
2519 /* Determine the offset for pointer formal arguments and set the
2523 size = gfc_index_one_node;
2524 offset = gfc_index_zero_node;
2525 for (n = 0; n < dimen; n++)
2527 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2529 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2530 gfc_array_index_type, tmp,
2531 gfc_index_one_node);
2532 gfc_conv_descriptor_ubound_set (&parmse->pre,
2536 gfc_conv_descriptor_lbound_set (&parmse->pre,
2539 gfc_index_one_node);
2540 size = gfc_evaluate_now (size, &parmse->pre);
2541 offset = fold_build2_loc (input_location, MINUS_EXPR,
2542 gfc_array_index_type,
2544 offset = gfc_evaluate_now (offset, &parmse->pre);
2545 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2546 gfc_array_index_type,
2547 rse.loop->to[n], rse.loop->from[n]);
2548 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2549 gfc_array_index_type,
2550 tmp, gfc_index_one_node);
2551 size = fold_build2_loc (input_location, MULT_EXPR,
2552 gfc_array_index_type, size, tmp);
2555 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2559 /* We want either the address for the data or the address of the descriptor,
2560 depending on the mode of passing array arguments. */
2562 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2564 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2570 /* Generate the code for argument list functions. */
2573 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2575 /* Pass by value for g77 %VAL(arg), pass the address
2576 indirectly for %LOC, else by reference. Thus %REF
2577 is a "do-nothing" and %LOC is the same as an F95
2579 if (strncmp (name, "%VAL", 4) == 0)
2580 gfc_conv_expr (se, expr);
2581 else if (strncmp (name, "%LOC", 4) == 0)
2583 gfc_conv_expr_reference (se, expr);
2584 se->expr = gfc_build_addr_expr (NULL, se->expr);
2586 else if (strncmp (name, "%REF", 4) == 0)
2587 gfc_conv_expr_reference (se, expr);
2589 gfc_error ("Unknown argument list function at %L", &expr->where);
2593 /* Takes a derived type expression and returns the address of a temporary
2594 class object of the 'declared' type. */
2596 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2597 gfc_typespec class_ts)
2601 gfc_symbol *declared = class_ts.u.derived;
2607 /* The derived type needs to be converted to a temporary
2609 tmp = gfc_typenode_for_spec (&class_ts);
2610 var = gfc_create_var (tmp, "class");
2613 cmp = gfc_find_component (declared, "_vptr", true, true);
2614 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2615 TREE_TYPE (cmp->backend_decl),
2616 var, cmp->backend_decl, NULL_TREE);
2618 /* Remember the vtab corresponds to the derived type
2619 not to the class declared type. */
2620 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2622 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2623 gfc_add_modify (&parmse->pre, ctree,
2624 fold_convert (TREE_TYPE (ctree), tmp));
2626 /* Now set the data field. */
2627 cmp = gfc_find_component (declared, "_data", true, true);
2628 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2629 TREE_TYPE (cmp->backend_decl),
2630 var, cmp->backend_decl, NULL_TREE);
2631 ss = gfc_walk_expr (e);
2632 if (ss == gfc_ss_terminator)
2635 gfc_conv_expr_reference (parmse, e);
2636 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2637 gfc_add_modify (&parmse->pre, ctree, tmp);
2642 gfc_conv_expr (parmse, e);
2643 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2646 /* Pass the address of the class object. */
2647 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2651 /* The following routine generates code for the intrinsic
2652 procedures from the ISO_C_BINDING module:
2654 * C_FUNLOC (function)
2655 * C_F_POINTER (subroutine)
2656 * C_F_PROCPOINTER (subroutine)
2657 * C_ASSOCIATED (function)
2658 One exception which is not handled here is C_F_POINTER with non-scalar
2659 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2662 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2663 gfc_actual_arglist * arg)
2668 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2670 if (arg->expr->rank == 0)
2671 gfc_conv_expr_reference (se, arg->expr);
2675 /* This is really the actual arg because no formal arglist is
2676 created for C_LOC. */
2677 fsym = arg->expr->symtree->n.sym;
2679 /* We should want it to do g77 calling convention. */
2681 && !(fsym->attr.pointer || fsym->attr.allocatable)
2682 && fsym->as->type != AS_ASSUMED_SHAPE;
2683 f = f || !sym->attr.always_explicit;
2685 argss = gfc_walk_expr (arg->expr);
2686 gfc_conv_array_parameter (se, arg->expr, argss, f,
2690 /* TODO -- the following two lines shouldn't be necessary, but if
2691 they're removed, a bug is exposed later in the code path.
2692 This workaround was thus introduced, but will have to be
2693 removed; please see PR 35150 for details about the issue. */
2694 se->expr = convert (pvoid_type_node, se->expr);
2695 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2699 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2701 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2702 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2703 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2704 gfc_conv_expr_reference (se, arg->expr);
2708 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2709 && arg->next->expr->rank == 0)
2710 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2712 /* Convert c_f_pointer if fptr is a scalar
2713 and convert c_f_procpointer. */
2717 gfc_init_se (&cptrse, NULL);
2718 gfc_conv_expr (&cptrse, arg->expr);
2719 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2720 gfc_add_block_to_block (&se->post, &cptrse.post);
2722 gfc_init_se (&fptrse, NULL);
2723 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2724 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2725 fptrse.want_pointer = 1;
2727 gfc_conv_expr (&fptrse, arg->next->expr);
2728 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2729 gfc_add_block_to_block (&se->post, &fptrse.post);
2731 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2732 && arg->next->expr->symtree->n.sym->attr.dummy)
2733 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2736 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2737 TREE_TYPE (fptrse.expr),
2739 fold_convert (TREE_TYPE (fptrse.expr),
2744 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2749 /* Build the addr_expr for the first argument. The argument is
2750 already an *address* so we don't need to set want_pointer in
2752 gfc_init_se (&arg1se, NULL);
2753 gfc_conv_expr (&arg1se, arg->expr);
2754 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2755 gfc_add_block_to_block (&se->post, &arg1se.post);
2757 /* See if we were given two arguments. */
2758 if (arg->next == NULL)
2759 /* Only given one arg so generate a null and do a
2760 not-equal comparison against the first arg. */
2761 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2763 fold_convert (TREE_TYPE (arg1se.expr),
2764 null_pointer_node));
2770 /* Given two arguments so build the arg2se from second arg. */
2771 gfc_init_se (&arg2se, NULL);
2772 gfc_conv_expr (&arg2se, arg->next->expr);
2773 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2774 gfc_add_block_to_block (&se->post, &arg2se.post);
2776 /* Generate test to compare that the two args are equal. */
2777 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2778 arg1se.expr, arg2se.expr);
2779 /* Generate test to ensure that the first arg is not null. */
2780 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2782 arg1se.expr, null_pointer_node);
2784 /* Finally, the generated test must check that both arg1 is not
2785 NULL and that it is equal to the second arg. */
2786 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2788 not_null_expr, eq_expr);
2794 /* Nothing was done. */
2798 /* Generate code for a procedure call. Note can return se->post != NULL.
2799 If se->direct_byref is set then se->expr contains the return parameter.
2800 Return nonzero, if the call has alternate specifiers.
2801 'expr' is only needed for procedure pointer components. */
2804 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2805 gfc_actual_arglist * args, gfc_expr * expr,
2806 VEC(tree,gc) *append_args)
2808 gfc_interface_mapping mapping;
2809 VEC(tree,gc) *arglist;
2810 VEC(tree,gc) *retargs;
2821 VEC(tree,gc) *stringargs;
2823 gfc_formal_arglist *formal;
2824 gfc_actual_arglist *arg;
2825 int has_alternate_specifier = 0;
2826 bool need_interface_mapping;
2833 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2834 gfc_component *comp = NULL;
2844 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2845 && conv_isocbinding_procedure (se, sym, args))
2848 gfc_is_proc_ptr_comp (expr, &comp);
2852 if (!sym->attr.elemental)
2854 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2855 if (se->ss->useflags)
2857 gcc_assert ((!comp && gfc_return_by_reference (sym)
2858 && sym->result->attr.dimension)
2859 || (comp && comp->attr.dimension));
2860 gcc_assert (se->loop != NULL);
2862 /* Access the previously obtained result. */
2863 gfc_conv_tmp_array_ref (se);
2867 info = &se->ss->data.info;
2872 gfc_init_block (&post);
2873 gfc_init_interface_mapping (&mapping);
2876 formal = sym->formal;
2877 need_interface_mapping = sym->attr.dimension ||
2878 (sym->ts.type == BT_CHARACTER
2879 && sym->ts.u.cl->length
2880 && sym->ts.u.cl->length->expr_type
2885 formal = comp->formal;
2886 need_interface_mapping = comp->attr.dimension ||
2887 (comp->ts.type == BT_CHARACTER
2888 && comp->ts.u.cl->length
2889 && comp->ts.u.cl->length->expr_type
2893 /* Evaluate the arguments. */
2894 for (arg = args; arg != NULL;
2895 arg = arg->next, formal = formal ? formal->next : NULL)
2898 fsym = formal ? formal->sym : NULL;
2899 parm_kind = MISSING;
2903 if (se->ignore_optional)
2905 /* Some intrinsics have already been resolved to the correct
2909 else if (arg->label)
2911 has_alternate_specifier = 1;
2916 /* Pass a NULL pointer for an absent arg. */
2917 gfc_init_se (&parmse, NULL);
2918 parmse.expr = null_pointer_node;
2919 if (arg->missing_arg_type == BT_CHARACTER)
2920 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2923 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2925 /* Pass a NULL pointer to denote an absent arg. */
2926 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2927 gfc_init_se (&parmse, NULL);
2928 parmse.expr = null_pointer_node;
2929 if (arg->missing_arg_type == BT_CHARACTER)
2930 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2932 else if (fsym && fsym->ts.type == BT_CLASS
2933 && e->ts.type == BT_DERIVED)
2935 /* The derived type needs to be converted to a temporary
2937 gfc_init_se (&parmse, se);
2938 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2940 else if (se->ss && se->ss->useflags)
2942 /* An elemental function inside a scalarized loop. */
2943 gfc_init_se (&parmse, se);
2944 gfc_conv_expr_reference (&parmse, e);
2945 parm_kind = ELEMENTAL;
2949 /* A scalar or transformational function. */
2950 gfc_init_se (&parmse, NULL);
2951 argss = gfc_walk_expr (e);
2953 if (argss == gfc_ss_terminator)
2955 if (e->expr_type == EXPR_VARIABLE
2956 && e->symtree->n.sym->attr.cray_pointee
2957 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2959 /* The Cray pointer needs to be converted to a pointer to
2960 a type given by the expression. */
2961 gfc_conv_expr (&parmse, e);
2962 type = build_pointer_type (TREE_TYPE (parmse.expr));
2963 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2964 parmse.expr = convert (type, tmp);
2966 else if (fsym && fsym->attr.value)
2968 if (fsym->ts.type == BT_CHARACTER
2969 && fsym->ts.is_c_interop
2970 && fsym->ns->proc_name != NULL
2971 && fsym->ns->proc_name->attr.is_bind_c)
2974 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2975 if (parmse.expr == NULL)
2976 gfc_conv_expr (&parmse, e);
2979 gfc_conv_expr (&parmse, e);
2981 else if (arg->name && arg->name[0] == '%')
2982 /* Argument list functions %VAL, %LOC and %REF are signalled
2983 through arg->name. */
2984 conv_arglist_function (&parmse, arg->expr, arg->name);
2985 else if ((e->expr_type == EXPR_FUNCTION)
2986 && ((e->value.function.esym
2987 && e->value.function.esym->result->attr.pointer)
2988 || (!e->value.function.esym
2989 && e->symtree->n.sym->attr.pointer))
2990 && fsym && fsym->attr.target)
2992 gfc_conv_expr (&parmse, e);
2993 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2995 else if (e->expr_type == EXPR_FUNCTION
2996 && e->symtree->n.sym->result
2997 && e->symtree->n.sym->result != e->symtree->n.sym
2998 && e->symtree->n.sym->result->attr.proc_pointer)
3000 /* Functions returning procedure pointers. */
3001 gfc_conv_expr (&parmse, e);
3002 if (fsym && fsym->attr.proc_pointer)
3003 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3007 gfc_conv_expr_reference (&parmse, e);
3009 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3010 allocated on entry, it must be deallocated. */
3011 if (fsym && fsym->attr.allocatable
3012 && fsym->attr.intent == INTENT_OUT)
3016 gfc_init_block (&block);
3017 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3019 gfc_add_expr_to_block (&block, tmp);
3020 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3021 void_type_node, parmse.expr,
3023 gfc_add_expr_to_block (&block, tmp);
3025 if (fsym->attr.optional
3026 && e->expr_type == EXPR_VARIABLE
3027 && e->symtree->n.sym->attr.optional)
3029 tmp = fold_build3_loc (input_location, COND_EXPR,
3031 gfc_conv_expr_present (e->symtree->n.sym),
3032 gfc_finish_block (&block),
3033 build_empty_stmt (input_location));
3036 tmp = gfc_finish_block (&block);
3038 gfc_add_expr_to_block (&se->pre, tmp);
3041 if (fsym && e->expr_type != EXPR_NULL
3042 && ((fsym->attr.pointer
3043 && fsym->attr.flavor != FL_PROCEDURE)
3044 || (fsym->attr.proc_pointer
3045 && !(e->expr_type == EXPR_VARIABLE
3046 && e->symtree->n.sym->attr.dummy))
3047 || (fsym->attr.proc_pointer
3048 && e->expr_type == EXPR_VARIABLE
3049 && gfc_is_proc_ptr_comp (e, NULL))
3050 || fsym->attr.allocatable))
3052 /* Scalar pointer dummy args require an extra level of
3053 indirection. The null pointer already contains
3054 this level of indirection. */
3055 parm_kind = SCALAR_POINTER;
3056 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3062 /* If the procedure requires an explicit interface, the actual
3063 argument is passed according to the corresponding formal
3064 argument. If the corresponding formal argument is a POINTER,
3065 ALLOCATABLE or assumed shape, we do not use g77's calling
3066 convention, and pass the address of the array descriptor
3067 instead. Otherwise we use g77's calling convention. */
3070 && !(fsym->attr.pointer || fsym->attr.allocatable)
3071 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3073 f = f || !comp->attr.always_explicit;
3075 f = f || !sym->attr.always_explicit;
3077 /* If the argument is a function call that may not create
3078 a temporary for the result, we have to check that we
3079 can do it, i.e. that there is no alias between this
3080 argument and another one. */
3081 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3087 intent = fsym->attr.intent;
3089 intent = INTENT_UNKNOWN;
3091 if (gfc_check_fncall_dependency (e, intent, sym, args,
3093 parmse.force_tmp = 1;
3095 iarg = e->value.function.actual->expr;
3097 /* Temporary needed if aliasing due to host association. */
3098 if (sym->attr.contained
3100 && !sym->attr.implicit_pure
3101 && !sym->attr.use_assoc
3102 && iarg->expr_type == EXPR_VARIABLE
3103 && sym->ns == iarg->symtree->n.sym->ns)
3104 parmse.force_tmp = 1;
3106 /* Ditto within module. */
3107 if (sym->attr.use_assoc
3109 && !sym->attr.implicit_pure
3110 && iarg->expr_type == EXPR_VARIABLE
3111 && sym->module == iarg->symtree->n.sym->module)
3112 parmse.force_tmp = 1;
3115 if (e->expr_type == EXPR_VARIABLE
3116 && is_subref_array (e))
3117 /* The actual argument is a component reference to an
3118 array of derived types. In this case, the argument
3119 is converted to a temporary, which is passed and then
3120 written back after the procedure call. */
3121 gfc_conv_subref_array_arg (&parmse, e, f,
3122 fsym ? fsym->attr.intent : INTENT_INOUT,
3123 fsym && fsym->attr.pointer);
3125 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3128 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3129 allocated on entry, it must be deallocated. */
3130 if (fsym && fsym->attr.allocatable
3131 && fsym->attr.intent == INTENT_OUT)
3133 tmp = build_fold_indirect_ref_loc (input_location,
3135 tmp = gfc_trans_dealloc_allocated (tmp);
3136 if (fsym->attr.optional
3137 && e->expr_type == EXPR_VARIABLE
3138 && e->symtree->n.sym->attr.optional)
3139 tmp = fold_build3_loc (input_location, COND_EXPR,
3141 gfc_conv_expr_present (e->symtree->n.sym),
3142 tmp, build_empty_stmt (input_location));
3143 gfc_add_expr_to_block (&se->pre, tmp);
3148 /* The case with fsym->attr.optional is that of a user subroutine
3149 with an interface indicating an optional argument. When we call
3150 an intrinsic subroutine, however, fsym is NULL, but we might still
3151 have an optional argument, so we proceed to the substitution
3153 if (e && (fsym == NULL || fsym->attr.optional))
3155 /* If an optional argument is itself an optional dummy argument,
3156 check its presence and substitute a null if absent. This is
3157 only needed when passing an array to an elemental procedure
3158 as then array elements are accessed - or no NULL pointer is
3159 allowed and a "1" or "0" should be passed if not present.
3160 When passing a non-array-descriptor full array to a
3161 non-array-descriptor dummy, no check is needed. For
3162 array-descriptor actual to array-descriptor dummy, see
3163 PR 41911 for why a check has to be inserted.
3164 fsym == NULL is checked as intrinsics required the descriptor
3165 but do not always set fsym. */
3166 if (e->expr_type == EXPR_VARIABLE
3167 && e->symtree->n.sym->attr.optional
3168 && ((e->rank > 0 && sym->attr.elemental)
3169 || e->representation.length || e->ts.type == BT_CHARACTER
3173 && (fsym->as->type == AS_ASSUMED_SHAPE
3174 || fsym->as->type == AS_DEFERRED))))))
3175 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3176 e->representation.length);
3181 /* Obtain the character length of an assumed character length
3182 length procedure from the typespec. */
3183 if (fsym->ts.type == BT_CHARACTER
3184 && parmse.string_length == NULL_TREE
3185 && e->ts.type == BT_PROCEDURE
3186 && e->symtree->n.sym->ts.type == BT_CHARACTER
3187 && e->symtree->n.sym->ts.u.cl->length != NULL
3188 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3190 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3191 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3195 if (fsym && need_interface_mapping && e)
3196 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3198 gfc_add_block_to_block (&se->pre, &parmse.pre);
3199 gfc_add_block_to_block (&post, &parmse.post);
3201 /* Allocated allocatable components of derived types must be
3202 deallocated for non-variable scalars. Non-variable arrays are
3203 dealt with in trans-array.c(gfc_conv_array_parameter). */
3204 if (e && e->ts.type == BT_DERIVED
3205 && e->ts.u.derived->attr.alloc_comp
3206 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3207 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3210 tmp = build_fold_indirect_ref_loc (input_location,
3212 parm_rank = e->rank;
3220 case (SCALAR_POINTER):
3221 tmp = build_fold_indirect_ref_loc (input_location,
3226 if (e->expr_type == EXPR_OP
3227 && e->value.op.op == INTRINSIC_PARENTHESES
3228 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3231 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3232 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3233 gfc_add_expr_to_block (&se->post, local_tmp);
3236 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3238 gfc_add_expr_to_block (&se->post, tmp);
3241 /* Add argument checking of passing an unallocated/NULL actual to
3242 a nonallocatable/nonpointer dummy. */
3244 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3246 symbol_attribute attr;
3250 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3251 attr = gfc_expr_attr (e);
3253 goto end_pointer_check;
3257 /* If the actual argument is an optional pointer/allocatable and
3258 the formal argument takes an nonpointer optional value,
3259 it is invalid to pass a non-present argument on, even
3260 though there is no technical reason for this in gfortran.
3261 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3262 tree present, null_ptr, type;
3264 if (attr.allocatable
3265 && (fsym == NULL || !fsym->attr.allocatable))
3266 asprintf (&msg, "Allocatable actual argument '%s' is not "
3267 "allocated or not present", e->symtree->n.sym->name);
3268 else if (attr.pointer
3269 && (fsym == NULL || !fsym->attr.pointer))
3270 asprintf (&msg, "Pointer actual argument '%s' is not "
3271 "associated or not present",
3272 e->symtree->n.sym->name);
3273 else if (attr.proc_pointer
3274 && (fsym == NULL || !fsym->attr.proc_pointer))
3275 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3276 "associated or not present",
3277 e->symtree->n.sym->name);
3279 goto end_pointer_check;
3281 present = gfc_conv_expr_present (e->symtree->n.sym);
3282 type = TREE_TYPE (present);
3283 present = fold_build2_loc (input_location, EQ_EXPR,
3284 boolean_type_node, present,
3286 null_pointer_node));
3287 type = TREE_TYPE (parmse.expr);
3288 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3289 boolean_type_node, parmse.expr,
3291 null_pointer_node));
3292 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3293 boolean_type_node, present, null_ptr);
3297 if (attr.allocatable
3298 && (fsym == NULL || !fsym->attr.allocatable))
3299 asprintf (&msg, "Allocatable actual argument '%s' is not "
3300 "allocated", e->symtree->n.sym->name);
3301 else if (attr.pointer
3302 && (fsym == NULL || !fsym->attr.pointer))
3303 asprintf (&msg, "Pointer actual argument '%s' is not "
3304 "associated", e->symtree->n.sym->name);
3305 else if (attr.proc_pointer
3306 && (fsym == NULL || !fsym->attr.proc_pointer))
3307 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3308 "associated", e->symtree->n.sym->name);
3310 goto end_pointer_check;
3313 cond = fold_build2_loc (input_location, EQ_EXPR,
3314 boolean_type_node, parmse.expr,
3315 fold_convert (TREE_TYPE (parmse.expr),
3316 null_pointer_node));
3319 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3325 /* Deferred length dummies pass the character length by reference
3326 so that the value can be returned. */
3327 if (parmse.string_length && fsym && fsym->ts.deferred)
3329 tmp = parmse.string_length;
3330 if (TREE_CODE (tmp) != VAR_DECL)
3331 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3332 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
3335 /* Character strings are passed as two parameters, a length and a
3336 pointer - except for Bind(c) which only passes the pointer. */
3337 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3338 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3340 VEC_safe_push (tree, gc, arglist, parmse.expr);
3342 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3349 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3350 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3351 else if (ts.type == BT_CHARACTER)
3353 if (ts.u.cl->length == NULL)
3355 /* Assumed character length results are not allowed by 5.1.1.5 of the
3356 standard and are trapped in resolve.c; except in the case of SPREAD
3357 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3358 we take the character length of the first argument for the result.
3359 For dummies, we have to look through the formal argument list for
3360 this function and use the character length found there.*/
3361 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
3362 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
3363 else if (!sym->attr.dummy)
3364 cl.backend_decl = VEC_index (tree, stringargs, 0);
3367 formal = sym->ns->proc_name->formal;
3368 for (; formal; formal = formal->next)
3369 if (strcmp (formal->sym->name, sym->name) == 0)
3370 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3377 /* Calculate the length of the returned string. */
3378 gfc_init_se (&parmse, NULL);
3379 if (need_interface_mapping)
3380 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3382 gfc_conv_expr (&parmse, ts.u.cl->length);
3383 gfc_add_block_to_block (&se->pre, &parmse.pre);
3384 gfc_add_block_to_block (&se->post, &parmse.post);
3386 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3387 tmp = fold_build2_loc (input_location, MAX_EXPR,
3388 gfc_charlen_type_node, tmp,
3389 build_int_cst (gfc_charlen_type_node, 0));
3390 cl.backend_decl = tmp;
3393 /* Set up a charlen structure for it. */
3398 len = cl.backend_decl;
3401 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3402 || (!comp && gfc_return_by_reference (sym));
3405 if (se->direct_byref)
3407 /* Sometimes, too much indirection can be applied; e.g. for
3408 function_result = array_valued_recursive_function. */
3409 if (TREE_TYPE (TREE_TYPE (se->expr))
3410 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3411 && GFC_DESCRIPTOR_TYPE_P
3412 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3413 se->expr = build_fold_indirect_ref_loc (input_location,
3416 /* If the lhs of an assignment x = f(..) is allocatable and
3417 f2003 is allowed, we must do the automatic reallocation.
3418 TODO - deal with intrinsics, without using a temporary. */
3419 if (gfc_option.flag_realloc_lhs
3420 && se->ss && se->ss->loop_chain
3421 && se->ss->loop_chain->is_alloc_lhs
3422 && !expr->value.function.isym
3423 && sym->result->as != NULL)
3425 /* Evaluate the bounds of the result, if known. */
3426 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3429 /* Perform the automatic reallocation. */
3430 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3432 gfc_add_expr_to_block (&se->pre, tmp);
3434 /* Pass the temporary as the first argument. */
3435 result = info->descriptor;
3438 result = build_fold_indirect_ref_loc (input_location,
3440 VEC_safe_push (tree, gc, retargs, se->expr);
3442 else if (comp && comp->attr.dimension)
3444 gcc_assert (se->loop && info);
3446 /* Set the type of the array. */
3447 tmp = gfc_typenode_for_spec (&comp->ts);
3448 info->dimen = se->loop->dimen;
3450 /* Evaluate the bounds of the result, if known. */
3451 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3453 /* If the lhs of an assignment x = f(..) is allocatable and
3454 f2003 is allowed, we must not generate the function call
3455 here but should just send back the results of the mapping.
3456 This is signalled by the function ss being flagged. */
3457 if (gfc_option.flag_realloc_lhs
3458 && se->ss && se->ss->is_alloc_lhs)
3460 gfc_free_interface_mapping (&mapping);
3461 return has_alternate_specifier;
3464 /* Create a temporary to store the result. In case the function
3465 returns a pointer, the temporary will be a shallow copy and
3466 mustn't be deallocated. */
3467 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3468 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3469 NULL_TREE, false, !comp->attr.pointer,
3470 callee_alloc, &se->ss->expr->where);
3472 /* Pass the temporary as the first argument. */
3473 result = info->descriptor;
3474 tmp = gfc_build_addr_expr (NULL_TREE, result);
3475 VEC_safe_push (tree, gc, retargs, tmp);
3477 else if (!comp && sym->result->attr.dimension)
3479 gcc_assert (se->loop && info);
3481 /* Set the type of the array. */
3482 tmp = gfc_typenode_for_spec (&ts);
3483 info->dimen = se->loop->dimen;
3485 /* Evaluate the bounds of the result, if known. */
3486 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3488 /* If the lhs of an assignment x = f(..) is allocatable and
3489 f2003 is allowed, we must not generate the function call
3490 here but should just send back the results of the mapping.
3491 This is signalled by the function ss being flagged. */
3492 if (gfc_option.flag_realloc_lhs
3493 && se->ss && se->ss->is_alloc_lhs)
3495 gfc_free_interface_mapping (&mapping);
3496 return has_alternate_specifier;
3499 /* Create a temporary to store the result. In case the function
3500 returns a pointer, the temporary will be a shallow copy and
3501 mustn't be deallocated. */
3502 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3503 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3504 NULL_TREE, false, !sym->attr.pointer,
3505 callee_alloc, &se->ss->expr->where);
3507 /* Pass the temporary as the first argument. */
3508 result = info->descriptor;
3509 tmp = gfc_build_addr_expr (NULL_TREE, result);
3510 VEC_safe_push (tree, gc, retargs, tmp);
3512 else if (ts.type == BT_CHARACTER)
3514 /* Pass the string length. */
3515 type = gfc_get_character_type (ts.kind, ts.u.cl);
3516 type = build_pointer_type (type);
3518 /* Return an address to a char[0:len-1]* temporary for
3519 character pointers. */
3520 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3521 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3523 var = gfc_create_var (type, "pstr");
3525 if ((!comp && sym->attr.allocatable)
3526 || (comp && comp->attr.allocatable))
3527 gfc_add_modify (&se->pre, var,
3528 fold_convert (TREE_TYPE (var),
3529 null_pointer_node));
3531 /* Provide an address expression for the function arguments. */
3532 var = gfc_build_addr_expr (NULL_TREE, var);
3535 var = gfc_conv_string_tmp (se, type, len);
3537 VEC_safe_push (tree, gc, retargs, var);
3541 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3543 type = gfc_get_complex_type (ts.kind);
3544 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3545 VEC_safe_push (tree, gc, retargs, var);
3548 if (ts.type == BT_CHARACTER && ts.deferred
3549 && (sym->attr.allocatable || sym->attr.pointer))
3552 if (TREE_CODE (tmp) != VAR_DECL)
3553 tmp = gfc_evaluate_now (len, &se->pre);
3554 len = gfc_build_addr_expr (NULL_TREE, tmp);
3557 /* Add the string length to the argument list. */
3558 if (ts.type == BT_CHARACTER)
3559 VEC_safe_push (tree, gc, retargs, len);
3561 gfc_free_interface_mapping (&mapping);
3563 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3564 arglen = (VEC_length (tree, arglist)
3565 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3566 VEC_reserve_exact (tree, gc, retargs, arglen);
3568 /* Add the return arguments. */
3569 VEC_splice (tree, retargs, arglist);
3571 /* Add the hidden string length parameters to the arguments. */
3572 VEC_splice (tree, retargs, stringargs);
3574 /* We may want to append extra arguments here. This is used e.g. for
3575 calls to libgfortran_matmul_??, which need extra information. */
3576 if (!VEC_empty (tree, append_args))
3577 VEC_splice (tree, retargs, append_args);
3580 /* Generate the actual call. */
3581 conv_function_val (se, sym, expr);
3583 /* If there are alternate return labels, function type should be
3584 integer. Can't modify the type in place though, since it can be shared
3585 with other functions. For dummy arguments, the typing is done to
3586 to this result, even if it has to be repeated for each call. */
3587 if (has_alternate_specifier
3588 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3590 if (!sym->attr.dummy)
3592 TREE_TYPE (sym->backend_decl)
3593 = build_function_type (integer_type_node,
3594 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3595 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3598 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3601 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3602 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3604 /* If we have a pointer function, but we don't want a pointer, e.g.
3607 where f is pointer valued, we have to dereference the result. */
3608 if (!se->want_pointer && !byref
3609 && (sym->attr.pointer || sym->attr.allocatable)
3610 && !gfc_is_proc_ptr_comp (expr, NULL))
3611 se->expr = build_fold_indirect_ref_loc (input_location,
3614 /* f2c calling conventions require a scalar default real function to
3615 return a double precision result. Convert this back to default
3616 real. We only care about the cases that can happen in Fortran 77.
3618 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3619 && sym->ts.kind == gfc_default_real_kind
3620 && !sym->attr.always_explicit)
3621 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3623 /* A pure function may still have side-effects - it may modify its
3625 TREE_SIDE_EFFECTS (se->expr) = 1;
3627 if (!sym->attr.pure)
3628 TREE_SIDE_EFFECTS (se->expr) = 1;
3633 /* Add the function call to the pre chain. There is no expression. */
3634 gfc_add_expr_to_block (&se->pre, se->expr);
3635 se->expr = NULL_TREE;
3637 if (!se->direct_byref)
3639 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3641 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3643 /* Check the data pointer hasn't been modified. This would
3644 happen in a function returning a pointer. */
3645 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3646 tmp = fold_build2_loc (input_location, NE_EXPR,
3649 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3652 se->expr = info->descriptor;
3653 /* Bundle in the string length. */
3654 se->string_length = len;
3656 else if (ts.type == BT_CHARACTER)
3658 /* Dereference for character pointer results. */
3659 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3660 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3661 se->expr = build_fold_indirect_ref_loc (input_location, var);
3666 se->string_length = len;
3667 else if (sym->attr.allocatable || sym->attr.pointer)
3668 se->string_length = cl.backend_decl;
3672 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3673 se->expr = build_fold_indirect_ref_loc (input_location, var);
3678 /* Follow the function call with the argument post block. */
3681 gfc_add_block_to_block (&se->pre, &post);
3683 /* Transformational functions of derived types with allocatable
3684 components must have the result allocatable components copied. */
3685 arg = expr->value.function.actual;
3686 if (result && arg && expr->rank
3687 && expr->value.function.isym
3688 && expr->value.function.isym->transformational
3689 && arg->expr->ts.type == BT_DERIVED
3690 && arg->expr->ts.u.derived->attr.alloc_comp)
3693 /* Copy the allocatable components. We have to use a
3694 temporary here to prevent source allocatable components
3695 from being corrupted. */
3696 tmp2 = gfc_evaluate_now (result, &se->pre);
3697 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3698 result, tmp2, expr->rank);
3699 gfc_add_expr_to_block (&se->pre, tmp);
3700 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3702 gfc_add_expr_to_block (&se->pre, tmp);
3704 /* Finally free the temporary's data field. */
3705 tmp = gfc_conv_descriptor_data_get (tmp2);
3706 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3707 gfc_add_expr_to_block (&se->pre, tmp);
3711 gfc_add_block_to_block (&se->post, &post);
3713 return has_alternate_specifier;
3717 /* Fill a character string with spaces. */
3720 fill_with_spaces (tree start, tree type, tree size)
3722 stmtblock_t block, loop;
3723 tree i, el, exit_label, cond, tmp;
3725 /* For a simple char type, we can call memset(). */
3726 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3727 return build_call_expr_loc (input_location,
3728 built_in_decls[BUILT_IN_MEMSET], 3, start,
3729 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3730 lang_hooks.to_target_charset (' ')),
3733 /* Otherwise, we use a loop:
3734 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3738 /* Initialize variables. */
3739 gfc_init_block (&block);
3740 i = gfc_create_var (sizetype, "i");
3741 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3742 el = gfc_create_var (build_pointer_type (type), "el");
3743 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3744 exit_label = gfc_build_label_decl (NULL_TREE);
3745 TREE_USED (exit_label) = 1;
3749 gfc_init_block (&loop);
3751 /* Exit condition. */
3752 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3753 build_zero_cst (sizetype));
3754 tmp = build1_v (GOTO_EXPR, exit_label);
3755 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3756 build_empty_stmt (input_location));
3757 gfc_add_expr_to_block (&loop, tmp);
3760 gfc_add_modify (&loop,
3761 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3762 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3764 /* Increment loop variables. */
3765 gfc_add_modify (&loop, i,
3766 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3767 TYPE_SIZE_UNIT (type)));
3768 gfc_add_modify (&loop, el,
3769 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3770 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3772 /* Making the loop... actually loop! */
3773 tmp = gfc_finish_block (&loop);
3774 tmp = build1_v (LOOP_EXPR, tmp);
3775 gfc_add_expr_to_block (&block, tmp);
3777 /* The exit label. */
3778 tmp = build1_v (LABEL_EXPR, exit_label);
3779 gfc_add_expr_to_block (&block, tmp);
3782 return gfc_finish_block (&block);
3786 /* Generate code to copy a string. */
3789 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3790 int dkind, tree slength, tree src, int skind)
3792 tree tmp, dlen, slen;
3801 stmtblock_t tempblock;
3803 gcc_assert (dkind == skind);
3805 if (slength != NULL_TREE)
3807 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3808 ssc = gfc_string_to_single_character (slen, src, skind);
3812 slen = build_int_cst (size_type_node, 1);
3816 if (dlength != NULL_TREE)
3818 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3819 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3823 dlen = build_int_cst (size_type_node, 1);
3827 /* Assign directly if the types are compatible. */
3828 if (dsc != NULL_TREE && ssc != NULL_TREE
3829 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3831 gfc_add_modify (block, dsc, ssc);
3835 /* Do nothing if the destination length is zero. */
3836 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3837 build_int_cst (size_type_node, 0));
3839 /* The following code was previously in _gfortran_copy_string:
3841 // The two strings may overlap so we use memmove.
3843 copy_string (GFC_INTEGER_4 destlen, char * dest,
3844 GFC_INTEGER_4 srclen, const char * src)
3846 if (srclen >= destlen)
3848 // This will truncate if too long.
3849 memmove (dest, src, destlen);
3853 memmove (dest, src, srclen);
3855 memset (&dest[srclen], ' ', destlen - srclen);
3859 We're now doing it here for better optimization, but the logic
3862 /* For non-default character kinds, we have to multiply the string
3863 length by the base type size. */
3864 chartype = gfc_get_char_type (dkind);
3865 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3866 fold_convert (size_type_node, slen),
3867 fold_convert (size_type_node,
3868 TYPE_SIZE_UNIT (chartype)));
3869 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3870 fold_convert (size_type_node, dlen),
3871 fold_convert (size_type_node,
3872 TYPE_SIZE_UNIT (chartype)));
3874 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
3875 dest = fold_convert (pvoid_type_node, dest);
3877 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3879 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
3880 src = fold_convert (pvoid_type_node, src);
3882 src = gfc_build_addr_expr (pvoid_type_node, src);
3884 /* Truncate string if source is too long. */
3885 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3887 tmp2 = build_call_expr_loc (input_location,
3888 built_in_decls[BUILT_IN_MEMMOVE],
3889 3, dest, src, dlen);
3891 /* Else copy and pad with spaces. */
3892 tmp3 = build_call_expr_loc (input_location,
3893 built_in_decls[BUILT_IN_MEMMOVE],
3894 3, dest, src, slen);
3896 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3897 dest, fold_convert (sizetype, slen));
3898 tmp4 = fill_with_spaces (tmp4, chartype,
3899 fold_build2_loc (input_location, MINUS_EXPR,
3900 TREE_TYPE(dlen), dlen, slen));
3902 gfc_init_block (&tempblock);
3903 gfc_add_expr_to_block (&tempblock, tmp3);
3904 gfc_add_expr_to_block (&tempblock, tmp4);
3905 tmp3 = gfc_finish_block (&tempblock);
3907 /* The whole copy_string function is there. */
3908 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3910 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3911 build_empty_stmt (input_location));
3912 gfc_add_expr_to_block (block, tmp);
3916 /* Translate a statement function.
3917 The value of a statement function reference is obtained by evaluating the
3918 expression using the values of the actual arguments for the values of the
3919 corresponding dummy arguments. */
3922 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3926 gfc_formal_arglist *fargs;
3927 gfc_actual_arglist *args;
3930 gfc_saved_var *saved_vars;
3936 sym = expr->symtree->n.sym;
3937 args = expr->value.function.actual;
3938 gfc_init_se (&lse, NULL);
3939 gfc_init_se (&rse, NULL);
3942 for (fargs = sym->formal; fargs; fargs = fargs->next)
3944 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3945 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3947 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3949 /* Each dummy shall be specified, explicitly or implicitly, to be
3951 gcc_assert (fargs->sym->attr.dimension == 0);
3954 if (fsym->ts.type == BT_CHARACTER)
3956 /* Copy string arguments. */
3959 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3960 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3962 /* Create a temporary to hold the value. */
3963 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3964 fsym->ts.u.cl->backend_decl
3965 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3967 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3968 temp_vars[n] = gfc_create_var (type, fsym->name);
3970 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3972 gfc_conv_expr (&rse, args->expr);
3973 gfc_conv_string_parameter (&rse);
3974 gfc_add_block_to_block (&se->pre, &lse.pre);
3975 gfc_add_block_to_block (&se->pre, &rse.pre);
3977 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
3978 rse.string_length, rse.expr, fsym->ts.kind);
3979 gfc_add_block_to_block (&se->pre, &lse.post);
3980 gfc_add_block_to_block (&se->pre, &rse.post);
3984 /* For everything else, just evaluate the expression. */
3986 /* Create a temporary to hold the value. */
3987 type = gfc_typenode_for_spec (&fsym->ts);
3988 temp_vars[n] = gfc_create_var (type, fsym->name);
3990 gfc_conv_expr (&lse, args->expr);
3992 gfc_add_block_to_block (&se->pre, &lse.pre);
3993 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3994 gfc_add_block_to_block (&se->pre, &lse.post);
4000 /* Use the temporary variables in place of the real ones. */
4001 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4002 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4004 gfc_conv_expr (se, sym->value);
4006 if (sym->ts.type == BT_CHARACTER)
4008 gfc_conv_const_charlen (sym->ts.u.cl);
4010 /* Force the expression to the correct length. */
4011 if (!INTEGER_CST_P (se->string_length)
4012 || tree_int_cst_lt (se->string_length,
4013 sym->ts.u.cl->backend_decl))
4015 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4016 tmp = gfc_create_var (type, sym->name);
4017 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4018 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4019 sym->ts.kind, se->string_length, se->expr,
4023 se->string_length = sym->ts.u.cl->backend_decl;
4026 /* Restore the original variables. */
4027 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4028 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4029 gfc_free (saved_vars);
4033 /* Translate a function expression. */
4036 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4040 if (expr->value.function.isym)
4042 gfc_conv_intrinsic_function (se, expr);
4046 /* We distinguish statement functions from general functions to improve
4047 runtime performance. */
4048 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4050 gfc_conv_statement_function (se, expr);
4054 /* expr.value.function.esym is the resolved (specific) function symbol for
4055 most functions. However this isn't set for dummy procedures. */
4056 sym = expr->value.function.esym;
4058 sym = expr->symtree->n.sym;
4060 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4064 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4067 is_zero_initializer_p (gfc_expr * expr)
4069 if (expr->expr_type != EXPR_CONSTANT)
4072 /* We ignore constants with prescribed memory representations for now. */
4073 if (expr->representation.string)
4076 switch (expr->ts.type)
4079 return mpz_cmp_si (expr->value.integer, 0) == 0;
4082 return mpfr_zero_p (expr->value.real)
4083 && MPFR_SIGN (expr->value.real) >= 0;
4086 return expr->value.logical == 0;
4089 return mpfr_zero_p (mpc_realref (expr->value.complex))
4090 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4091 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4092 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4102 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4104 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4105 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4107 gfc_conv_tmp_array_ref (se);
4111 /* Build a static initializer. EXPR is the expression for the initial value.
4112 The other parameters describe the variable of the component being
4113 initialized. EXPR may be null. */
4116 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4117 bool array, bool pointer, bool procptr)
4121 if (!(expr || pointer || procptr))
4124 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4125 (these are the only two iso_c_binding derived types that can be
4126 used as initialization expressions). If so, we need to modify
4127 the 'expr' to be that for a (void *). */
4128 if (expr != NULL && expr->ts.type == BT_DERIVED
4129 && expr->ts.is_iso_c && expr->ts.u.derived)
4131 gfc_symbol *derived = expr->ts.u.derived;
4133 /* The derived symbol has already been converted to a (void *). Use
4135 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4136 expr->ts.f90_type = derived->ts.f90_type;
4138 gfc_init_se (&se, NULL);
4139 gfc_conv_constant (&se, expr);
4140 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4144 if (array && !procptr)
4147 /* Arrays need special handling. */
4149 ctor = gfc_build_null_descriptor (type);
4150 /* Special case assigning an array to zero. */
4151 else if (is_zero_initializer_p (expr))
4152 ctor = build_constructor (type, NULL);
4154 ctor = gfc_conv_array_initializer (type, expr);
4155 TREE_STATIC (ctor) = 1;
4158 else if (pointer || procptr)
4160 if (!expr || expr->expr_type == EXPR_NULL)
4161 return fold_convert (type, null_pointer_node);
4164 gfc_init_se (&se, NULL);
4165 se.want_pointer = 1;
4166 gfc_conv_expr (&se, expr);
4167 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4177 gfc_init_se (&se, NULL);
4178 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4179 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4181 gfc_conv_structure (&se, expr, 1);
4182 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4183 TREE_STATIC (se.expr) = 1;
4188 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4189 TREE_STATIC (ctor) = 1;
4194 gfc_init_se (&se, NULL);
4195 gfc_conv_constant (&se, expr);
4196 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4203 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4215 gfc_start_block (&block);
4217 /* Initialize the scalarizer. */
4218 gfc_init_loopinfo (&loop);
4220 gfc_init_se (&lse, NULL);
4221 gfc_init_se (&rse, NULL);
4224 rss = gfc_walk_expr (expr);
4225 if (rss == gfc_ss_terminator)
4227 /* The rhs is scalar. Add a ss for the expression. */
4228 rss = gfc_get_ss ();
4229 rss->next = gfc_ss_terminator;
4230 rss->type = GFC_SS_SCALAR;
4234 /* Create a SS for the destination. */
4235 lss = gfc_get_ss ();
4236 lss->type = GFC_SS_COMPONENT;
4238 lss->shape = gfc_get_shape (cm->as->rank);
4239 lss->next = gfc_ss_terminator;
4240 lss->data.info.dimen = cm->as->rank;
4241 lss->data.info.descriptor = dest;
4242 lss->data.info.data = gfc_conv_array_data (dest);
4243 lss->data.info.offset = gfc_conv_array_offset (dest);
4244 for (n = 0; n < cm->as->rank; n++)
4246 lss->data.info.dim[n] = n;
4247 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4248 lss->data.info.stride[n] = gfc_index_one_node;
4250 mpz_init (lss->shape[n]);
4251 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4252 cm->as->lower[n]->value.integer);
4253 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4256 /* Associate the SS with the loop. */
4257 gfc_add_ss_to_loop (&loop, lss);
4258 gfc_add_ss_to_loop (&loop, rss);
4260 /* Calculate the bounds of the scalarization. */
4261 gfc_conv_ss_startstride (&loop);
4263 /* Setup the scalarizing loops. */
4264 gfc_conv_loop_setup (&loop, &expr->where);
4266 /* Setup the gfc_se structures. */
4267 gfc_copy_loopinfo_to_se (&lse, &loop);
4268 gfc_copy_loopinfo_to_se (&rse, &loop);
4271 gfc_mark_ss_chain_used (rss, 1);
4273 gfc_mark_ss_chain_used (lss, 1);
4275 /* Start the scalarized loop body. */
4276 gfc_start_scalarized_body (&loop, &body);
4278 gfc_conv_tmp_array_ref (&lse);
4279 if (cm->ts.type == BT_CHARACTER)
4280 lse.string_length = cm->ts.u.cl->backend_decl;
4282 gfc_conv_expr (&rse, expr);
4284 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4285 gfc_add_expr_to_block (&body, tmp);
4287 gcc_assert (rse.ss == gfc_ss_terminator);
4289 /* Generate the copying loops. */
4290 gfc_trans_scalarizing_loops (&loop, &body);
4292 /* Wrap the whole thing up. */
4293 gfc_add_block_to_block (&block, &loop.pre);
4294 gfc_add_block_to_block (&block, &loop.post);
4296 for (n = 0; n < cm->as->rank; n++)
4297 mpz_clear (lss->shape[n]);
4298 gfc_free (lss->shape);
4300 gfc_cleanup_loop (&loop);
4302 return gfc_finish_block (&block);
4307 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4318 gfc_expr *arg = NULL;
4320 gfc_start_block (&block);
4321 gfc_init_se (&se, NULL);
4323 /* Get the descriptor for the expressions. */
4324 rss = gfc_walk_expr (expr);
4325 se.want_pointer = 0;
4326 gfc_conv_expr_descriptor (&se, expr, rss);
4327 gfc_add_block_to_block (&block, &se.pre);
4328 gfc_add_modify (&block, dest, se.expr);
4330 /* Deal with arrays of derived types with allocatable components. */
4331 if (cm->ts.type == BT_DERIVED
4332 && cm->ts.u.derived->attr.alloc_comp)
4333 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4337 tmp = gfc_duplicate_allocatable (dest, se.expr,
4338 TREE_TYPE(cm->backend_decl),
4341 gfc_add_expr_to_block (&block, tmp);
4342 gfc_add_block_to_block (&block, &se.post);
4344 if (expr->expr_type != EXPR_VARIABLE)
4345 gfc_conv_descriptor_data_set (&block, se.expr,
4348 /* We need to know if the argument of a conversion function is a
4349 variable, so that the correct lower bound can be used. */
4350 if (expr->expr_type == EXPR_FUNCTION
4351 && expr->value.function.isym
4352 && expr->value.function.isym->conversion
4353 && expr->value.function.actual->expr
4354 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4355 arg = expr->value.function.actual->expr;
4357 /* Obtain the array spec of full array references. */
4359 as = gfc_get_full_arrayspec_from_expr (arg);
4361 as = gfc_get_full_arrayspec_from_expr (expr);
4363 /* Shift the lbound and ubound of temporaries to being unity,
4364 rather than zero, based. Always calculate the offset. */
4365 offset = gfc_conv_descriptor_offset_get (dest);
4366 gfc_add_modify (&block, offset, gfc_index_zero_node);
4367 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4369 for (n = 0; n < expr->rank; n++)
4374 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4375 TODO It looks as if gfc_conv_expr_descriptor should return
4376 the correct bounds and that the following should not be
4377 necessary. This would simplify gfc_conv_intrinsic_bound
4379 if (as && as->lower[n])
4382 gfc_init_se (&lbse, NULL);
4383 gfc_conv_expr (&lbse, as->lower[n]);
4384 gfc_add_block_to_block (&block, &lbse.pre);
4385 lbound = gfc_evaluate_now (lbse.expr, &block);
4389 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4390 lbound = gfc_conv_descriptor_lbound_get (tmp,
4394 lbound = gfc_conv_descriptor_lbound_get (dest,
4397 lbound = gfc_index_one_node;
4399 lbound = fold_convert (gfc_array_index_type, lbound);
4401 /* Shift the bounds and set the offset accordingly. */
4402 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4403 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4404 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4405 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4407 gfc_conv_descriptor_ubound_set (&block, dest,
4408 gfc_rank_cst[n], tmp);
4409 gfc_conv_descriptor_lbound_set (&block, dest,
4410 gfc_rank_cst[n], lbound);
4412 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4413 gfc_conv_descriptor_lbound_get (dest,
4415 gfc_conv_descriptor_stride_get (dest,
4417 gfc_add_modify (&block, tmp2, tmp);
4418 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4420 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4425 /* If a conversion expression has a null data pointer
4426 argument, nullify the allocatable component. */
4430 if (arg->symtree->n.sym->attr.allocatable
4431 || arg->symtree->n.sym->attr.pointer)
4433 non_null_expr = gfc_finish_block (&block);
4434 gfc_start_block (&block);
4435 gfc_conv_descriptor_data_set (&block, dest,
4437 null_expr = gfc_finish_block (&block);
4438 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4439 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4440 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4441 return build3_v (COND_EXPR, tmp,
4442 null_expr, non_null_expr);
4446 return gfc_finish_block (&block);
4450 /* Assign a single component of a derived type constructor. */
4453 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4461 gfc_start_block (&block);
4463 if (cm->attr.pointer)
4465 gfc_init_se (&se, NULL);
4466 /* Pointer component. */
4467 if (cm->attr.dimension)
4469 /* Array pointer. */
4470 if (expr->expr_type == EXPR_NULL)
4471 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4474 rss = gfc_walk_expr (expr);
4475 se.direct_byref = 1;
4477 gfc_conv_expr_descriptor (&se, expr, rss);
4478 gfc_add_block_to_block (&block, &se.pre);
4479 gfc_add_block_to_block (&block, &se.post);
4484 /* Scalar pointers. */
4485 se.want_pointer = 1;
4486 gfc_conv_expr (&se, expr);
4487 gfc_add_block_to_block (&block, &se.pre);
4488 gfc_add_modify (&block, dest,
4489 fold_convert (TREE_TYPE (dest), se.expr));
4490 gfc_add_block_to_block (&block, &se.post);
4493 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4495 /* NULL initialization for CLASS components. */
4496 tmp = gfc_trans_structure_assign (dest,
4497 gfc_class_null_initializer (&cm->ts));
4498 gfc_add_expr_to_block (&block, tmp);
4500 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4502 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4503 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4504 else if (cm->attr.allocatable)
4506 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4507 gfc_add_expr_to_block (&block, tmp);
4511 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4512 gfc_add_expr_to_block (&block, tmp);
4515 else if (expr->ts.type == BT_DERIVED)
4517 if (expr->expr_type != EXPR_STRUCTURE)
4519 gfc_init_se (&se, NULL);
4520 gfc_conv_expr (&se, expr);
4521 gfc_add_block_to_block (&block, &se.pre);
4522 gfc_add_modify (&block, dest,
4523 fold_convert (TREE_TYPE (dest), se.expr));
4524 gfc_add_block_to_block (&block, &se.post);
4528 /* Nested constructors. */
4529 tmp = gfc_trans_structure_assign (dest, expr);
4530 gfc_add_expr_to_block (&block, tmp);
4535 /* Scalar component. */
4536 gfc_init_se (&se, NULL);
4537 gfc_init_se (&lse, NULL);
4539 gfc_conv_expr (&se, expr);
4540 if (cm->ts.type == BT_CHARACTER)
4541 lse.string_length = cm->ts.u.cl->backend_decl;
4543 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4544 gfc_add_expr_to_block (&block, tmp);
4546 return gfc_finish_block (&block);
4549 /* Assign a derived type constructor to a variable. */
4552 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4560 gfc_start_block (&block);
4561 cm = expr->ts.u.derived->components;
4563 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4564 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4565 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4569 gcc_assert (cm->backend_decl == NULL);
4570 gfc_init_se (&se, NULL);
4571 gfc_init_se (&lse, NULL);
4572 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4574 gfc_add_modify (&block, lse.expr,
4575 fold_convert (TREE_TYPE (lse.expr), se.expr));
4577 return gfc_finish_block (&block);
4580 for (c = gfc_constructor_first (expr->value.constructor);
4581 c; c = gfc_constructor_next (c), cm = cm->next)
4583 /* Skip absent members in default initializers. */
4587 field = cm->backend_decl;
4588 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4589 dest, field, NULL_TREE);
4590 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4591 gfc_add_expr_to_block (&block, tmp);
4593 return gfc_finish_block (&block);
4596 /* Build an expression for a constructor. If init is nonzero then
4597 this is part of a static variable initializer. */
4600 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4607 VEC(constructor_elt,gc) *v = NULL;
4609 gcc_assert (se->ss == NULL);
4610 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4611 type = gfc_typenode_for_spec (&expr->ts);
4615 /* Create a temporary variable and fill it in. */
4616 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4617 tmp = gfc_trans_structure_assign (se->expr, expr);
4618 gfc_add_expr_to_block (&se->pre, tmp);
4622 cm = expr->ts.u.derived->components;
4624 for (c = gfc_constructor_first (expr->value.constructor);
4625 c; c = gfc_constructor_next (c), cm = cm->next)
4627 /* Skip absent members in default initializers and allocatable
4628 components. Although the latter have a default initializer
4629 of EXPR_NULL,... by default, the static nullify is not needed
4630 since this is done every time we come into scope. */
4631 if (!c->expr || cm->attr.allocatable)
4634 if (strcmp (cm->name, "_size") == 0)
4636 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4637 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4639 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4640 && strcmp (cm->name, "_extends") == 0)
4644 vtabs = cm->initializer->symtree->n.sym;
4645 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4646 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4650 val = gfc_conv_initializer (c->expr, &cm->ts,
4651 TREE_TYPE (cm->backend_decl),
4652 cm->attr.dimension, cm->attr.pointer,
4653 cm->attr.proc_pointer);
4655 /* Append it to the constructor list. */
4656 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4659 se->expr = build_constructor (type, v);
4661 TREE_CONSTANT (se->expr) = 1;
4665 /* Translate a substring expression. */
4668 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4674 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4676 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4677 expr->value.character.length,
4678 expr->value.character.string);
4680 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4681 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4684 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4688 /* Entry point for expression translation. Evaluates a scalar quantity.
4689 EXPR is the expression to be translated, and SE is the state structure if
4690 called from within the scalarized. */
4693 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4695 if (se->ss && se->ss->expr == expr
4696 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4698 /* Substitute a scalar expression evaluated outside the scalarization
4700 se->expr = se->ss->data.scalar.expr;
4701 if (se->ss->type == GFC_SS_REFERENCE)
4702 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4703 se->string_length = se->ss->string_length;
4704 gfc_advance_se_ss_chain (se);
4708 /* We need to convert the expressions for the iso_c_binding derived types.
4709 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4710 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4711 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4712 updated to be an integer with a kind equal to the size of a (void *). */
4713 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4714 && expr->ts.u.derived->attr.is_iso_c)
4716 if (expr->expr_type == EXPR_VARIABLE
4717 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4718 || expr->symtree->n.sym->intmod_sym_id
4719 == ISOCBINDING_NULL_FUNPTR))
4721 /* Set expr_type to EXPR_NULL, which will result in
4722 null_pointer_node being used below. */
4723 expr->expr_type = EXPR_NULL;
4727 /* Update the type/kind of the expression to be what the new
4728 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4729 expr->ts.type = expr->ts.u.derived->ts.type;
4730 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4731 expr->ts.kind = expr->ts.u.derived->ts.kind;
4735 switch (expr->expr_type)
4738 gfc_conv_expr_op (se, expr);
4742 gfc_conv_function_expr (se, expr);
4746 gfc_conv_constant (se, expr);
4750 gfc_conv_variable (se, expr);
4754 se->expr = null_pointer_node;
4757 case EXPR_SUBSTRING:
4758 gfc_conv_substring_expr (se, expr);
4761 case EXPR_STRUCTURE:
4762 gfc_conv_structure (se, expr, 0);
4766 gfc_conv_array_constructor_expr (se, expr);
4775 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4776 of an assignment. */
4778 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4780 gfc_conv_expr (se, expr);
4781 /* All numeric lvalues should have empty post chains. If not we need to
4782 figure out a way of rewriting an lvalue so that it has no post chain. */
4783 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4786 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4787 numeric expressions. Used for scalar values where inserting cleanup code
4790 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4794 gcc_assert (expr->ts.type != BT_CHARACTER);
4795 gfc_conv_expr (se, expr);
4798 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4799 gfc_add_modify (&se->pre, val, se->expr);
4801 gfc_add_block_to_block (&se->pre, &se->post);
4805 /* Helper to translate an expression and convert it to a particular type. */
4807 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4809 gfc_conv_expr_val (se, expr);
4810 se->expr = convert (type, se->expr);
4814 /* Converts an expression so that it can be passed by reference. Scalar
4818 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4822 if (se->ss && se->ss->expr == expr
4823 && se->ss->type == GFC_SS_REFERENCE)
4825 /* Returns a reference to the scalar evaluated outside the loop
4827 gfc_conv_expr (se, expr);
4831 if (expr->ts.type == BT_CHARACTER)
4833 gfc_conv_expr (se, expr);
4834 gfc_conv_string_parameter (se);
4838 if (expr->expr_type == EXPR_VARIABLE)
4840 se->want_pointer = 1;
4841 gfc_conv_expr (se, expr);
4844 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4845 gfc_add_modify (&se->pre, var, se->expr);
4846 gfc_add_block_to_block (&se->pre, &se->post);
4852 if (expr->expr_type == EXPR_FUNCTION
4853 && ((expr->value.function.esym
4854 && expr->value.function.esym->result->attr.pointer
4855 && !expr->value.function.esym->result->attr.dimension)
4856 || (!expr->value.function.esym
4857 && expr->symtree->n.sym->attr.pointer
4858 && !expr->symtree->n.sym->attr.dimension)))
4860 se->want_pointer = 1;
4861 gfc_conv_expr (se, expr);
4862 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4863 gfc_add_modify (&se->pre, var, se->expr);
4869 gfc_conv_expr (se, expr);
4871 /* Create a temporary var to hold the value. */
4872 if (TREE_CONSTANT (se->expr))
4874 tree tmp = se->expr;
4875 STRIP_TYPE_NOPS (tmp);
4876 var = build_decl (input_location,
4877 CONST_DECL, NULL, TREE_TYPE (tmp));
4878 DECL_INITIAL (var) = tmp;
4879 TREE_STATIC (var) = 1;
4884 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4885 gfc_add_modify (&se->pre, var, se->expr);
4887 gfc_add_block_to_block (&se->pre, &se->post);
4889 /* Take the address of that value. */
4890 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4895 gfc_trans_pointer_assign (gfc_code * code)
4897 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4901 /* Generate code for a pointer assignment. */
4904 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4915 gfc_start_block (&block);
4917 gfc_init_se (&lse, NULL);
4919 lss = gfc_walk_expr (expr1);
4920 rss = gfc_walk_expr (expr2);
4921 if (lss == gfc_ss_terminator)
4923 /* Scalar pointers. */
4924 lse.want_pointer = 1;
4925 gfc_conv_expr (&lse, expr1);
4926 gcc_assert (rss == gfc_ss_terminator);
4927 gfc_init_se (&rse, NULL);
4928 rse.want_pointer = 1;
4929 gfc_conv_expr (&rse, expr2);
4931 if (expr1->symtree->n.sym->attr.proc_pointer
4932 && expr1->symtree->n.sym->attr.dummy)
4933 lse.expr = build_fold_indirect_ref_loc (input_location,
4936 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4937 && expr2->symtree->n.sym->attr.dummy)
4938 rse.expr = build_fold_indirect_ref_loc (input_location,
4941 gfc_add_block_to_block (&block, &lse.pre);
4942 gfc_add_block_to_block (&block, &rse.pre);
4944 /* Check character lengths if character expression. The test is only
4945 really added if -fbounds-check is enabled. Exclude deferred
4946 character length lefthand sides. */
4947 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4948 && !(expr1->ts.deferred
4949 && (TREE_CODE (lse.string_length) == VAR_DECL))
4950 && !expr1->symtree->n.sym->attr.proc_pointer
4951 && !gfc_is_proc_ptr_comp (expr1, NULL))
4953 gcc_assert (expr2->ts.type == BT_CHARACTER);
4954 gcc_assert (lse.string_length && rse.string_length);
4955 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4956 lse.string_length, rse.string_length,
4960 /* The assignment to an deferred character length sets the string
4961 length to that of the rhs. */
4962 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
4964 if (expr2->expr_type != EXPR_NULL)
4965 gfc_add_modify (&block, lse.string_length, rse.string_length);
4967 gfc_add_modify (&block, lse.string_length,
4968 build_int_cst (gfc_charlen_type_node, 0));
4971 gfc_add_modify (&block, lse.expr,
4972 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4974 gfc_add_block_to_block (&block, &rse.post);
4975 gfc_add_block_to_block (&block, &lse.post);
4982 tree strlen_rhs = NULL_TREE;
4984 /* Array pointer. Find the last reference on the LHS and if it is an
4985 array section ref, we're dealing with bounds remapping. In this case,
4986 set it to AR_FULL so that gfc_conv_expr_descriptor does
4987 not see it and process the bounds remapping afterwards explicitely. */
4988 for (remap = expr1->ref; remap; remap = remap->next)
4989 if (!remap->next && remap->type == REF_ARRAY
4990 && remap->u.ar.type == AR_SECTION)
4992 remap->u.ar.type = AR_FULL;
4995 rank_remap = (remap && remap->u.ar.end[0]);
4997 gfc_conv_expr_descriptor (&lse, expr1, lss);
4998 strlen_lhs = lse.string_length;
5001 if (expr2->expr_type == EXPR_NULL)
5003 /* Just set the data pointer to null. */
5004 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5006 else if (rank_remap)
5008 /* If we are rank-remapping, just get the RHS's descriptor and
5009 process this later on. */
5010 gfc_init_se (&rse, NULL);
5011 rse.direct_byref = 1;
5012 rse.byref_noassign = 1;
5013 gfc_conv_expr_descriptor (&rse, expr2, rss);
5014 strlen_rhs = rse.string_length;
5016 else if (expr2->expr_type == EXPR_VARIABLE)
5018 /* Assign directly to the LHS's descriptor. */
5019 lse.direct_byref = 1;
5020 gfc_conv_expr_descriptor (&lse, expr2, rss);
5021 strlen_rhs = lse.string_length;
5023 /* If this is a subreference array pointer assignment, use the rhs
5024 descriptor element size for the lhs span. */
5025 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5027 decl = expr1->symtree->n.sym->backend_decl;
5028 gfc_init_se (&rse, NULL);
5029 rse.descriptor_only = 1;
5030 gfc_conv_expr (&rse, expr2);
5031 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5032 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5033 if (!INTEGER_CST_P (tmp))
5034 gfc_add_block_to_block (&lse.post, &rse.pre);
5035 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5040 /* Assign to a temporary descriptor and then copy that
5041 temporary to the pointer. */
5042 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5045 lse.direct_byref = 1;
5046 gfc_conv_expr_descriptor (&lse, expr2, rss);
5047 strlen_rhs = lse.string_length;
5048 gfc_add_modify (&lse.pre, desc, tmp);
5051 gfc_add_block_to_block (&block, &lse.pre);
5053 gfc_add_block_to_block (&block, &rse.pre);
5055 /* If we do bounds remapping, update LHS descriptor accordingly. */
5059 gcc_assert (remap->u.ar.dimen == expr1->rank);
5063 /* Do rank remapping. We already have the RHS's descriptor
5064 converted in rse and now have to build the correct LHS
5065 descriptor for it. */
5069 tree lbound, ubound;
5072 dtype = gfc_conv_descriptor_dtype (desc);
5073 tmp = gfc_get_dtype (TREE_TYPE (desc));
5074 gfc_add_modify (&block, dtype, tmp);
5076 /* Copy data pointer. */
5077 data = gfc_conv_descriptor_data_get (rse.expr);
5078 gfc_conv_descriptor_data_set (&block, desc, data);
5080 /* Copy offset but adjust it such that it would correspond
5081 to a lbound of zero. */
5082 offs = gfc_conv_descriptor_offset_get (rse.expr);
5083 for (dim = 0; dim < expr2->rank; ++dim)
5085 stride = gfc_conv_descriptor_stride_get (rse.expr,
5087 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5089 tmp = fold_build2_loc (input_location, MULT_EXPR,
5090 gfc_array_index_type, stride, lbound);
5091 offs = fold_build2_loc (input_location, PLUS_EXPR,
5092 gfc_array_index_type, offs, tmp);
5094 gfc_conv_descriptor_offset_set (&block, desc, offs);
5096 /* Set the bounds as declared for the LHS and calculate strides as
5097 well as another offset update accordingly. */
5098 stride = gfc_conv_descriptor_stride_get (rse.expr,
5100 for (dim = 0; dim < expr1->rank; ++dim)
5105 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5107 /* Convert declared bounds. */
5108 gfc_init_se (&lower_se, NULL);
5109 gfc_init_se (&upper_se, NULL);
5110 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5111 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5113 gfc_add_block_to_block (&block, &lower_se.pre);
5114 gfc_add_block_to_block (&block, &upper_se.pre);
5116 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5117 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5119 lbound = gfc_evaluate_now (lbound, &block);
5120 ubound = gfc_evaluate_now (ubound, &block);
5122 gfc_add_block_to_block (&block, &lower_se.post);
5123 gfc_add_block_to_block (&block, &upper_se.post);
5125 /* Set bounds in descriptor. */
5126 gfc_conv_descriptor_lbound_set (&block, desc,
5127 gfc_rank_cst[dim], lbound);
5128 gfc_conv_descriptor_ubound_set (&block, desc,
5129 gfc_rank_cst[dim], ubound);
5132 stride = gfc_evaluate_now (stride, &block);
5133 gfc_conv_descriptor_stride_set (&block, desc,
5134 gfc_rank_cst[dim], stride);
5136 /* Update offset. */
5137 offs = gfc_conv_descriptor_offset_get (desc);
5138 tmp = fold_build2_loc (input_location, MULT_EXPR,
5139 gfc_array_index_type, lbound, stride);
5140 offs = fold_build2_loc (input_location, MINUS_EXPR,
5141 gfc_array_index_type, offs, tmp);
5142 offs = gfc_evaluate_now (offs, &block);
5143 gfc_conv_descriptor_offset_set (&block, desc, offs);
5145 /* Update stride. */
5146 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5147 stride = fold_build2_loc (input_location, MULT_EXPR,
5148 gfc_array_index_type, stride, tmp);
5153 /* Bounds remapping. Just shift the lower bounds. */
5155 gcc_assert (expr1->rank == expr2->rank);
5157 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5161 gcc_assert (remap->u.ar.start[dim]);
5162 gcc_assert (!remap->u.ar.end[dim]);
5163 gfc_init_se (&lbound_se, NULL);
5164 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5166 gfc_add_block_to_block (&block, &lbound_se.pre);
5167 gfc_conv_shift_descriptor_lbound (&block, desc,
5168 dim, lbound_se.expr);
5169 gfc_add_block_to_block (&block, &lbound_se.post);
5174 /* Check string lengths if applicable. The check is only really added
5175 to the output code if -fbounds-check is enabled. */
5176 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5178 gcc_assert (expr2->ts.type == BT_CHARACTER);
5179 gcc_assert (strlen_lhs && strlen_rhs);
5180 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5181 strlen_lhs, strlen_rhs, &block);
5184 /* If rank remapping was done, check with -fcheck=bounds that
5185 the target is at least as large as the pointer. */
5186 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5192 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5193 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5195 lsize = gfc_evaluate_now (lsize, &block);
5196 rsize = gfc_evaluate_now (rsize, &block);
5197 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5200 msg = _("Target of rank remapping is too small (%ld < %ld)");
5201 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5205 gfc_add_block_to_block (&block, &lse.post);
5207 gfc_add_block_to_block (&block, &rse.post);
5210 return gfc_finish_block (&block);
5214 /* Makes sure se is suitable for passing as a function string parameter. */
5215 /* TODO: Need to check all callers of this function. It may be abused. */
5218 gfc_conv_string_parameter (gfc_se * se)
5222 if (TREE_CODE (se->expr) == STRING_CST)
5224 type = TREE_TYPE (TREE_TYPE (se->expr));
5225 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5229 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5231 if (TREE_CODE (se->expr) != INDIRECT_REF)
5233 type = TREE_TYPE (se->expr);
5234 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5238 type = gfc_get_character_type_len (gfc_default_character_kind,
5240 type = build_pointer_type (type);
5241 se->expr = gfc_build_addr_expr (type, se->expr);
5245 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5249 /* Generate code for assignment of scalar variables. Includes character
5250 strings and derived types with allocatable components.
5251 If you know that the LHS has no allocations, set dealloc to false. */
5254 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5255 bool l_is_temp, bool r_is_var, bool dealloc)
5261 gfc_init_block (&block);
5263 if (ts.type == BT_CHARACTER)
5268 if (lse->string_length != NULL_TREE)
5270 gfc_conv_string_parameter (lse);
5271 gfc_add_block_to_block (&block, &lse->pre);
5272 llen = lse->string_length;
5275 if (rse->string_length != NULL_TREE)
5277 gcc_assert (rse->string_length != NULL_TREE);
5278 gfc_conv_string_parameter (rse);
5279 gfc_add_block_to_block (&block, &rse->pre);
5280 rlen = rse->string_length;
5283 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5284 rse->expr, ts.kind);
5286 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5290 /* Are the rhs and the lhs the same? */
5293 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5294 gfc_build_addr_expr (NULL_TREE, lse->expr),
5295 gfc_build_addr_expr (NULL_TREE, rse->expr));
5296 cond = gfc_evaluate_now (cond, &lse->pre);
5299 /* Deallocate the lhs allocated components as long as it is not
5300 the same as the rhs. This must be done following the assignment
5301 to prevent deallocating data that could be used in the rhs
5303 if (!l_is_temp && dealloc)
5305 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5306 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5308 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5310 gfc_add_expr_to_block (&lse->post, tmp);
5313 gfc_add_block_to_block (&block, &rse->pre);
5314 gfc_add_block_to_block (&block, &lse->pre);
5316 gfc_add_modify (&block, lse->expr,
5317 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5319 /* Do a deep copy if the rhs is a variable, if it is not the
5323 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5324 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5326 gfc_add_expr_to_block (&block, tmp);
5329 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5331 gfc_add_block_to_block (&block, &lse->pre);
5332 gfc_add_block_to_block (&block, &rse->pre);
5333 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5334 TREE_TYPE (lse->expr), rse->expr);
5335 gfc_add_modify (&block, lse->expr, tmp);
5339 gfc_add_block_to_block (&block, &lse->pre);
5340 gfc_add_block_to_block (&block, &rse->pre);
5342 gfc_add_modify (&block, lse->expr,
5343 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5346 gfc_add_block_to_block (&block, &lse->post);
5347 gfc_add_block_to_block (&block, &rse->post);
5349 return gfc_finish_block (&block);
5353 /* There are quite a lot of restrictions on the optimisation in using an
5354 array function assign without a temporary. */
5357 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5360 bool seen_array_ref;
5362 gfc_symbol *sym = expr1->symtree->n.sym;
5364 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5365 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5368 /* Elemental functions are scalarized so that they don't need a
5369 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5370 they would need special treatment in gfc_trans_arrayfunc_assign. */
5371 if (expr2->value.function.esym != NULL
5372 && expr2->value.function.esym->attr.elemental)
5375 /* Need a temporary if rhs is not FULL or a contiguous section. */
5376 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5379 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5380 if (gfc_ref_needs_temporary_p (expr1->ref))
5383 /* Functions returning pointers need temporaries. */
5384 if (expr2->symtree->n.sym->attr.pointer
5385 || expr2->symtree->n.sym->attr.allocatable)
5388 /* Character array functions need temporaries unless the
5389 character lengths are the same. */
5390 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5392 if (expr1->ts.u.cl->length == NULL
5393 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5396 if (expr2->ts.u.cl->length == NULL
5397 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5400 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5401 expr2->ts.u.cl->length->value.integer) != 0)
5405 /* Check that no LHS component references appear during an array
5406 reference. This is needed because we do not have the means to
5407 span any arbitrary stride with an array descriptor. This check
5408 is not needed for the rhs because the function result has to be
5410 seen_array_ref = false;
5411 for (ref = expr1->ref; ref; ref = ref->next)
5413 if (ref->type == REF_ARRAY)
5414 seen_array_ref= true;
5415 else if (ref->type == REF_COMPONENT && seen_array_ref)
5419 /* Check for a dependency. */
5420 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5421 expr2->value.function.esym,
5422 expr2->value.function.actual,
5426 /* If we have reached here with an intrinsic function, we do not
5427 need a temporary. */
5428 if (expr2->value.function.isym)
5431 /* If the LHS is a dummy, we need a temporary if it is not
5433 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5436 /* If the lhs has been host_associated, is in common, a pointer or is
5437 a target and the function is not using a RESULT variable, aliasing
5438 can occur and a temporary is needed. */
5439 if ((sym->attr.host_assoc
5440 || sym->attr.in_common
5441 || sym->attr.pointer
5442 || sym->attr.cray_pointee
5443 || sym->attr.target)
5444 && expr2->symtree != NULL
5445 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5448 /* A PURE function can unconditionally be called without a temporary. */
5449 if (expr2->value.function.esym != NULL
5450 && expr2->value.function.esym->attr.pure)
5453 /* Implicit_pure functions are those which could legally be declared
5455 if (expr2->value.function.esym != NULL
5456 && expr2->value.function.esym->attr.implicit_pure)
5459 if (!sym->attr.use_assoc
5460 && !sym->attr.in_common
5461 && !sym->attr.pointer
5462 && !sym->attr.target
5463 && !sym->attr.cray_pointee
5464 && expr2->value.function.esym)
5466 /* A temporary is not needed if the function is not contained and
5467 the variable is local or host associated and not a pointer or
5469 if (!expr2->value.function.esym->attr.contained)
5472 /* A temporary is not needed if the lhs has never been host
5473 associated and the procedure is contained. */
5474 else if (!sym->attr.host_assoc)
5477 /* A temporary is not needed if the variable is local and not
5478 a pointer, a target or a result. */
5480 && expr2->value.function.esym->ns == sym->ns->parent)
5484 /* Default to temporary use. */
5489 /* Provide the loop info so that the lhs descriptor can be built for
5490 reallocatable assignments from extrinsic function calls. */
5493 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
5496 /* Signal that the function call should not be made by
5497 gfc_conv_loop_setup. */
5498 se->ss->is_alloc_lhs = 1;
5499 gfc_init_loopinfo (&loop);
5500 gfc_add_ss_to_loop (&loop, *ss);
5501 gfc_add_ss_to_loop (&loop, se->ss);
5502 gfc_conv_ss_startstride (&loop);
5503 gfc_conv_loop_setup (&loop, where);
5504 gfc_copy_loopinfo_to_se (se, &loop);
5505 gfc_add_block_to_block (&se->pre, &loop.pre);
5506 gfc_add_block_to_block (&se->pre, &loop.post);
5507 se->ss->is_alloc_lhs = 0;
5512 realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
5519 /* Use the allocation done by the library. */
5520 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5521 tmp = gfc_conv_descriptor_data_get (desc);
5522 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5523 gfc_add_expr_to_block (&se->pre, tmp);
5524 gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
5525 /* Unallocated, the descriptor does not have a dtype. */
5526 tmp = gfc_conv_descriptor_dtype (desc);
5527 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5529 offset = gfc_index_zero_node;
5530 tmp = gfc_index_one_node;
5531 /* Now reset the bounds from zero based to unity based. */
5532 for (n = 0 ; n < rank; n++)
5534 /* Accumulate the offset. */
5535 offset = fold_build2_loc (input_location, MINUS_EXPR,
5536 gfc_array_index_type,
5538 /* Now do the bounds. */
5539 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5540 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5541 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5542 gfc_array_index_type,
5543 tmp, gfc_index_one_node);
5544 gfc_conv_descriptor_lbound_set (&se->post, desc,
5546 gfc_index_one_node);
5547 gfc_conv_descriptor_ubound_set (&se->post, desc,
5548 gfc_rank_cst[n], tmp);
5550 /* The extent for the next contribution to offset. */
5551 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5552 gfc_array_index_type,
5553 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5554 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5555 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5556 gfc_array_index_type,
5557 tmp, gfc_index_one_node);
5559 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5564 /* Try to translate array(:) = func (...), where func is a transformational
5565 array function, without using a temporary. Returns NULL if this isn't the
5569 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5573 gfc_component *comp = NULL;
5575 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5578 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5580 gcc_assert (expr2->value.function.isym
5581 || (gfc_is_proc_ptr_comp (expr2, &comp)
5582 && comp && comp->attr.dimension)
5583 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5584 && expr2->value.function.esym->result->attr.dimension));
5586 ss = gfc_walk_expr (expr1);
5587 gcc_assert (ss != gfc_ss_terminator);
5588 gfc_init_se (&se, NULL);
5589 gfc_start_block (&se.pre);
5590 se.want_pointer = 1;
5592 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5594 if (expr1->ts.type == BT_DERIVED
5595 && expr1->ts.u.derived->attr.alloc_comp)
5598 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5600 gfc_add_expr_to_block (&se.pre, tmp);
5603 se.direct_byref = 1;
5604 se.ss = gfc_walk_expr (expr2);
5605 gcc_assert (se.ss != gfc_ss_terminator);
5607 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5608 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5609 Clearly, this cannot be done for an allocatable function result, since
5610 the shape of the result is unknown and, in any case, the function must
5611 correctly take care of the reallocation internally. For intrinsic
5612 calls, the array data is freed and the library takes care of allocation.
5613 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5615 if (gfc_option.flag_realloc_lhs
5616 && gfc_is_reallocatable_lhs (expr1)
5617 && !gfc_expr_attr (expr1).codimension
5618 && !gfc_is_coindexed (expr1)
5619 && !(expr2->value.function.esym
5620 && expr2->value.function.esym->result->attr.allocatable))
5622 if (!expr2->value.function.isym)
5624 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
5625 ss->is_alloc_lhs = 1;
5628 realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
5631 gfc_conv_function_expr (&se, expr2);
5632 gfc_add_block_to_block (&se.pre, &se.post);
5634 return gfc_finish_block (&se.pre);
5638 /* Try to efficiently translate array(:) = 0. Return NULL if this
5642 gfc_trans_zero_assign (gfc_expr * expr)
5644 tree dest, len, type;
5648 sym = expr->symtree->n.sym;
5649 dest = gfc_get_symbol_decl (sym);
5651 type = TREE_TYPE (dest);
5652 if (POINTER_TYPE_P (type))
5653 type = TREE_TYPE (type);
5654 if (!GFC_ARRAY_TYPE_P (type))
5657 /* Determine the length of the array. */
5658 len = GFC_TYPE_ARRAY_SIZE (type);
5659 if (!len || TREE_CODE (len) != INTEGER_CST)
5662 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5663 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5664 fold_convert (gfc_array_index_type, tmp));
5666 /* If we are zeroing a local array avoid taking its address by emitting
5668 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5669 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5670 dest, build_constructor (TREE_TYPE (dest), NULL));
5672 /* Convert arguments to the correct types. */
5673 dest = fold_convert (pvoid_type_node, dest);
5674 len = fold_convert (size_type_node, len);
5676 /* Construct call to __builtin_memset. */
5677 tmp = build_call_expr_loc (input_location,
5678 built_in_decls[BUILT_IN_MEMSET],
5679 3, dest, integer_zero_node, len);
5680 return fold_convert (void_type_node, tmp);
5684 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5685 that constructs the call to __builtin_memcpy. */
5688 gfc_build_memcpy_call (tree dst, tree src, tree len)
5692 /* Convert arguments to the correct types. */
5693 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5694 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5696 dst = fold_convert (pvoid_type_node, dst);
5698 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5699 src = gfc_build_addr_expr (pvoid_type_node, src);
5701 src = fold_convert (pvoid_type_node, src);
5703 len = fold_convert (size_type_node, len);
5705 /* Construct call to __builtin_memcpy. */
5706 tmp = build_call_expr_loc (input_location,
5707 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5708 return fold_convert (void_type_node, tmp);
5712 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5713 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5714 source/rhs, both are gfc_full_array_ref_p which have been checked for
5718 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5720 tree dst, dlen, dtype;
5721 tree src, slen, stype;
5724 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5725 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5727 dtype = TREE_TYPE (dst);
5728 if (POINTER_TYPE_P (dtype))
5729 dtype = TREE_TYPE (dtype);
5730 stype = TREE_TYPE (src);
5731 if (POINTER_TYPE_P (stype))
5732 stype = TREE_TYPE (stype);
5734 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5737 /* Determine the lengths of the arrays. */
5738 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5739 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5741 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5742 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5743 dlen, fold_convert (gfc_array_index_type, tmp));
5745 slen = GFC_TYPE_ARRAY_SIZE (stype);
5746 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5748 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5749 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5750 slen, fold_convert (gfc_array_index_type, tmp));
5752 /* Sanity check that they are the same. This should always be
5753 the case, as we should already have checked for conformance. */
5754 if (!tree_int_cst_equal (slen, dlen))
5757 return gfc_build_memcpy_call (dst, src, dlen);
5761 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5762 this can't be done. EXPR1 is the destination/lhs for which
5763 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5766 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5768 unsigned HOST_WIDE_INT nelem;
5774 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5778 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5779 dtype = TREE_TYPE (dst);
5780 if (POINTER_TYPE_P (dtype))
5781 dtype = TREE_TYPE (dtype);
5782 if (!GFC_ARRAY_TYPE_P (dtype))
5785 /* Determine the lengths of the array. */
5786 len = GFC_TYPE_ARRAY_SIZE (dtype);
5787 if (!len || TREE_CODE (len) != INTEGER_CST)
5790 /* Confirm that the constructor is the same size. */
5791 if (compare_tree_int (len, nelem) != 0)
5794 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5795 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5796 fold_convert (gfc_array_index_type, tmp));
5798 stype = gfc_typenode_for_spec (&expr2->ts);
5799 src = gfc_build_constant_array_constructor (expr2, stype);
5801 stype = TREE_TYPE (src);
5802 if (POINTER_TYPE_P (stype))
5803 stype = TREE_TYPE (stype);
5805 return gfc_build_memcpy_call (dst, src, len);
5809 /* Tells whether the expression is to be treated as a variable reference. */
5812 expr_is_variable (gfc_expr *expr)
5816 if (expr->expr_type == EXPR_VARIABLE)
5819 arg = gfc_get_noncopying_intrinsic_argument (expr);
5822 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5823 return expr_is_variable (arg);
5830 /* Is the lhs OK for automatic reallocation? */
5833 is_scalar_reallocatable_lhs (gfc_expr *expr)
5837 /* An allocatable variable with no reference. */
5838 if (expr->symtree->n.sym->attr.allocatable
5842 /* All that can be left are allocatable components. */
5843 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
5844 && expr->symtree->n.sym->ts.type != BT_CLASS)
5845 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
5848 /* Find an allocatable component ref last. */
5849 for (ref = expr->ref; ref; ref = ref->next)
5850 if (ref->type == REF_COMPONENT
5852 && ref->u.c.component->attr.allocatable)
5859 /* Allocate or reallocate scalar lhs, as necessary. */
5862 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
5876 if (!expr1 || expr1->rank)
5879 if (!expr2 || expr2->rank)
5882 /* Since this is a scalar lhs, we can afford to do this. That is,
5883 there is no risk of side effects being repeated. */
5884 gfc_init_se (&lse, NULL);
5885 lse.want_pointer = 1;
5886 gfc_conv_expr (&lse, expr1);
5888 jump_label1 = gfc_build_label_decl (NULL_TREE);
5889 jump_label2 = gfc_build_label_decl (NULL_TREE);
5891 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5892 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
5893 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5895 tmp = build3_v (COND_EXPR, cond,
5896 build1_v (GOTO_EXPR, jump_label1),
5897 build_empty_stmt (input_location));
5898 gfc_add_expr_to_block (block, tmp);
5900 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5902 /* Use the rhs string length and the lhs element size. */
5903 size = string_length;
5904 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
5905 tmp = TYPE_SIZE_UNIT (tmp);
5906 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
5907 TREE_TYPE (tmp), tmp,
5908 fold_convert (TREE_TYPE (tmp), size));
5912 /* Otherwise use the length in bytes of the rhs. */
5913 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
5914 size_in_bytes = size;
5917 tmp = build_call_expr_loc (input_location,
5918 built_in_decls[BUILT_IN_MALLOC], 1,
5920 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5921 gfc_add_modify (block, lse.expr, tmp);
5922 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5924 /* Deferred characters need checking for lhs and rhs string
5925 length. Other deferred parameter variables will have to
5927 tmp = build1_v (GOTO_EXPR, jump_label2);
5928 gfc_add_expr_to_block (block, tmp);
5930 tmp = build1_v (LABEL_EXPR, jump_label1);
5931 gfc_add_expr_to_block (block, tmp);
5933 /* For a deferred length character, reallocate if lengths of lhs and
5934 rhs are different. */
5935 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5937 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5938 expr1->ts.u.cl->backend_decl, size);
5939 /* Jump past the realloc if the lengths are the same. */
5940 tmp = build3_v (COND_EXPR, cond,
5941 build1_v (GOTO_EXPR, jump_label2),
5942 build_empty_stmt (input_location));
5943 gfc_add_expr_to_block (block, tmp);
5944 tmp = build_call_expr_loc (input_location,
5945 built_in_decls[BUILT_IN_REALLOC], 2,
5946 fold_convert (pvoid_type_node, lse.expr),
5948 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
5949 gfc_add_modify (block, lse.expr, tmp);
5950 tmp = build1_v (LABEL_EXPR, jump_label2);
5951 gfc_add_expr_to_block (block, tmp);
5953 /* Update the lhs character length. */
5954 size = string_length;
5955 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
5960 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5961 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5962 init_flag indicates initialization expressions and dealloc that no
5963 deallocate prior assignment is needed (if in doubt, set true). */
5966 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5972 gfc_ss *lss_section;
5979 bool scalar_to_array;
5983 /* Assignment of the form lhs = rhs. */
5984 gfc_start_block (&block);
5986 gfc_init_se (&lse, NULL);
5987 gfc_init_se (&rse, NULL);
5990 lss = gfc_walk_expr (expr1);
5991 if (gfc_is_reallocatable_lhs (expr1)
5992 && !(expr2->expr_type == EXPR_FUNCTION
5993 && expr2->value.function.isym != NULL))
5994 lss->is_alloc_lhs = 1;
5996 if (lss != gfc_ss_terminator)
5998 /* Allow the scalarizer to workshare array assignments. */
5999 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
6000 ompws_flags |= OMPWS_SCALARIZER_WS;
6002 /* The assignment needs scalarization. */
6005 /* Find a non-scalar SS from the lhs. */
6006 while (lss_section != gfc_ss_terminator
6007 && lss_section->type != GFC_SS_SECTION)
6008 lss_section = lss_section->next;
6010 gcc_assert (lss_section != gfc_ss_terminator);
6012 /* Initialize the scalarizer. */
6013 gfc_init_loopinfo (&loop);
6016 rss = gfc_walk_expr (expr2);
6017 if (rss == gfc_ss_terminator)
6019 /* The rhs is scalar. Add a ss for the expression. */
6020 rss = gfc_get_ss ();
6021 rss->next = gfc_ss_terminator;
6022 rss->type = GFC_SS_SCALAR;
6025 /* Associate the SS with the loop. */
6026 gfc_add_ss_to_loop (&loop, lss);
6027 gfc_add_ss_to_loop (&loop, rss);
6029 /* Calculate the bounds of the scalarization. */
6030 gfc_conv_ss_startstride (&loop);
6031 /* Enable loop reversal. */
6032 for (n = 0; n < loop.dimen; n++)
6033 loop.reverse[n] = GFC_REVERSE_NOT_SET;
6034 /* Resolve any data dependencies in the statement. */
6035 gfc_conv_resolve_dependencies (&loop, lss, rss);
6036 /* Setup the scalarizing loops. */
6037 gfc_conv_loop_setup (&loop, &expr2->where);
6039 /* Setup the gfc_se structures. */
6040 gfc_copy_loopinfo_to_se (&lse, &loop);
6041 gfc_copy_loopinfo_to_se (&rse, &loop);
6044 gfc_mark_ss_chain_used (rss, 1);
6045 if (loop.temp_ss == NULL)
6048 gfc_mark_ss_chain_used (lss, 1);
6052 lse.ss = loop.temp_ss;
6053 gfc_mark_ss_chain_used (lss, 3);
6054 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6057 /* Start the scalarized loop body. */
6058 gfc_start_scalarized_body (&loop, &body);
6061 gfc_init_block (&body);
6063 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6065 /* Translate the expression. */
6066 gfc_conv_expr (&rse, expr2);
6068 /* Stabilize a string length for temporaries. */
6069 if (expr2->ts.type == BT_CHARACTER)
6070 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6072 string_length = NULL_TREE;
6076 gfc_conv_tmp_array_ref (&lse);
6077 if (expr2->ts.type == BT_CHARACTER)
6078 lse.string_length = string_length;
6081 gfc_conv_expr (&lse, expr1);
6083 /* Assignments of scalar derived types with allocatable components
6084 to arrays must be done with a deep copy and the rhs temporary
6085 must have its components deallocated afterwards. */
6086 scalar_to_array = (expr2->ts.type == BT_DERIVED
6087 && expr2->ts.u.derived->attr.alloc_comp
6088 && !expr_is_variable (expr2)
6089 && !gfc_is_constant_expr (expr2)
6090 && expr1->rank && !expr2->rank);
6091 if (scalar_to_array && dealloc)
6093 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6094 gfc_add_expr_to_block (&loop.post, tmp);
6097 /* For a deferred character length function, the function call must
6098 happen before the (re)allocation of the lhs, otherwise the character
6099 length of the result is not known. */
6100 if (gfc_option.flag_realloc_lhs
6101 && expr2->expr_type == EXPR_FUNCTION
6102 && expr2->ts.type == BT_CHARACTER
6103 && expr2->ts.deferred)
6104 gfc_add_block_to_block (&block, &rse.pre);
6106 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6107 l_is_temp || init_flag,
6108 expr_is_variable (expr2) || scalar_to_array,
6110 gfc_add_expr_to_block (&body, tmp);
6112 if (lss == gfc_ss_terminator)
6114 /* F2003: Add the code for reallocation on assignment. */
6115 if (gfc_option.flag_realloc_lhs
6116 && is_scalar_reallocatable_lhs (expr1))
6117 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6120 /* Use the scalar assignment as is. */
6121 gfc_add_block_to_block (&block, &body);
6125 gcc_assert (lse.ss == gfc_ss_terminator
6126 && rse.ss == gfc_ss_terminator);
6130 gfc_trans_scalarized_loop_boundary (&loop, &body);
6132 /* We need to copy the temporary to the actual lhs. */
6133 gfc_init_se (&lse, NULL);
6134 gfc_init_se (&rse, NULL);
6135 gfc_copy_loopinfo_to_se (&lse, &loop);
6136 gfc_copy_loopinfo_to_se (&rse, &loop);
6138 rse.ss = loop.temp_ss;
6141 gfc_conv_tmp_array_ref (&rse);
6142 gfc_conv_expr (&lse, expr1);
6144 gcc_assert (lse.ss == gfc_ss_terminator
6145 && rse.ss == gfc_ss_terminator);
6147 if (expr2->ts.type == BT_CHARACTER)
6148 rse.string_length = string_length;
6150 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6151 false, false, dealloc);
6152 gfc_add_expr_to_block (&body, tmp);
6155 /* F2003: Allocate or reallocate lhs of allocatable array. */
6156 if (gfc_option.flag_realloc_lhs
6157 && gfc_is_reallocatable_lhs (expr1)
6158 && !gfc_expr_attr (expr1).codimension
6159 && !gfc_is_coindexed (expr1))
6161 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
6162 if (tmp != NULL_TREE)
6163 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
6166 /* Generate the copying loops. */
6167 gfc_trans_scalarizing_loops (&loop, &body);
6169 /* Wrap the whole thing up. */
6170 gfc_add_block_to_block (&block, &loop.pre);
6171 gfc_add_block_to_block (&block, &loop.post);
6173 gfc_cleanup_loop (&loop);
6176 return gfc_finish_block (&block);
6180 /* Check whether EXPR is a copyable array. */
6183 copyable_array_p (gfc_expr * expr)
6185 if (expr->expr_type != EXPR_VARIABLE)
6188 /* First check it's an array. */
6189 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6192 if (!gfc_full_array_ref_p (expr->ref, NULL))
6195 /* Next check that it's of a simple enough type. */
6196 switch (expr->ts.type)
6208 return !expr->ts.u.derived->attr.alloc_comp;
6217 /* Translate an assignment. */
6220 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6225 /* Special case a single function returning an array. */
6226 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6228 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6233 /* Special case assigning an array to zero. */
6234 if (copyable_array_p (expr1)
6235 && is_zero_initializer_p (expr2))
6237 tmp = gfc_trans_zero_assign (expr1);
6242 /* Special case copying one array to another. */
6243 if (copyable_array_p (expr1)
6244 && copyable_array_p (expr2)
6245 && gfc_compare_types (&expr1->ts, &expr2->ts)
6246 && !gfc_check_dependency (expr1, expr2, 0))
6248 tmp = gfc_trans_array_copy (expr1, expr2);
6253 /* Special case initializing an array from a constant array constructor. */
6254 if (copyable_array_p (expr1)
6255 && expr2->expr_type == EXPR_ARRAY
6256 && gfc_compare_types (&expr1->ts, &expr2->ts))
6258 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6263 /* Fallback to the scalarizer to generate explicit loops. */
6264 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6268 gfc_trans_init_assign (gfc_code * code)
6270 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6274 gfc_trans_assign (gfc_code * code)
6276 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6280 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6281 A MEMCPY is needed to copy the full data from the default initializer
6282 of the dynamic type. */
6285 gfc_trans_class_init_assign (gfc_code *code)
6289 gfc_se dst,src,memsz;
6290 gfc_expr *lhs,*rhs,*sz;
6292 gfc_start_block (&block);
6294 lhs = gfc_copy_expr (code->expr1);
6295 gfc_add_data_component (lhs);
6297 rhs = gfc_copy_expr (code->expr1);
6298 gfc_add_vptr_component (rhs);
6299 gfc_add_def_init_component (rhs);
6301 sz = gfc_copy_expr (code->expr1);
6302 gfc_add_vptr_component (sz);
6303 gfc_add_size_component (sz);
6305 gfc_init_se (&dst, NULL);
6306 gfc_init_se (&src, NULL);
6307 gfc_init_se (&memsz, NULL);
6308 gfc_conv_expr (&dst, lhs);
6309 gfc_conv_expr (&src, rhs);
6310 gfc_conv_expr (&memsz, sz);
6311 gfc_add_block_to_block (&block, &src.pre);
6312 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6313 gfc_add_expr_to_block (&block, tmp);
6315 return gfc_finish_block (&block);
6319 /* Translate an assignment to a CLASS object
6320 (pointer or ordinary assignment). */
6323 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6330 gfc_start_block (&block);
6332 if (expr2->ts.type != BT_CLASS)
6334 /* Insert an additional assignment which sets the '_vptr' field. */
6335 gfc_symbol *vtab = NULL;
6338 lhs = gfc_copy_expr (expr1);
6339 gfc_add_vptr_component (lhs);
6341 if (expr2->ts.type == BT_DERIVED)
6342 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6343 else if (expr2->expr_type == EXPR_NULL)
6344 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6347 rhs = gfc_get_expr ();
6348 rhs->expr_type = EXPR_VARIABLE;
6349 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6353 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6354 gfc_add_expr_to_block (&block, tmp);
6356 gfc_free_expr (lhs);
6357 gfc_free_expr (rhs);
6360 /* Do the actual CLASS assignment. */
6361 if (expr2->ts.type == BT_CLASS)
6364 gfc_add_data_component (expr1);
6366 if (op == EXEC_ASSIGN)
6367 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6368 else if (op == EXEC_POINTER_ASSIGN)
6369 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6373 gfc_add_expr_to_block (&block, tmp);
6375 return gfc_finish_block (&block);