1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set_tuples. */
167 gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
168 tree desc, tree value,
173 type = TREE_TYPE (desc);
174 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
176 field = TYPE_FIELDS (type);
177 gcc_assert (DATA_FIELD == 0);
179 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
180 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc)
192 type = TREE_TYPE (desc);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
195 field = TYPE_FIELDS (type);
196 gcc_assert (DATA_FIELD == 0);
198 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
199 return build_fold_addr_expr (t);
203 gfc_conv_descriptor_offset (tree desc)
208 type = TREE_TYPE (desc);
209 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
211 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
212 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
214 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
218 gfc_conv_descriptor_dtype (tree desc)
223 type = TREE_TYPE (desc);
224 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
226 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
227 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
229 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
233 gfc_conv_descriptor_dimension (tree desc, tree dim)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
243 gcc_assert (field != NULL_TREE
244 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
247 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
248 tmp = gfc_build_array_ref (tmp, dim);
253 gfc_conv_descriptor_stride (tree desc, tree dim)
258 tmp = gfc_conv_descriptor_dimension (desc, dim);
259 field = TYPE_FIELDS (TREE_TYPE (tmp));
260 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
261 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
263 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
268 gfc_conv_descriptor_lbound (tree desc, tree dim)
273 tmp = gfc_conv_descriptor_dimension (desc, dim);
274 field = TYPE_FIELDS (TREE_TYPE (tmp));
275 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
276 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
278 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
283 gfc_conv_descriptor_ubound (tree desc, tree dim)
288 tmp = gfc_conv_descriptor_dimension (desc, dim);
289 field = TYPE_FIELDS (TREE_TYPE (tmp));
290 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
291 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
293 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
298 /* Build a null array descriptor constructor. */
301 gfc_build_null_descriptor (tree type)
306 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
307 gcc_assert (DATA_FIELD == 0);
308 field = TYPE_FIELDS (type);
310 /* Set a NULL data pointer. */
311 tmp = build_constructor_single (type, field, null_pointer_node);
312 TREE_CONSTANT (tmp) = 1;
313 TREE_INVARIANT (tmp) = 1;
314 /* All other fields are ignored. */
320 /* Cleanup those #defines. */
325 #undef DIMENSION_FIELD
326 #undef STRIDE_SUBFIELD
327 #undef LBOUND_SUBFIELD
328 #undef UBOUND_SUBFIELD
331 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
332 flags & 1 = Main loop body.
333 flags & 2 = temp copy loop. */
336 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
338 for (; ss != gfc_ss_terminator; ss = ss->next)
339 ss->useflags = flags;
342 static void gfc_free_ss (gfc_ss *);
345 /* Free a gfc_ss chain. */
348 gfc_free_ss_chain (gfc_ss * ss)
352 while (ss != gfc_ss_terminator)
354 gcc_assert (ss != NULL);
365 gfc_free_ss (gfc_ss * ss)
372 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
374 if (ss->data.info.subscript[n])
375 gfc_free_ss_chain (ss->data.info.subscript[n]);
387 /* Free all the SS associated with a loop. */
390 gfc_cleanup_loop (gfc_loopinfo * loop)
396 while (ss != gfc_ss_terminator)
398 gcc_assert (ss != NULL);
399 next = ss->loop_chain;
406 /* Associate a SS chain with a loop. */
409 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
413 if (head == gfc_ss_terminator)
417 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
419 if (ss->next == gfc_ss_terminator)
420 ss->loop_chain = loop->ss;
422 ss->loop_chain = ss->next;
424 gcc_assert (ss == gfc_ss_terminator);
429 /* Generate an initializer for a static pointer or allocatable array. */
432 gfc_trans_static_array_pointer (gfc_symbol * sym)
436 gcc_assert (TREE_STATIC (sym->backend_decl));
437 /* Just zero the data member. */
438 type = TREE_TYPE (sym->backend_decl);
439 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
443 /* If the bounds of SE's loop have not yet been set, see if they can be
444 determined from array spec AS, which is the array spec of a called
445 function. MAPPING maps the callee's dummy arguments to the values
446 that the caller is passing. Add any initialization and finalization
450 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
451 gfc_se * se, gfc_array_spec * as)
459 if (as && as->type == AS_EXPLICIT)
460 for (dim = 0; dim < se->loop->dimen; dim++)
462 n = se->loop->order[dim];
463 if (se->loop->to[n] == NULL_TREE)
465 /* Evaluate the lower bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* ...and the upper bound. */
473 gfc_init_se (&tmpse, NULL);
474 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
475 gfc_add_block_to_block (&se->pre, &tmpse.pre);
476 gfc_add_block_to_block (&se->post, &tmpse.post);
479 /* Set the upper bound of the loop to UPPER - LOWER. */
480 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
481 tmp = gfc_evaluate_now (tmp, &se->pre);
482 se->loop->to[n] = tmp;
488 /* Generate code to allocate an array temporary, or create a variable to
489 hold the data. If size is NULL, zero the descriptor so that the
490 callee will allocate the array. If DEALLOC is true, also generate code to
491 free the array afterwards.
493 Initialization code is added to PRE and finalization code to POST.
494 DYNAMIC is true if the caller may want to extend the array later
495 using realloc. This prevents us from putting the array on the stack. */
498 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
499 gfc_ss_info * info, tree size, tree nelem,
500 bool dynamic, bool dealloc)
506 desc = info->descriptor;
507 info->offset = gfc_index_zero_node;
508 if (size == NULL_TREE || integer_zerop (size))
510 /* A callee allocated array. */
511 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
516 /* Allocate the temporary. */
517 onstack = !dynamic && gfc_can_put_var_on_stack (size);
521 /* Make a temporary variable to hold the data. */
522 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
524 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
526 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
528 tmp = gfc_create_var (tmp, "A");
529 tmp = build_fold_addr_expr (tmp);
530 gfc_conv_descriptor_data_set (pre, desc, tmp);
534 /* Allocate memory to hold the data. */
535 tmp = gfc_call_malloc (pre, NULL, size);
536 tmp = gfc_evaluate_now (tmp, pre);
537 gfc_conv_descriptor_data_set (pre, desc, tmp);
540 info->data = gfc_conv_descriptor_data_get (desc);
542 /* The offset is zero because we create temporaries with a zero
544 tmp = gfc_conv_descriptor_offset (desc);
545 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
547 if (dealloc && !onstack)
549 /* Free the temporary. */
550 tmp = gfc_conv_descriptor_data_get (desc);
551 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
552 gfc_add_expr_to_block (post, tmp);
557 /* Generate code to create and initialize the descriptor for a temporary
558 array. This is used for both temporaries needed by the scalarizer, and
559 functions returning arrays. Adjusts the loop variables to be
560 zero-based, and calculates the loop bounds for callee allocated arrays.
561 Allocate the array unless it's callee allocated (we have a callee
562 allocated array if 'callee_alloc' is true, or if loop->to[n] is
563 NULL_TREE for any n). Also fills in the descriptor, data and offset
564 fields of info if known. Returns the size of the array, or NULL for a
565 callee allocated array.
567 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
571 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
572 gfc_loopinfo * loop, gfc_ss_info * info,
573 tree eltype, bool dynamic, bool dealloc,
586 gcc_assert (info->dimen > 0);
587 /* Set the lower bound to zero. */
588 for (dim = 0; dim < info->dimen; dim++)
590 n = loop->order[dim];
591 if (n < loop->temp_dim)
592 gcc_assert (integer_zerop (loop->from[n]));
595 /* Callee allocated arrays may not have a known bound yet. */
597 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
598 loop->to[n], loop->from[n]);
599 loop->from[n] = gfc_index_zero_node;
602 info->delta[dim] = gfc_index_zero_node;
603 info->start[dim] = gfc_index_zero_node;
604 info->end[dim] = gfc_index_zero_node;
605 info->stride[dim] = gfc_index_one_node;
606 info->dim[dim] = dim;
609 /* Initialize the descriptor. */
611 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
612 desc = gfc_create_var (type, "atmp");
613 GFC_DECL_PACKED_ARRAY (desc) = 1;
615 info->descriptor = desc;
616 size = gfc_index_one_node;
618 /* Fill in the array dtype. */
619 tmp = gfc_conv_descriptor_dtype (desc);
620 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
623 Fill in the bounds and stride. This is a packed array, so:
626 for (n = 0; n < rank; n++)
629 delta = ubound[n] + 1 - lbound[n];
632 size = size * sizeof(element);
637 for (n = 0; n < info->dimen; n++)
639 if (loop->to[n] == NULL_TREE)
641 /* For a callee allocated array express the loop bounds in terms
642 of the descriptor fields. */
643 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
644 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
645 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
651 /* Store the stride and bound components in the descriptor. */
652 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
653 gfc_add_modify_expr (pre, tmp, size);
655 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
656 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
658 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
659 gfc_add_modify_expr (pre, tmp, loop->to[n]);
661 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
662 loop->to[n], gfc_index_one_node);
664 /* Check whether the size for this dimension is negative. */
665 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
666 gfc_index_zero_node);
667 cond = gfc_evaluate_now (cond, pre);
672 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
674 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
675 size = gfc_evaluate_now (size, pre);
678 /* Get the size of the array. */
680 if (size && !callee_alloc)
682 /* If or_expr is true, then the extent in at least one
683 dimension is zero and the size is set to zero. */
684 size = fold_build3 (COND_EXPR, gfc_array_index_type,
685 or_expr, gfc_index_zero_node, size);
688 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
689 fold_convert (gfc_array_index_type,
690 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
698 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
701 if (info->dimen > loop->temp_dim)
702 loop->temp_dim = info->dimen;
708 /* Generate code to transpose array EXPR by creating a new descriptor
709 in which the dimension specifications have been reversed. */
712 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
714 tree dest, src, dest_index, src_index;
716 gfc_ss_info *dest_info, *src_info;
717 gfc_ss *dest_ss, *src_ss;
723 src_ss = gfc_walk_expr (expr);
726 src_info = &src_ss->data.info;
727 dest_info = &dest_ss->data.info;
728 gcc_assert (dest_info->dimen == 2);
729 gcc_assert (src_info->dimen == 2);
731 /* Get a descriptor for EXPR. */
732 gfc_init_se (&src_se, NULL);
733 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
734 gfc_add_block_to_block (&se->pre, &src_se.pre);
735 gfc_add_block_to_block (&se->post, &src_se.post);
738 /* Allocate a new descriptor for the return value. */
739 dest = gfc_create_var (TREE_TYPE (src), "atmp");
740 dest_info->descriptor = dest;
743 /* Copy across the dtype field. */
744 gfc_add_modify_expr (&se->pre,
745 gfc_conv_descriptor_dtype (dest),
746 gfc_conv_descriptor_dtype (src));
748 /* Copy the dimension information, renumbering dimension 1 to 0 and
750 for (n = 0; n < 2; n++)
752 dest_info->delta[n] = gfc_index_zero_node;
753 dest_info->start[n] = gfc_index_zero_node;
754 dest_info->end[n] = gfc_index_zero_node;
755 dest_info->stride[n] = gfc_index_one_node;
756 dest_info->dim[n] = n;
758 dest_index = gfc_rank_cst[n];
759 src_index = gfc_rank_cst[1 - n];
761 gfc_add_modify_expr (&se->pre,
762 gfc_conv_descriptor_stride (dest, dest_index),
763 gfc_conv_descriptor_stride (src, src_index));
765 gfc_add_modify_expr (&se->pre,
766 gfc_conv_descriptor_lbound (dest, dest_index),
767 gfc_conv_descriptor_lbound (src, src_index));
769 gfc_add_modify_expr (&se->pre,
770 gfc_conv_descriptor_ubound (dest, dest_index),
771 gfc_conv_descriptor_ubound (src, src_index));
775 gcc_assert (integer_zerop (loop->from[n]));
776 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
777 gfc_conv_descriptor_ubound (dest, dest_index),
778 gfc_conv_descriptor_lbound (dest, dest_index));
782 /* Copy the data pointer. */
783 dest_info->data = gfc_conv_descriptor_data_get (src);
784 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
786 /* Copy the offset. This is not changed by transposition: the top-left
787 element is still at the same offset as before. */
788 dest_info->offset = gfc_conv_descriptor_offset (src);
789 gfc_add_modify_expr (&se->pre,
790 gfc_conv_descriptor_offset (dest),
793 if (dest_info->dimen > loop->temp_dim)
794 loop->temp_dim = dest_info->dimen;
798 /* Return the number of iterations in a loop that starts at START,
799 ends at END, and has step STEP. */
802 gfc_get_iteration_count (tree start, tree end, tree step)
807 type = TREE_TYPE (step);
808 tmp = fold_build2 (MINUS_EXPR, type, end, start);
809 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
810 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
811 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
812 return fold_convert (gfc_array_index_type, tmp);
816 /* Extend the data in array DESC by EXTRA elements. */
819 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
826 if (integer_zerop (extra))
829 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
831 /* Add EXTRA to the upper bound. */
832 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
833 gfc_add_modify_expr (pblock, ubound, tmp);
835 /* Get the value of the current data pointer. */
836 arg0 = gfc_conv_descriptor_data_get (desc);
838 /* Calculate the new array size. */
839 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
840 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
841 arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
842 fold_convert (gfc_array_index_type, size));
844 /* Pick the realloc function. */
845 if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8)
846 tmp = gfor_fndecl_internal_realloc;
850 /* Set the new data pointer. */
851 tmp = build_call_expr (tmp, 2, arg0, arg1);
852 gfc_conv_descriptor_data_set (pblock, desc, tmp);
856 /* Return true if the bounds of iterator I can only be determined
860 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
862 return (i->start->expr_type != EXPR_CONSTANT
863 || i->end->expr_type != EXPR_CONSTANT
864 || i->step->expr_type != EXPR_CONSTANT);
868 /* Split the size of constructor element EXPR into the sum of two terms,
869 one of which can be determined at compile time and one of which must
870 be calculated at run time. Set *SIZE to the former and return true
871 if the latter might be nonzero. */
874 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
876 if (expr->expr_type == EXPR_ARRAY)
877 return gfc_get_array_constructor_size (size, expr->value.constructor);
878 else if (expr->rank > 0)
880 /* Calculate everything at run time. */
881 mpz_set_ui (*size, 0);
886 /* A single element. */
887 mpz_set_ui (*size, 1);
893 /* Like gfc_get_array_constructor_element_size, but applied to the whole
894 of array constructor C. */
897 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
904 mpz_set_ui (*size, 0);
909 for (; c; c = c->next)
912 if (i && gfc_iterator_has_dynamic_bounds (i))
916 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
919 /* Multiply the static part of the element size by the
920 number of iterations. */
921 mpz_sub (val, i->end->value.integer, i->start->value.integer);
922 mpz_fdiv_q (val, val, i->step->value.integer);
923 mpz_add_ui (val, val, 1);
924 if (mpz_sgn (val) > 0)
925 mpz_mul (len, len, val);
929 mpz_add (*size, *size, len);
938 /* Make sure offset is a variable. */
941 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
944 /* We should have already created the offset variable. We cannot
945 create it here because we may be in an inner scope. */
946 gcc_assert (*offsetvar != NULL_TREE);
947 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
948 *poffset = *offsetvar;
949 TREE_USED (*offsetvar) = 1;
953 /* Assign an element of an array constructor. */
956 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
957 tree offset, gfc_se * se, gfc_expr * expr)
961 gfc_conv_expr (se, expr);
963 /* Store the value. */
964 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
965 tmp = gfc_build_array_ref (tmp, offset);
966 if (expr->ts.type == BT_CHARACTER)
968 gfc_conv_string_parameter (se);
969 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
971 /* The temporary is an array of pointers. */
972 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
973 gfc_add_modify_expr (&se->pre, tmp, se->expr);
977 /* The temporary is an array of string values. */
978 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
979 /* We know the temporary and the value will be the same length,
980 so can use memcpy. */
981 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
982 tmp, se->expr, se->string_length);
983 gfc_add_expr_to_block (&se->pre, tmp);
988 /* TODO: Should the frontend already have done this conversion? */
989 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
990 gfc_add_modify_expr (&se->pre, tmp, se->expr);
993 gfc_add_block_to_block (pblock, &se->pre);
994 gfc_add_block_to_block (pblock, &se->post);
998 /* Add the contents of an array to the constructor. DYNAMIC is as for
999 gfc_trans_array_constructor_value. */
1002 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1003 tree type ATTRIBUTE_UNUSED,
1004 tree desc, gfc_expr * expr,
1005 tree * poffset, tree * offsetvar,
1016 /* We need this to be a variable so we can increment it. */
1017 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1019 gfc_init_se (&se, NULL);
1021 /* Walk the array expression. */
1022 ss = gfc_walk_expr (expr);
1023 gcc_assert (ss != gfc_ss_terminator);
1025 /* Initialize the scalarizer. */
1026 gfc_init_loopinfo (&loop);
1027 gfc_add_ss_to_loop (&loop, ss);
1029 /* Initialize the loop. */
1030 gfc_conv_ss_startstride (&loop);
1031 gfc_conv_loop_setup (&loop);
1033 /* Make sure the constructed array has room for the new data. */
1036 /* Set SIZE to the total number of elements in the subarray. */
1037 size = gfc_index_one_node;
1038 for (n = 0; n < loop.dimen; n++)
1040 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1041 gfc_index_one_node);
1042 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1045 /* Grow the constructed array by SIZE elements. */
1046 gfc_grow_array (&loop.pre, desc, size);
1049 /* Make the loop body. */
1050 gfc_mark_ss_chain_used (ss, 1);
1051 gfc_start_scalarized_body (&loop, &body);
1052 gfc_copy_loopinfo_to_se (&se, &loop);
1055 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1056 gcc_assert (se.ss == gfc_ss_terminator);
1058 /* Increment the offset. */
1059 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1060 gfc_add_modify_expr (&body, *poffset, tmp);
1062 /* Finish the loop. */
1063 gfc_trans_scalarizing_loops (&loop, &body);
1064 gfc_add_block_to_block (&loop.pre, &loop.post);
1065 tmp = gfc_finish_block (&loop.pre);
1066 gfc_add_expr_to_block (pblock, tmp);
1068 gfc_cleanup_loop (&loop);
1072 /* Assign the values to the elements of an array constructor. DYNAMIC
1073 is true if descriptor DESC only contains enough data for the static
1074 size calculated by gfc_get_array_constructor_size. When true, memory
1075 for the dynamic parts must be allocated using realloc. */
1078 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1079 tree desc, gfc_constructor * c,
1080 tree * poffset, tree * offsetvar,
1089 for (; c; c = c->next)
1091 /* If this is an iterator or an array, the offset must be a variable. */
1092 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1093 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1095 gfc_start_block (&body);
1097 if (c->expr->expr_type == EXPR_ARRAY)
1099 /* Array constructors can be nested. */
1100 gfc_trans_array_constructor_value (&body, type, desc,
1101 c->expr->value.constructor,
1102 poffset, offsetvar, dynamic);
1104 else if (c->expr->rank > 0)
1106 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1107 poffset, offsetvar, dynamic);
1111 /* This code really upsets the gimplifier so don't bother for now. */
1118 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1125 /* Scalar values. */
1126 gfc_init_se (&se, NULL);
1127 gfc_trans_array_ctor_element (&body, desc, *poffset,
1130 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1131 *poffset, gfc_index_one_node);
1135 /* Collect multiple scalar constants into a constructor. */
1143 /* Count the number of consecutive scalar constants. */
1144 while (p && !(p->iterator
1145 || p->expr->expr_type != EXPR_CONSTANT))
1147 gfc_init_se (&se, NULL);
1148 gfc_conv_constant (&se, p->expr);
1149 if (p->expr->ts.type == BT_CHARACTER
1150 && POINTER_TYPE_P (type))
1152 /* For constant character array constructors we build
1153 an array of pointers. */
1154 se.expr = gfc_build_addr_expr (pchar_type_node,
1158 list = tree_cons (NULL_TREE, se.expr, list);
1163 bound = build_int_cst (NULL_TREE, n - 1);
1164 /* Create an array type to hold them. */
1165 tmptype = build_range_type (gfc_array_index_type,
1166 gfc_index_zero_node, bound);
1167 tmptype = build_array_type (type, tmptype);
1169 init = build_constructor_from_list (tmptype, nreverse (list));
1170 TREE_CONSTANT (init) = 1;
1171 TREE_INVARIANT (init) = 1;
1172 TREE_STATIC (init) = 1;
1173 /* Create a static variable to hold the data. */
1174 tmp = gfc_create_var (tmptype, "data");
1175 TREE_STATIC (tmp) = 1;
1176 TREE_CONSTANT (tmp) = 1;
1177 TREE_INVARIANT (tmp) = 1;
1178 TREE_READONLY (tmp) = 1;
1179 DECL_INITIAL (tmp) = init;
1182 /* Use BUILTIN_MEMCPY to assign the values. */
1183 tmp = gfc_conv_descriptor_data_get (desc);
1184 tmp = build_fold_indirect_ref (tmp);
1185 tmp = gfc_build_array_ref (tmp, *poffset);
1186 tmp = build_fold_addr_expr (tmp);
1187 init = build_fold_addr_expr (init);
1189 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1190 bound = build_int_cst (NULL_TREE, n * size);
1191 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1193 gfc_add_expr_to_block (&body, tmp);
1195 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1197 build_int_cst (gfc_array_index_type, n));
1199 if (!INTEGER_CST_P (*poffset))
1201 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1202 *poffset = *offsetvar;
1206 /* The frontend should already have done any expansions possible
1210 /* Pass the code as is. */
1211 tmp = gfc_finish_block (&body);
1212 gfc_add_expr_to_block (pblock, tmp);
1216 /* Build the implied do-loop. */
1226 loopbody = gfc_finish_block (&body);
1228 gfc_init_se (&se, NULL);
1229 gfc_conv_expr (&se, c->iterator->var);
1230 gfc_add_block_to_block (pblock, &se.pre);
1233 /* Make a temporary, store the current value in that
1234 and return it, once the loop is done. */
1235 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1236 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1238 /* Initialize the loop. */
1239 gfc_init_se (&se, NULL);
1240 gfc_conv_expr_val (&se, c->iterator->start);
1241 gfc_add_block_to_block (pblock, &se.pre);
1242 gfc_add_modify_expr (pblock, loopvar, se.expr);
1244 gfc_init_se (&se, NULL);
1245 gfc_conv_expr_val (&se, c->iterator->end);
1246 gfc_add_block_to_block (pblock, &se.pre);
1247 end = gfc_evaluate_now (se.expr, pblock);
1249 gfc_init_se (&se, NULL);
1250 gfc_conv_expr_val (&se, c->iterator->step);
1251 gfc_add_block_to_block (pblock, &se.pre);
1252 step = gfc_evaluate_now (se.expr, pblock);
1254 /* If this array expands dynamically, and the number of iterations
1255 is not constant, we won't have allocated space for the static
1256 part of C->EXPR's size. Do that now. */
1257 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1259 /* Get the number of iterations. */
1260 tmp = gfc_get_iteration_count (loopvar, end, step);
1262 /* Get the static part of C->EXPR's size. */
1263 gfc_get_array_constructor_element_size (&size, c->expr);
1264 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1266 /* Grow the array by TMP * TMP2 elements. */
1267 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1268 gfc_grow_array (pblock, desc, tmp);
1271 /* Generate the loop body. */
1272 exit_label = gfc_build_label_decl (NULL_TREE);
1273 gfc_start_block (&body);
1275 /* Generate the exit condition. Depending on the sign of
1276 the step variable we have to generate the correct
1278 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1279 build_int_cst (TREE_TYPE (step), 0));
1280 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1281 build2 (GT_EXPR, boolean_type_node,
1283 build2 (LT_EXPR, boolean_type_node,
1285 tmp = build1_v (GOTO_EXPR, exit_label);
1286 TREE_USED (exit_label) = 1;
1287 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1288 gfc_add_expr_to_block (&body, tmp);
1290 /* The main loop body. */
1291 gfc_add_expr_to_block (&body, loopbody);
1293 /* Increase loop variable by step. */
1294 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1295 gfc_add_modify_expr (&body, loopvar, tmp);
1297 /* Finish the loop. */
1298 tmp = gfc_finish_block (&body);
1299 tmp = build1_v (LOOP_EXPR, tmp);
1300 gfc_add_expr_to_block (pblock, tmp);
1302 /* Add the exit label. */
1303 tmp = build1_v (LABEL_EXPR, exit_label);
1304 gfc_add_expr_to_block (pblock, tmp);
1306 /* Restore the original value of the loop counter. */
1307 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1314 /* Figure out the string length of a variable reference expression.
1315 Used by get_array_ctor_strlen. */
1318 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1324 /* Don't bother if we already know the length is a constant. */
1325 if (*len && INTEGER_CST_P (*len))
1328 ts = &expr->symtree->n.sym->ts;
1329 for (ref = expr->ref; ref; ref = ref->next)
1334 /* Array references don't change the string length. */
1338 /* Use the length of the component. */
1339 ts = &ref->u.c.component->ts;
1343 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1344 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1346 mpz_init_set_ui (char_len, 1);
1347 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1348 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1349 *len = gfc_conv_mpz_to_tree (char_len,
1350 gfc_default_character_kind);
1351 *len = convert (gfc_charlen_type_node, *len);
1352 mpz_clear (char_len);
1356 /* TODO: Substrings are tricky because we can't evaluate the
1357 expression more than once. For now we just give up, and hope
1358 we can figure it out elsewhere. */
1363 *len = ts->cl->backend_decl;
1367 /* A catch-all to obtain the string length for anything that is not a
1368 constant, array or variable. */
1370 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1375 /* Don't bother if we already know the length is a constant. */
1376 if (*len && INTEGER_CST_P (*len))
1379 if (!e->ref && e->ts.cl->length
1380 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1383 gfc_conv_const_charlen (e->ts.cl);
1384 *len = e->ts.cl->backend_decl;
1388 /* Otherwise, be brutal even if inefficient. */
1389 ss = gfc_walk_expr (e);
1390 gfc_init_se (&se, NULL);
1392 /* No function call, in case of side effects. */
1393 se.no_function_call = 1;
1394 if (ss == gfc_ss_terminator)
1395 gfc_conv_expr (&se, e);
1397 gfc_conv_expr_descriptor (&se, e, ss);
1399 /* Fix the value. */
1400 *len = gfc_evaluate_now (se.string_length, &se.pre);
1402 gfc_add_block_to_block (block, &se.pre);
1403 gfc_add_block_to_block (block, &se.post);
1405 e->ts.cl->backend_decl = *len;
1410 /* Figure out the string length of a character array constructor.
1411 Returns TRUE if all elements are character constants. */
1414 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1419 for (; c; c = c->next)
1421 switch (c->expr->expr_type)
1424 if (!(*len && INTEGER_CST_P (*len)))
1425 *len = build_int_cstu (gfc_charlen_type_node,
1426 c->expr->value.character.length);
1430 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1436 get_array_ctor_var_strlen (c->expr, len);
1441 get_array_ctor_all_strlen (block, c->expr, len);
1449 /* Check whether the array constructor C consists entirely of constant
1450 elements, and if so returns the number of those elements, otherwise
1451 return zero. Note, an empty or NULL array constructor returns zero. */
1453 unsigned HOST_WIDE_INT
1454 gfc_constant_array_constructor_p (gfc_constructor * c)
1456 unsigned HOST_WIDE_INT nelem = 0;
1461 || c->expr->rank > 0
1462 || c->expr->expr_type != EXPR_CONSTANT)
1471 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1472 and the tree type of it's elements, TYPE, return a static constant
1473 variable that is compile-time initialized. */
1476 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1478 tree tmptype, list, init, tmp;
1479 HOST_WIDE_INT nelem;
1485 /* First traverse the constructor list, converting the constants
1486 to tree to build an initializer. */
1489 c = expr->value.constructor;
1492 gfc_init_se (&se, NULL);
1493 gfc_conv_constant (&se, c->expr);
1494 if (c->expr->ts.type == BT_CHARACTER
1495 && POINTER_TYPE_P (type))
1496 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1497 list = tree_cons (NULL_TREE, se.expr, list);
1502 /* Next determine the tree type for the array. We use the gfortran
1503 front-end's gfc_get_nodesc_array_type in order to create a suitable
1504 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1506 memset (&as, 0, sizeof (gfc_array_spec));
1508 as.rank = expr->rank;
1509 as.type = AS_EXPLICIT;
1512 as.lower[0] = gfc_int_expr (0);
1513 as.upper[0] = gfc_int_expr (nelem - 1);
1516 for (i = 0; i < expr->rank; i++)
1518 int tmp = (int) mpz_get_si (expr->shape[i]);
1519 as.lower[i] = gfc_int_expr (0);
1520 as.upper[i] = gfc_int_expr (tmp - 1);
1523 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1525 init = build_constructor_from_list (tmptype, nreverse (list));
1527 TREE_CONSTANT (init) = 1;
1528 TREE_INVARIANT (init) = 1;
1529 TREE_STATIC (init) = 1;
1531 tmp = gfc_create_var (tmptype, "A");
1532 TREE_STATIC (tmp) = 1;
1533 TREE_CONSTANT (tmp) = 1;
1534 TREE_INVARIANT (tmp) = 1;
1535 TREE_READONLY (tmp) = 1;
1536 DECL_INITIAL (tmp) = init;
1542 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1543 This mostly initializes the scalarizer state info structure with the
1544 appropriate values to directly use the array created by the function
1545 gfc_build_constant_array_constructor. */
1548 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1549 gfc_ss * ss, tree type)
1555 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1557 info = &ss->data.info;
1559 info->descriptor = tmp;
1560 info->data = build_fold_addr_expr (tmp);
1561 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1564 for (i = 0; i < info->dimen; i++)
1566 info->delta[i] = gfc_index_zero_node;
1567 info->start[i] = gfc_index_zero_node;
1568 info->end[i] = gfc_index_zero_node;
1569 info->stride[i] = gfc_index_one_node;
1573 if (info->dimen > loop->temp_dim)
1574 loop->temp_dim = info->dimen;
1577 /* Helper routine of gfc_trans_array_constructor to determine if the
1578 bounds of the loop specified by LOOP are constant and simple enough
1579 to use with gfc_trans_constant_array_constructor. Returns the
1580 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1583 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1585 tree size = gfc_index_one_node;
1589 for (i = 0; i < loop->dimen; i++)
1591 /* If the bounds aren't constant, return NULL_TREE. */
1592 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1594 if (!integer_zerop (loop->from[i]))
1596 /* Only allow nonzero "from" in one-dimensional arrays. */
1597 if (loop->dimen != 1)
1599 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1600 loop->to[i], loop->from[i]);
1604 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1605 tmp, gfc_index_one_node);
1606 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1613 /* Array constructors are handled by constructing a temporary, then using that
1614 within the scalarization loop. This is not optimal, but seems by far the
1618 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1627 ss->data.info.dimen = loop->dimen;
1629 c = ss->expr->value.constructor;
1630 if (ss->expr->ts.type == BT_CHARACTER)
1632 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1633 if (!ss->string_length)
1634 gfc_todo_error ("complex character array constructors");
1636 /* It is surprising but still possible to wind up with expressions that
1637 lack a character length.
1638 TODO Find the offending part of the front end and cure this properly.
1639 Concatenation involving arrays is the main culprit. */
1640 if (!ss->expr->ts.cl)
1642 ss->expr->ts.cl = gfc_get_charlen ();
1643 ss->expr->ts.cl->next = gfc_current_ns->cl_list;
1644 gfc_current_ns->cl_list = ss->expr->ts.cl->next;
1647 ss->expr->ts.cl->backend_decl = ss->string_length;
1649 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1651 type = build_pointer_type (type);
1654 type = gfc_typenode_for_spec (&ss->expr->ts);
1656 /* See if the constructor determines the loop bounds. */
1659 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1661 /* We have a multidimensional parameter. */
1663 for (n = 0; n < ss->expr->rank; n++)
1665 loop->from[n] = gfc_index_zero_node;
1666 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1667 gfc_index_integer_kind);
1668 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1669 loop->to[n], gfc_index_one_node);
1673 if (loop->to[0] == NULL_TREE)
1677 /* We should have a 1-dimensional, zero-based loop. */
1678 gcc_assert (loop->dimen == 1);
1679 gcc_assert (integer_zerop (loop->from[0]));
1681 /* Split the constructor size into a static part and a dynamic part.
1682 Allocate the static size up-front and record whether the dynamic
1683 size might be nonzero. */
1685 dynamic = gfc_get_array_constructor_size (&size, c);
1686 mpz_sub_ui (size, size, 1);
1687 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1691 /* Special case constant array constructors. */
1694 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1697 tree size = constant_array_constructor_loop_size (loop);
1698 if (size && compare_tree_int (size, nelem) == 0)
1700 gfc_trans_constant_array_constructor (loop, ss, type);
1706 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1707 type, dynamic, true, false);
1709 desc = ss->data.info.descriptor;
1710 offset = gfc_index_zero_node;
1711 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1712 TREE_NO_WARNING (offsetvar) = 1;
1713 TREE_USED (offsetvar) = 0;
1714 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1715 &offset, &offsetvar, dynamic);
1717 /* If the array grows dynamically, the upper bound of the loop variable
1718 is determined by the array's final upper bound. */
1720 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1722 if (TREE_USED (offsetvar))
1723 pushdecl (offsetvar);
1725 gcc_assert (INTEGER_CST_P (offset));
1727 /* Disable bound checking for now because it's probably broken. */
1728 if (flag_bounds_check)
1736 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1737 called after evaluating all of INFO's vector dimensions. Go through
1738 each such vector dimension and see if we can now fill in any missing
1742 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1751 for (n = 0; n < loop->dimen; n++)
1754 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1755 && loop->to[n] == NULL)
1757 /* Loop variable N indexes vector dimension DIM, and we don't
1758 yet know the upper bound of loop variable N. Set it to the
1759 difference between the vector's upper and lower bounds. */
1760 gcc_assert (loop->from[n] == gfc_index_zero_node);
1761 gcc_assert (info->subscript[dim]
1762 && info->subscript[dim]->type == GFC_SS_VECTOR);
1764 gfc_init_se (&se, NULL);
1765 desc = info->subscript[dim]->data.info.descriptor;
1766 zero = gfc_rank_cst[0];
1767 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1768 gfc_conv_descriptor_ubound (desc, zero),
1769 gfc_conv_descriptor_lbound (desc, zero));
1770 tmp = gfc_evaluate_now (tmp, &loop->pre);
1777 /* Add the pre and post chains for all the scalar expressions in a SS chain
1778 to loop. This is called after the loop parameters have been calculated,
1779 but before the actual scalarizing loops. */
1782 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1787 /* TODO: This can generate bad code if there are ordering dependencies.
1788 eg. a callee allocated function and an unknown size constructor. */
1789 gcc_assert (ss != NULL);
1791 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1798 /* Scalar expression. Evaluate this now. This includes elemental
1799 dimension indices, but not array section bounds. */
1800 gfc_init_se (&se, NULL);
1801 gfc_conv_expr (&se, ss->expr);
1802 gfc_add_block_to_block (&loop->pre, &se.pre);
1804 if (ss->expr->ts.type != BT_CHARACTER)
1806 /* Move the evaluation of scalar expressions outside the
1807 scalarization loop. */
1809 se.expr = convert(gfc_array_index_type, se.expr);
1810 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1811 gfc_add_block_to_block (&loop->pre, &se.post);
1814 gfc_add_block_to_block (&loop->post, &se.post);
1816 ss->data.scalar.expr = se.expr;
1817 ss->string_length = se.string_length;
1820 case GFC_SS_REFERENCE:
1821 /* Scalar reference. Evaluate this now. */
1822 gfc_init_se (&se, NULL);
1823 gfc_conv_expr_reference (&se, ss->expr);
1824 gfc_add_block_to_block (&loop->pre, &se.pre);
1825 gfc_add_block_to_block (&loop->post, &se.post);
1827 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1828 ss->string_length = se.string_length;
1831 case GFC_SS_SECTION:
1832 /* Add the expressions for scalar and vector subscripts. */
1833 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1834 if (ss->data.info.subscript[n])
1835 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1837 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1841 /* Get the vector's descriptor and store it in SS. */
1842 gfc_init_se (&se, NULL);
1843 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1844 gfc_add_block_to_block (&loop->pre, &se.pre);
1845 gfc_add_block_to_block (&loop->post, &se.post);
1846 ss->data.info.descriptor = se.expr;
1849 case GFC_SS_INTRINSIC:
1850 gfc_add_intrinsic_ss_code (loop, ss);
1853 case GFC_SS_FUNCTION:
1854 /* Array function return value. We call the function and save its
1855 result in a temporary for use inside the loop. */
1856 gfc_init_se (&se, NULL);
1859 gfc_conv_expr (&se, ss->expr);
1860 gfc_add_block_to_block (&loop->pre, &se.pre);
1861 gfc_add_block_to_block (&loop->post, &se.post);
1862 ss->string_length = se.string_length;
1865 case GFC_SS_CONSTRUCTOR:
1866 gfc_trans_array_constructor (loop, ss);
1870 case GFC_SS_COMPONENT:
1871 /* Do nothing. These are handled elsewhere. */
1881 /* Translate expressions for the descriptor and data pointer of a SS. */
1885 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1890 /* Get the descriptor for the array to be scalarized. */
1891 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1892 gfc_init_se (&se, NULL);
1893 se.descriptor_only = 1;
1894 gfc_conv_expr_lhs (&se, ss->expr);
1895 gfc_add_block_to_block (block, &se.pre);
1896 ss->data.info.descriptor = se.expr;
1897 ss->string_length = se.string_length;
1901 /* Also the data pointer. */
1902 tmp = gfc_conv_array_data (se.expr);
1903 /* If this is a variable or address of a variable we use it directly.
1904 Otherwise we must evaluate it now to avoid breaking dependency
1905 analysis by pulling the expressions for elemental array indices
1908 || (TREE_CODE (tmp) == ADDR_EXPR
1909 && DECL_P (TREE_OPERAND (tmp, 0)))))
1910 tmp = gfc_evaluate_now (tmp, block);
1911 ss->data.info.data = tmp;
1913 tmp = gfc_conv_array_offset (se.expr);
1914 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1919 /* Initialize a gfc_loopinfo structure. */
1922 gfc_init_loopinfo (gfc_loopinfo * loop)
1926 memset (loop, 0, sizeof (gfc_loopinfo));
1927 gfc_init_block (&loop->pre);
1928 gfc_init_block (&loop->post);
1930 /* Initially scalarize in order. */
1931 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1934 loop->ss = gfc_ss_terminator;
1938 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1942 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1948 /* Return an expression for the data pointer of an array. */
1951 gfc_conv_array_data (tree descriptor)
1955 type = TREE_TYPE (descriptor);
1956 if (GFC_ARRAY_TYPE_P (type))
1958 if (TREE_CODE (type) == POINTER_TYPE)
1962 /* Descriptorless arrays. */
1963 return build_fold_addr_expr (descriptor);
1967 return gfc_conv_descriptor_data_get (descriptor);
1971 /* Return an expression for the base offset of an array. */
1974 gfc_conv_array_offset (tree descriptor)
1978 type = TREE_TYPE (descriptor);
1979 if (GFC_ARRAY_TYPE_P (type))
1980 return GFC_TYPE_ARRAY_OFFSET (type);
1982 return gfc_conv_descriptor_offset (descriptor);
1986 /* Get an expression for the array stride. */
1989 gfc_conv_array_stride (tree descriptor, int dim)
1994 type = TREE_TYPE (descriptor);
1996 /* For descriptorless arrays use the array size. */
1997 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1998 if (tmp != NULL_TREE)
2001 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2006 /* Like gfc_conv_array_stride, but for the lower bound. */
2009 gfc_conv_array_lbound (tree descriptor, int dim)
2014 type = TREE_TYPE (descriptor);
2016 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2017 if (tmp != NULL_TREE)
2020 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2025 /* Like gfc_conv_array_stride, but for the upper bound. */
2028 gfc_conv_array_ubound (tree descriptor, int dim)
2033 type = TREE_TYPE (descriptor);
2035 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2036 if (tmp != NULL_TREE)
2039 /* This should only ever happen when passing an assumed shape array
2040 as an actual parameter. The value will never be used. */
2041 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2042 return gfc_index_zero_node;
2044 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2049 /* Generate code to perform an array index bound check. */
2052 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2053 locus * where, bool check_upper)
2058 const char * name = NULL;
2060 if (!flag_bounds_check)
2063 index = gfc_evaluate_now (index, &se->pre);
2065 /* We find a name for the error message. */
2067 name = se->ss->expr->symtree->name;
2069 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2070 && se->loop->ss->expr->symtree)
2071 name = se->loop->ss->expr->symtree->name;
2073 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2074 && se->loop->ss->loop_chain->expr
2075 && se->loop->ss->loop_chain->expr->symtree)
2076 name = se->loop->ss->loop_chain->expr->symtree->name;
2078 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2079 && se->loop->ss->loop_chain->expr->symtree)
2080 name = se->loop->ss->loop_chain->expr->symtree->name;
2082 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2084 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2085 && se->loop->ss->expr->value.function.name)
2086 name = se->loop->ss->expr->value.function.name;
2088 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2089 || se->loop->ss->type == GFC_SS_SCALAR)
2090 name = "unnamed constant";
2093 /* Check lower bound. */
2094 tmp = gfc_conv_array_lbound (descriptor, n);
2095 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2097 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2098 gfc_msg_fault, name, n+1);
2100 asprintf (&msg, "%s, lower bound of dimension %d exceeded",
2101 gfc_msg_fault, n+1);
2102 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2105 /* Check upper bound. */
2108 tmp = gfc_conv_array_ubound (descriptor, n);
2109 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2111 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2112 " exceeded", gfc_msg_fault, name, n+1);
2114 asprintf (&msg, "%s, upper bound of dimension %d exceeded",
2115 gfc_msg_fault, n+1);
2116 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2124 /* Return the offset for an index. Performs bound checking for elemental
2125 dimensions. Single element references are processed separately. */
2128 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2129 gfc_array_ref * ar, tree stride)
2135 /* Get the index into the array for this dimension. */
2138 gcc_assert (ar->type != AR_ELEMENT);
2139 switch (ar->dimen_type[dim])
2142 gcc_assert (i == -1);
2143 /* Elemental dimension. */
2144 gcc_assert (info->subscript[dim]
2145 && info->subscript[dim]->type == GFC_SS_SCALAR);
2146 /* We've already translated this value outside the loop. */
2147 index = info->subscript[dim]->data.scalar.expr;
2149 index = gfc_trans_array_bound_check (se, info->descriptor,
2150 index, dim, &ar->where,
2151 (ar->as->type != AS_ASSUMED_SIZE
2152 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2156 gcc_assert (info && se->loop);
2157 gcc_assert (info->subscript[dim]
2158 && info->subscript[dim]->type == GFC_SS_VECTOR);
2159 desc = info->subscript[dim]->data.info.descriptor;
2161 /* Get a zero-based index into the vector. */
2162 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2163 se->loop->loopvar[i], se->loop->from[i]);
2165 /* Multiply the index by the stride. */
2166 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2167 index, gfc_conv_array_stride (desc, 0));
2169 /* Read the vector to get an index into info->descriptor. */
2170 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2171 index = gfc_build_array_ref (data, index);
2172 index = gfc_evaluate_now (index, &se->pre);
2174 /* Do any bounds checking on the final info->descriptor index. */
2175 index = gfc_trans_array_bound_check (se, info->descriptor,
2176 index, dim, &ar->where,
2177 (ar->as->type != AS_ASSUMED_SIZE
2178 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2182 /* Scalarized dimension. */
2183 gcc_assert (info && se->loop);
2185 /* Multiply the loop variable by the stride and delta. */
2186 index = se->loop->loopvar[i];
2187 if (!integer_onep (info->stride[i]))
2188 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2190 if (!integer_zerop (info->delta[i]))
2191 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2201 /* Temporary array or derived type component. */
2202 gcc_assert (se->loop);
2203 index = se->loop->loopvar[se->loop->order[i]];
2204 if (!integer_zerop (info->delta[i]))
2205 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2206 index, info->delta[i]);
2209 /* Multiply by the stride. */
2210 if (!integer_onep (stride))
2211 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2217 /* Build a scalarized reference to an array. */
2220 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2227 info = &se->ss->data.info;
2229 n = se->loop->order[0];
2233 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2235 /* Add the offset for this dimension to the stored offset for all other
2237 if (!integer_zerop (info->offset))
2238 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2240 tmp = build_fold_indirect_ref (info->data);
2241 se->expr = gfc_build_array_ref (tmp, index);
2245 /* Translate access of temporary array. */
2248 gfc_conv_tmp_array_ref (gfc_se * se)
2250 se->string_length = se->ss->string_length;
2251 gfc_conv_scalarized_array_ref (se, NULL);
2255 /* Build an array reference. se->expr already holds the array descriptor.
2256 This should be either a variable, indirect variable reference or component
2257 reference. For arrays which do not have a descriptor, se->expr will be
2259 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2262 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2271 /* Handle scalarized references separately. */
2272 if (ar->type != AR_ELEMENT)
2274 gfc_conv_scalarized_array_ref (se, ar);
2275 gfc_advance_se_ss_chain (se);
2279 index = gfc_index_zero_node;
2281 /* Calculate the offsets from all the dimensions. */
2282 for (n = 0; n < ar->dimen; n++)
2284 /* Calculate the index for this dimension. */
2285 gfc_init_se (&indexse, se);
2286 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2287 gfc_add_block_to_block (&se->pre, &indexse.pre);
2289 if (flag_bounds_check)
2291 /* Check array bounds. */
2295 /* Evaluate the indexse.expr only once. */
2296 indexse.expr = save_expr (indexse.expr);
2299 tmp = gfc_conv_array_lbound (se->expr, n);
2300 cond = fold_build2 (LT_EXPR, boolean_type_node,
2302 asprintf (&msg, "%s for array '%s', "
2303 "lower bound of dimension %d exceeded", gfc_msg_fault,
2305 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2308 /* Upper bound, but not for the last dimension of assumed-size
2310 if (n < ar->dimen - 1
2311 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2313 tmp = gfc_conv_array_ubound (se->expr, n);
2314 cond = fold_build2 (GT_EXPR, boolean_type_node,
2316 asprintf (&msg, "%s for array '%s', "
2317 "upper bound of dimension %d exceeded", gfc_msg_fault,
2319 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2324 /* Multiply the index by the stride. */
2325 stride = gfc_conv_array_stride (se->expr, n);
2326 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2329 /* And add it to the total. */
2330 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2333 tmp = gfc_conv_array_offset (se->expr);
2334 if (!integer_zerop (tmp))
2335 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2337 /* Access the calculated element. */
2338 tmp = gfc_conv_array_data (se->expr);
2339 tmp = build_fold_indirect_ref (tmp);
2340 se->expr = gfc_build_array_ref (tmp, index);
2344 /* Generate the code to be executed immediately before entering a
2345 scalarization loop. */
2348 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2349 stmtblock_t * pblock)
2358 /* This code will be executed before entering the scalarization loop
2359 for this dimension. */
2360 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2362 if ((ss->useflags & flag) == 0)
2365 if (ss->type != GFC_SS_SECTION
2366 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2367 && ss->type != GFC_SS_COMPONENT)
2370 info = &ss->data.info;
2372 if (dim >= info->dimen)
2375 if (dim == info->dimen - 1)
2377 /* For the outermost loop calculate the offset due to any
2378 elemental dimensions. It will have been initialized with the
2379 base offset of the array. */
2382 for (i = 0; i < info->ref->u.ar.dimen; i++)
2384 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2387 gfc_init_se (&se, NULL);
2389 se.expr = info->descriptor;
2390 stride = gfc_conv_array_stride (info->descriptor, i);
2391 index = gfc_conv_array_index_offset (&se, info, i, -1,
2394 gfc_add_block_to_block (pblock, &se.pre);
2396 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2397 info->offset, index);
2398 info->offset = gfc_evaluate_now (info->offset, pblock);
2402 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2405 stride = gfc_conv_array_stride (info->descriptor, 0);
2407 /* Calculate the stride of the innermost loop. Hopefully this will
2408 allow the backend optimizers to do their stuff more effectively.
2410 info->stride0 = gfc_evaluate_now (stride, pblock);
2414 /* Add the offset for the previous loop dimension. */
2419 ar = &info->ref->u.ar;
2420 i = loop->order[dim + 1];
2428 gfc_init_se (&se, NULL);
2430 se.expr = info->descriptor;
2431 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2432 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2434 gfc_add_block_to_block (pblock, &se.pre);
2435 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2436 info->offset, index);
2437 info->offset = gfc_evaluate_now (info->offset, pblock);
2440 /* Remember this offset for the second loop. */
2441 if (dim == loop->temp_dim - 1)
2442 info->saved_offset = info->offset;
2447 /* Start a scalarized expression. Creates a scope and declares loop
2451 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2457 gcc_assert (!loop->array_parameter);
2459 for (dim = loop->dimen - 1; dim >= 0; dim--)
2461 n = loop->order[dim];
2463 gfc_start_block (&loop->code[n]);
2465 /* Create the loop variable. */
2466 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2468 if (dim < loop->temp_dim)
2472 /* Calculate values that will be constant within this loop. */
2473 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2475 gfc_start_block (pbody);
2479 /* Generates the actual loop code for a scalarization loop. */
2482 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2483 stmtblock_t * pbody)
2491 loopbody = gfc_finish_block (pbody);
2493 /* Initialize the loopvar. */
2494 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2496 exit_label = gfc_build_label_decl (NULL_TREE);
2498 /* Generate the loop body. */
2499 gfc_init_block (&block);
2501 /* The exit condition. */
2502 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2503 tmp = build1_v (GOTO_EXPR, exit_label);
2504 TREE_USED (exit_label) = 1;
2505 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2506 gfc_add_expr_to_block (&block, tmp);
2508 /* The main body. */
2509 gfc_add_expr_to_block (&block, loopbody);
2511 /* Increment the loopvar. */
2512 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2513 loop->loopvar[n], gfc_index_one_node);
2514 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2516 /* Build the loop. */
2517 tmp = gfc_finish_block (&block);
2518 tmp = build1_v (LOOP_EXPR, tmp);
2519 gfc_add_expr_to_block (&loop->code[n], tmp);
2521 /* Add the exit label. */
2522 tmp = build1_v (LABEL_EXPR, exit_label);
2523 gfc_add_expr_to_block (&loop->code[n], tmp);
2527 /* Finishes and generates the loops for a scalarized expression. */
2530 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2535 stmtblock_t *pblock;
2539 /* Generate the loops. */
2540 for (dim = 0; dim < loop->dimen; dim++)
2542 n = loop->order[dim];
2543 gfc_trans_scalarized_loop_end (loop, n, pblock);
2544 loop->loopvar[n] = NULL_TREE;
2545 pblock = &loop->code[n];
2548 tmp = gfc_finish_block (pblock);
2549 gfc_add_expr_to_block (&loop->pre, tmp);
2551 /* Clear all the used flags. */
2552 for (ss = loop->ss; ss; ss = ss->loop_chain)
2557 /* Finish the main body of a scalarized expression, and start the secondary
2561 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2565 stmtblock_t *pblock;
2569 /* We finish as many loops as are used by the temporary. */
2570 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2572 n = loop->order[dim];
2573 gfc_trans_scalarized_loop_end (loop, n, pblock);
2574 loop->loopvar[n] = NULL_TREE;
2575 pblock = &loop->code[n];
2578 /* We don't want to finish the outermost loop entirely. */
2579 n = loop->order[loop->temp_dim - 1];
2580 gfc_trans_scalarized_loop_end (loop, n, pblock);
2582 /* Restore the initial offsets. */
2583 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2585 if ((ss->useflags & 2) == 0)
2588 if (ss->type != GFC_SS_SECTION
2589 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2590 && ss->type != GFC_SS_COMPONENT)
2593 ss->data.info.offset = ss->data.info.saved_offset;
2596 /* Restart all the inner loops we just finished. */
2597 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2599 n = loop->order[dim];
2601 gfc_start_block (&loop->code[n]);
2603 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2605 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2608 /* Start a block for the secondary copying code. */
2609 gfc_start_block (body);
2613 /* Calculate the upper bound of an array section. */
2616 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2625 gcc_assert (ss->type == GFC_SS_SECTION);
2627 info = &ss->data.info;
2630 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2631 /* We'll calculate the upper bound once we have access to the
2632 vector's descriptor. */
2635 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2636 desc = info->descriptor;
2637 end = info->ref->u.ar.end[dim];
2641 /* The upper bound was specified. */
2642 gfc_init_se (&se, NULL);
2643 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2644 gfc_add_block_to_block (pblock, &se.pre);
2649 /* No upper bound was specified, so use the bound of the array. */
2650 bound = gfc_conv_array_ubound (desc, dim);
2657 /* Calculate the lower bound of an array section. */
2660 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2670 gcc_assert (ss->type == GFC_SS_SECTION);
2672 info = &ss->data.info;
2675 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2677 /* We use a zero-based index to access the vector. */
2678 info->start[n] = gfc_index_zero_node;
2679 info->end[n] = gfc_index_zero_node;
2680 info->stride[n] = gfc_index_one_node;
2684 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2685 desc = info->descriptor;
2686 start = info->ref->u.ar.start[dim];
2687 end = info->ref->u.ar.end[dim];
2688 stride = info->ref->u.ar.stride[dim];
2690 /* Calculate the start of the range. For vector subscripts this will
2691 be the range of the vector. */
2694 /* Specified section start. */
2695 gfc_init_se (&se, NULL);
2696 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2697 gfc_add_block_to_block (&loop->pre, &se.pre);
2698 info->start[n] = se.expr;
2702 /* No lower bound specified so use the bound of the array. */
2703 info->start[n] = gfc_conv_array_lbound (desc, dim);
2705 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2707 /* Similarly calculate the end. Although this is not used in the
2708 scalarizer, it is needed when checking bounds and where the end
2709 is an expression with side-effects. */
2712 /* Specified section start. */
2713 gfc_init_se (&se, NULL);
2714 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2715 gfc_add_block_to_block (&loop->pre, &se.pre);
2716 info->end[n] = se.expr;
2720 /* No upper bound specified so use the bound of the array. */
2721 info->end[n] = gfc_conv_array_ubound (desc, dim);
2723 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2725 /* Calculate the stride. */
2727 info->stride[n] = gfc_index_one_node;
2730 gfc_init_se (&se, NULL);
2731 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2732 gfc_add_block_to_block (&loop->pre, &se.pre);
2733 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2738 /* Calculates the range start and stride for a SS chain. Also gets the
2739 descriptor and data pointer. The range of vector subscripts is the size
2740 of the vector. Array bounds are also checked. */
2743 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2751 /* Determine the rank of the loop. */
2753 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2757 case GFC_SS_SECTION:
2758 case GFC_SS_CONSTRUCTOR:
2759 case GFC_SS_FUNCTION:
2760 case GFC_SS_COMPONENT:
2761 loop->dimen = ss->data.info.dimen;
2764 /* As usual, lbound and ubound are exceptions!. */
2765 case GFC_SS_INTRINSIC:
2766 switch (ss->expr->value.function.isym->id)
2768 case GFC_ISYM_LBOUND:
2769 case GFC_ISYM_UBOUND:
2770 loop->dimen = ss->data.info.dimen;
2781 if (loop->dimen == 0)
2782 gfc_todo_error ("Unable to determine rank of expression");
2785 /* Loop over all the SS in the chain. */
2786 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2788 if (ss->expr && ss->expr->shape && !ss->shape)
2789 ss->shape = ss->expr->shape;
2793 case GFC_SS_SECTION:
2794 /* Get the descriptor for the array. */
2795 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2797 for (n = 0; n < ss->data.info.dimen; n++)
2798 gfc_conv_section_startstride (loop, ss, n);
2801 case GFC_SS_INTRINSIC:
2802 switch (ss->expr->value.function.isym->id)
2804 /* Fall through to supply start and stride. */
2805 case GFC_ISYM_LBOUND:
2806 case GFC_ISYM_UBOUND:
2812 case GFC_SS_CONSTRUCTOR:
2813 case GFC_SS_FUNCTION:
2814 for (n = 0; n < ss->data.info.dimen; n++)
2816 ss->data.info.start[n] = gfc_index_zero_node;
2817 ss->data.info.end[n] = gfc_index_zero_node;
2818 ss->data.info.stride[n] = gfc_index_one_node;
2827 /* The rest is just runtime bound checking. */
2828 if (flag_bounds_check)
2831 tree lbound, ubound;
2833 tree size[GFC_MAX_DIMENSIONS];
2834 tree stride_pos, stride_neg, non_zerosized, tmp2;
2839 gfc_start_block (&block);
2841 for (n = 0; n < loop->dimen; n++)
2842 size[n] = NULL_TREE;
2844 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2846 if (ss->type != GFC_SS_SECTION)
2849 /* TODO: range checking for mapped dimensions. */
2850 info = &ss->data.info;
2852 /* This code only checks ranges. Elemental and vector
2853 dimensions are checked later. */
2854 for (n = 0; n < loop->dimen; n++)
2859 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2862 if (n == info->ref->u.ar.dimen - 1
2863 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2864 || info->ref->u.ar.as->cp_was_assumed))
2865 check_upper = false;
2869 /* Zero stride is not allowed. */
2870 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2871 gfc_index_zero_node);
2872 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2873 "of array '%s'", info->dim[n]+1,
2874 ss->expr->symtree->name);
2875 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2878 desc = ss->data.info.descriptor;
2880 /* This is the run-time equivalent of resolve.c's
2881 check_dimension(). The logical is more readable there
2882 than it is here, with all the trees. */
2883 lbound = gfc_conv_array_lbound (desc, dim);
2886 ubound = gfc_conv_array_ubound (desc, dim);
2890 /* non_zerosized is true when the selected range is not
2892 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2893 info->stride[n], gfc_index_zero_node);
2894 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2896 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2899 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2900 info->stride[n], gfc_index_zero_node);
2901 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2903 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2905 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2906 stride_pos, stride_neg);
2908 /* Check the start of the range against the lower and upper
2909 bounds of the array, if the range is not empty. */
2910 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2912 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2913 non_zerosized, tmp);
2914 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2915 " exceeded", gfc_msg_fault, info->dim[n]+1,
2916 ss->expr->symtree->name);
2917 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2922 tmp = fold_build2 (GT_EXPR, boolean_type_node,
2923 info->start[n], ubound);
2924 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2925 non_zerosized, tmp);
2926 asprintf (&msg, "%s, upper bound of dimension %d of array "
2927 "'%s' exceeded", gfc_msg_fault, info->dim[n]+1,
2928 ss->expr->symtree->name);
2929 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2933 /* Compute the last element of the range, which is not
2934 necessarily "end" (think 0:5:3, which doesn't contain 5)
2935 and check it against both lower and upper bounds. */
2936 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2938 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2940 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2943 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2944 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2945 non_zerosized, tmp);
2946 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2947 " exceeded", gfc_msg_fault, info->dim[n]+1,
2948 ss->expr->symtree->name);
2949 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2954 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2955 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2956 non_zerosized, tmp);
2957 asprintf (&msg, "%s, upper bound of dimension %d of array "
2958 "'%s' exceeded", gfc_msg_fault, info->dim[n]+1,
2959 ss->expr->symtree->name);
2960 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2964 /* Check the section sizes match. */
2965 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2967 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2969 /* We remember the size of the first section, and check all the
2970 others against this. */
2974 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2975 asprintf (&msg, "%s, size mismatch for dimension %d "
2976 "of array '%s'", gfc_msg_bounds, info->dim[n]+1,
2977 ss->expr->symtree->name);
2978 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2982 size[n] = gfc_evaluate_now (tmp, &block);
2986 tmp = gfc_finish_block (&block);
2987 gfc_add_expr_to_block (&loop->pre, tmp);
2992 /* Return true if the two SS could be aliased, i.e. both point to the same data
2994 /* TODO: resolve aliases based on frontend expressions. */
2997 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3004 lsym = lss->expr->symtree->n.sym;
3005 rsym = rss->expr->symtree->n.sym;
3006 if (gfc_symbols_could_alias (lsym, rsym))
3009 if (rsym->ts.type != BT_DERIVED
3010 && lsym->ts.type != BT_DERIVED)
3013 /* For derived types we must check all the component types. We can ignore
3014 array references as these will have the same base type as the previous
3016 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3018 if (lref->type != REF_COMPONENT)
3021 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3024 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3027 if (rref->type != REF_COMPONENT)
3030 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3035 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3037 if (rref->type != REF_COMPONENT)
3040 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3048 /* Resolve array data dependencies. Creates a temporary if required. */
3049 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3053 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3063 loop->temp_ss = NULL;
3064 aref = dest->data.info.ref;
3067 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3069 if (ss->type != GFC_SS_SECTION)
3072 if (gfc_could_be_alias (dest, ss)
3073 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3079 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3081 lref = dest->expr->ref;
3082 rref = ss->expr->ref;
3084 nDepend = gfc_dep_resolver (lref, rref);
3088 /* TODO : loop shifting. */
3091 /* Mark the dimensions for LOOP SHIFTING */
3092 for (n = 0; n < loop->dimen; n++)
3094 int dim = dest->data.info.dim[n];
3096 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3098 else if (! gfc_is_same_range (&lref->u.ar,
3099 &rref->u.ar, dim, 0))
3103 /* Put all the dimensions with dependencies in the
3106 for (n = 0; n < loop->dimen; n++)
3108 gcc_assert (loop->order[n] == n);
3110 loop->order[dim++] = n;
3113 for (n = 0; n < loop->dimen; n++)
3116 loop->order[dim++] = n;
3119 gcc_assert (dim == loop->dimen);
3128 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3129 if (GFC_ARRAY_TYPE_P (base_type)
3130 || GFC_DESCRIPTOR_TYPE_P (base_type))
3131 base_type = gfc_get_element_type (base_type);
3132 loop->temp_ss = gfc_get_ss ();
3133 loop->temp_ss->type = GFC_SS_TEMP;
3134 loop->temp_ss->data.temp.type = base_type;
3135 loop->temp_ss->string_length = dest->string_length;
3136 loop->temp_ss->data.temp.dimen = loop->dimen;
3137 loop->temp_ss->next = gfc_ss_terminator;
3138 gfc_add_ss_to_loop (loop, loop->temp_ss);
3141 loop->temp_ss = NULL;
3145 /* Initialize the scalarization loop. Creates the loop variables. Determines
3146 the range of the loop variables. Creates a temporary if required.
3147 Calculates how to transform from loop variables to array indices for each
3148 expression. Also generates code for scalar expressions which have been
3149 moved outside the loop. */
3152 gfc_conv_loop_setup (gfc_loopinfo * loop)
3157 gfc_ss_info *specinfo;
3161 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3162 bool dynamic[GFC_MAX_DIMENSIONS];
3168 for (n = 0; n < loop->dimen; n++)
3172 /* We use one SS term, and use that to determine the bounds of the
3173 loop for this dimension. We try to pick the simplest term. */
3174 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3178 /* The frontend has worked out the size for us. */
3183 if (ss->type == GFC_SS_CONSTRUCTOR)
3185 /* An unknown size constructor will always be rank one.
3186 Higher rank constructors will either have known shape,
3187 or still be wrapped in a call to reshape. */
3188 gcc_assert (loop->dimen == 1);
3190 /* Always prefer to use the constructor bounds if the size
3191 can be determined at compile time. Prefer not to otherwise,
3192 since the general case involves realloc, and it's better to
3193 avoid that overhead if possible. */
3194 c = ss->expr->value.constructor;
3195 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3196 if (!dynamic[n] || !loopspec[n])
3201 /* TODO: Pick the best bound if we have a choice between a
3202 function and something else. */
3203 if (ss->type == GFC_SS_FUNCTION)
3209 if (ss->type != GFC_SS_SECTION)
3213 specinfo = &loopspec[n]->data.info;
3216 info = &ss->data.info;
3220 /* Criteria for choosing a loop specifier (most important first):
3221 doesn't need realloc
3227 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3229 else if (integer_onep (info->stride[n])
3230 && !integer_onep (specinfo->stride[n]))
3232 else if (INTEGER_CST_P (info->stride[n])
3233 && !INTEGER_CST_P (specinfo->stride[n]))
3235 else if (INTEGER_CST_P (info->start[n])
3236 && !INTEGER_CST_P (specinfo->start[n]))
3238 /* We don't work out the upper bound.
3239 else if (INTEGER_CST_P (info->finish[n])
3240 && ! INTEGER_CST_P (specinfo->finish[n]))
3241 loopspec[n] = ss; */
3245 gfc_todo_error ("Unable to find scalarization loop specifier");
3247 info = &loopspec[n]->data.info;
3249 /* Set the extents of this range. */
3250 cshape = loopspec[n]->shape;
3251 if (cshape && INTEGER_CST_P (info->start[n])
3252 && INTEGER_CST_P (info->stride[n]))
3254 loop->from[n] = info->start[n];
3255 mpz_set (i, cshape[n]);
3256 mpz_sub_ui (i, i, 1);
3257 /* To = from + (size - 1) * stride. */
3258 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3259 if (!integer_onep (info->stride[n]))
3260 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3261 tmp, info->stride[n]);
3262 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3263 loop->from[n], tmp);
3267 loop->from[n] = info->start[n];
3268 switch (loopspec[n]->type)
3270 case GFC_SS_CONSTRUCTOR:
3271 /* The upper bound is calculated when we expand the
3273 gcc_assert (loop->to[n] == NULL_TREE);
3276 case GFC_SS_SECTION:
3277 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3281 case GFC_SS_FUNCTION:
3282 /* The loop bound will be set when we generate the call. */
3283 gcc_assert (loop->to[n] == NULL_TREE);
3291 /* Transform everything so we have a simple incrementing variable. */
3292 if (integer_onep (info->stride[n]))
3293 info->delta[n] = gfc_index_zero_node;
3296 /* Set the delta for this section. */
3297 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3298 /* Number of iterations is (end - start + step) / step.
3299 with start = 0, this simplifies to
3301 for (i = 0; i<=last; i++){...}; */
3302 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3303 loop->to[n], loop->from[n]);
3304 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3305 tmp, info->stride[n]);
3306 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3307 /* Make the loop variable start at 0. */
3308 loop->from[n] = gfc_index_zero_node;
3312 /* Add all the scalar code that can be taken out of the loops.
3313 This may include calculating the loop bounds, so do it before
3314 allocating the temporary. */
3315 gfc_add_loop_ss_code (loop, loop->ss, false);
3317 /* If we want a temporary then create it. */
3318 if (loop->temp_ss != NULL)
3320 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3321 tmp = loop->temp_ss->data.temp.type;
3322 len = loop->temp_ss->string_length;
3323 n = loop->temp_ss->data.temp.dimen;
3324 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3325 loop->temp_ss->type = GFC_SS_SECTION;
3326 loop->temp_ss->data.info.dimen = n;
3327 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3328 &loop->temp_ss->data.info, tmp, false, true,
3332 for (n = 0; n < loop->temp_dim; n++)
3333 loopspec[loop->order[n]] = NULL;
3337 /* For array parameters we don't have loop variables, so don't calculate the
3339 if (loop->array_parameter)
3342 /* Calculate the translation from loop variables to array indices. */
3343 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3345 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3348 info = &ss->data.info;
3350 for (n = 0; n < info->dimen; n++)
3354 /* If we are specifying the range the delta is already set. */
3355 if (loopspec[n] != ss)
3357 /* Calculate the offset relative to the loop variable.
3358 First multiply by the stride. */
3359 tmp = loop->from[n];
3360 if (!integer_onep (info->stride[n]))
3361 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3362 tmp, info->stride[n]);
3364 /* Then subtract this from our starting value. */
3365 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3366 info->start[n], tmp);
3368 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3375 /* Fills in an array descriptor, and returns the size of the array. The size
3376 will be a simple_val, ie a variable or a constant. Also calculates the
3377 offset of the base. Returns the size of the array.
3381 for (n = 0; n < rank; n++)
3383 a.lbound[n] = specified_lower_bound;
3384 offset = offset + a.lbond[n] * stride;
3386 a.ubound[n] = specified_upper_bound;
3387 a.stride[n] = stride;
3388 size = ubound + size; //size = ubound + 1 - lbound
3389 stride = stride * size;
3396 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3397 gfc_expr ** lower, gfc_expr ** upper,
3398 stmtblock_t * pblock)
3410 stmtblock_t thenblock;
3411 stmtblock_t elseblock;
3416 type = TREE_TYPE (descriptor);
3418 stride = gfc_index_one_node;
3419 offset = gfc_index_zero_node;
3421 /* Set the dtype. */
3422 tmp = gfc_conv_descriptor_dtype (descriptor);
3423 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3425 or_expr = NULL_TREE;
3427 for (n = 0; n < rank; n++)
3429 /* We have 3 possibilities for determining the size of the array:
3430 lower == NULL => lbound = 1, ubound = upper[n]
3431 upper[n] = NULL => lbound = 1, ubound = lower[n]
3432 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3435 /* Set lower bound. */
3436 gfc_init_se (&se, NULL);
3438 se.expr = gfc_index_one_node;
3441 gcc_assert (lower[n]);
3444 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3445 gfc_add_block_to_block (pblock, &se.pre);
3449 se.expr = gfc_index_one_node;
3453 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3454 gfc_add_modify_expr (pblock, tmp, se.expr);
3456 /* Work out the offset for this component. */
3457 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3458 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3460 /* Start the calculation for the size of this dimension. */
3461 size = build2 (MINUS_EXPR, gfc_array_index_type,
3462 gfc_index_one_node, se.expr);
3464 /* Set upper bound. */
3465 gfc_init_se (&se, NULL);
3466 gcc_assert (ubound);
3467 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3468 gfc_add_block_to_block (pblock, &se.pre);
3470 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3471 gfc_add_modify_expr (pblock, tmp, se.expr);
3473 /* Store the stride. */
3474 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3475 gfc_add_modify_expr (pblock, tmp, stride);
3477 /* Calculate the size of this dimension. */
3478 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3480 /* Check whether the size for this dimension is negative. */
3481 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3482 gfc_index_zero_node);
3486 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3488 /* Multiply the stride by the number of elements in this dimension. */
3489 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3490 stride = gfc_evaluate_now (stride, pblock);
3493 /* The stride is the number of elements in the array, so multiply by the
3494 size of an element to get the total size. */
3495 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3496 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3497 fold_convert (gfc_array_index_type, tmp));
3499 if (poffset != NULL)
3501 offset = gfc_evaluate_now (offset, pblock);
3505 if (integer_zerop (or_expr))
3507 if (integer_onep (or_expr))
3508 return gfc_index_zero_node;
3510 var = gfc_create_var (TREE_TYPE (size), "size");
3511 gfc_start_block (&thenblock);
3512 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3513 thencase = gfc_finish_block (&thenblock);
3515 gfc_start_block (&elseblock);
3516 gfc_add_modify_expr (&elseblock, var, size);
3517 elsecase = gfc_finish_block (&elseblock);
3519 tmp = gfc_evaluate_now (or_expr, pblock);
3520 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3521 gfc_add_expr_to_block (pblock, tmp);
3527 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3528 the work for an ALLOCATE statement. */
3532 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3541 gfc_ref *ref, *prev_ref = NULL;
3542 bool allocatable_array;
3546 /* Find the last reference in the chain. */
3547 while (ref && ref->next != NULL)
3549 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3554 if (ref == NULL || ref->type != REF_ARRAY)
3558 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3560 allocatable_array = prev_ref->u.c.component->allocatable;
3562 /* Figure out the size of the array. */
3563 switch (ref->u.ar.type)
3567 upper = ref->u.ar.start;
3571 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3573 lower = ref->u.ar.as->lower;
3574 upper = ref->u.ar.as->upper;
3578 lower = ref->u.ar.start;
3579 upper = ref->u.ar.end;
3587 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3588 lower, upper, &se->pre);
3590 /* Allocate memory to store the data. */
3591 pointer = gfc_conv_descriptor_data_get (se->expr);
3592 STRIP_NOPS (pointer);
3594 if (TYPE_PRECISION (gfc_array_index_type) == 32 ||
3595 TYPE_PRECISION (gfc_array_index_type) == 64)
3597 if (allocatable_array)
3598 allocate = gfor_fndecl_allocate_array;
3600 allocate = gfor_fndecl_allocate;
3605 /* The allocate_array variants take the old pointer as first argument. */
3606 if (allocatable_array)
3607 tmp = build_call_expr (allocate, 3, pointer, size, pstat);
3609 tmp = build_call_expr (allocate, 2, size, pstat);
3610 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3611 gfc_add_expr_to_block (&se->pre, tmp);
3613 tmp = gfc_conv_descriptor_offset (se->expr);
3614 gfc_add_modify_expr (&se->pre, tmp, offset);
3616 if (expr->ts.type == BT_DERIVED
3617 && expr->ts.derived->attr.alloc_comp)
3619 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3620 ref->u.ar.as->rank);
3621 gfc_add_expr_to_block (&se->pre, tmp);
3628 /* Deallocate an array variable. Also used when an allocated variable goes
3633 gfc_array_deallocate (tree descriptor, tree pstat)
3639 gfc_start_block (&block);
3640 /* Get a pointer to the data. */
3641 var = gfc_conv_descriptor_data_get (descriptor);
3644 /* Parameter is the address of the data component. */
3645 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
3646 gfc_add_expr_to_block (&block, tmp);
3648 /* Zero the data pointer. */
3649 tmp = build2 (MODIFY_EXPR, void_type_node,
3650 var, build_int_cst (TREE_TYPE (var), 0));
3651 gfc_add_expr_to_block (&block, tmp);
3653 return gfc_finish_block (&block);
3657 /* Create an array constructor from an initialization expression.
3658 We assume the frontend already did any expansions and conversions. */
3661 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3668 unsigned HOST_WIDE_INT lo;
3670 VEC(constructor_elt,gc) *v = NULL;
3672 switch (expr->expr_type)
3675 case EXPR_STRUCTURE:
3676 /* A single scalar or derived type value. Create an array with all
3677 elements equal to that value. */
3678 gfc_init_se (&se, NULL);
3680 if (expr->expr_type == EXPR_CONSTANT)
3681 gfc_conv_constant (&se, expr);
3683 gfc_conv_structure (&se, expr, 1);
3685 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3686 gcc_assert (tmp && INTEGER_CST_P (tmp));
3687 hi = TREE_INT_CST_HIGH (tmp);
3688 lo = TREE_INT_CST_LOW (tmp);
3692 /* This will probably eat buckets of memory for large arrays. */
3693 while (hi != 0 || lo != 0)
3695 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3703 /* Create a vector of all the elements. */
3704 for (c = expr->value.constructor; c; c = c->next)
3708 /* Problems occur when we get something like
3709 integer :: a(lots) = (/(i, i=1,lots)/) */
3710 /* TODO: Unexpanded array initializers. */
3712 ("Possible frontend bug: array constructor not expanded");
3714 if (mpz_cmp_si (c->n.offset, 0) != 0)
3715 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3719 if (mpz_cmp_si (c->repeat, 0) != 0)
3723 mpz_set (maxval, c->repeat);
3724 mpz_add (maxval, c->n.offset, maxval);
3725 mpz_sub_ui (maxval, maxval, 1);
3726 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3727 if (mpz_cmp_si (c->n.offset, 0) != 0)
3729 mpz_add_ui (maxval, c->n.offset, 1);
3730 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3733 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3735 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3741 gfc_init_se (&se, NULL);
3742 switch (c->expr->expr_type)
3745 gfc_conv_constant (&se, c->expr);
3746 if (range == NULL_TREE)
3747 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3750 if (index != NULL_TREE)
3751 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3752 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3756 case EXPR_STRUCTURE:
3757 gfc_conv_structure (&se, c->expr, 1);
3758 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3768 return gfc_build_null_descriptor (type);
3774 /* Create a constructor from the list of elements. */
3775 tmp = build_constructor (type, v);
3776 TREE_CONSTANT (tmp) = 1;
3777 TREE_INVARIANT (tmp) = 1;
3782 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3783 returns the size (in elements) of the array. */
3786 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3787 stmtblock_t * pblock)
3802 size = gfc_index_one_node;
3803 offset = gfc_index_zero_node;
3804 for (dim = 0; dim < as->rank; dim++)
3806 /* Evaluate non-constant array bound expressions. */
3807 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3808 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3810 gfc_init_se (&se, NULL);
3811 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3812 gfc_add_block_to_block (pblock, &se.pre);
3813 gfc_add_modify_expr (pblock, lbound, se.expr);
3815 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3816 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3818 gfc_init_se (&se, NULL);
3819 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3820 gfc_add_block_to_block (pblock, &se.pre);
3821 gfc_add_modify_expr (pblock, ubound, se.expr);
3823 /* The offset of this dimension. offset = offset - lbound * stride. */
3824 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3825 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3827 /* The size of this dimension, and the stride of the next. */
3828 if (dim + 1 < as->rank)
3829 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3831 stride = GFC_TYPE_ARRAY_SIZE (type);
3833 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3835 /* Calculate stride = size * (ubound + 1 - lbound). */
3836 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3837 gfc_index_one_node, lbound);
3838 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3839 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3841 gfc_add_modify_expr (pblock, stride, tmp);
3843 stride = gfc_evaluate_now (tmp, pblock);
3845 /* Make sure that negative size arrays are translated
3846 to being zero size. */
3847 tmp = build2 (GE_EXPR, boolean_type_node,
3848 stride, gfc_index_zero_node);
3849 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3850 stride, gfc_index_zero_node);
3851 gfc_add_modify_expr (pblock, stride, tmp);
3857 gfc_trans_vla_type_sizes (sym, pblock);
3864 /* Generate code to initialize/allocate an array variable. */
3867 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3876 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3878 /* Do nothing for USEd variables. */
3879 if (sym->attr.use_assoc)
3882 type = TREE_TYPE (decl);
3883 gcc_assert (GFC_ARRAY_TYPE_P (type));
3884 onstack = TREE_CODE (type) != POINTER_TYPE;
3886 gfc_start_block (&block);
3888 /* Evaluate character string length. */
3889 if (sym->ts.type == BT_CHARACTER
3890 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3892 gfc_trans_init_string_length (sym->ts.cl, &block);
3894 gfc_trans_vla_type_sizes (sym, &block);
3896 /* Emit a DECL_EXPR for this variable, which will cause the
3897 gimplifier to allocate storage, and all that good stuff. */
3898 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3899 gfc_add_expr_to_block (&block, tmp);
3904 gfc_add_expr_to_block (&block, fnbody);
3905 return gfc_finish_block (&block);
3908 type = TREE_TYPE (type);
3910 gcc_assert (!sym->attr.use_assoc);
3911 gcc_assert (!TREE_STATIC (decl));
3912 gcc_assert (!sym->module);
3914 if (sym->ts.type == BT_CHARACTER
3915 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3916 gfc_trans_init_string_length (sym->ts.cl, &block);
3918 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3920 /* Don't actually allocate space for Cray Pointees. */
3921 if (sym->attr.cray_pointee)
3923 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3924 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3925 gfc_add_expr_to_block (&block, fnbody);
3926 return gfc_finish_block (&block);
3929 /* The size is the number of elements in the array, so multiply by the
3930 size of an element to get the total size. */
3931 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3932 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
3933 fold_convert (gfc_array_index_type, tmp));
3935 /* Allocate memory to hold the data. */
3936 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3937 gfc_add_modify_expr (&block, decl, tmp);
3939 /* Set offset of the array. */
3940 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3941 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3944 /* Automatic arrays should not have initializers. */
3945 gcc_assert (!sym->value);
3947 gfc_add_expr_to_block (&block, fnbody);
3949 /* Free the temporary. */
3950 tmp = gfc_call_free (convert (pvoid_type_node, decl));
3951 gfc_add_expr_to_block (&block, tmp);
3953 return gfc_finish_block (&block);
3957 /* Generate entry and exit code for g77 calling convention arrays. */
3960 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3970 gfc_get_backend_locus (&loc);
3971 gfc_set_backend_locus (&sym->declared_at);
3973 /* Descriptor type. */
3974 parm = sym->backend_decl;
3975 type = TREE_TYPE (parm);
3976 gcc_assert (GFC_ARRAY_TYPE_P (type));
3978 gfc_start_block (&block);
3980 if (sym->ts.type == BT_CHARACTER
3981 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3982 gfc_trans_init_string_length (sym->ts.cl, &block);
3984 /* Evaluate the bounds of the array. */
3985 gfc_trans_array_bounds (type, sym, &offset, &block);
3987 /* Set the offset. */
3988 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3989 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3991 /* Set the pointer itself if we aren't using the parameter directly. */
3992 if (TREE_CODE (parm) != PARM_DECL)
3994 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3995 gfc_add_modify_expr (&block, parm, tmp);
3997 stmt = gfc_finish_block (&block);
3999 gfc_set_backend_locus (&loc);
4001 gfc_start_block (&block);
4003 /* Add the initialization code to the start of the function. */
4005 if (sym->attr.optional || sym->attr.not_always_present)
4007 tmp = gfc_conv_expr_present (sym);
4008 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4011 gfc_add_expr_to_block (&block, stmt);
4012 gfc_add_expr_to_block (&block, body);
4014 return gfc_finish_block (&block);
4018 /* Modify the descriptor of an array parameter so that it has the
4019 correct lower bound. Also move the upper bound accordingly.
4020 If the array is not packed, it will be copied into a temporary.
4021 For each dimension we set the new lower and upper bounds. Then we copy the
4022 stride and calculate the offset for this dimension. We also work out
4023 what the stride of a packed array would be, and see it the two match.
4024 If the array need repacking, we set the stride to the values we just
4025 calculated, recalculate the offset and copy the array data.
4026 Code is also added to copy the data back at the end of the function.
4030 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4037 stmtblock_t cleanup;
4045 tree stride, stride2;
4055 /* Do nothing for pointer and allocatable arrays. */
4056 if (sym->attr.pointer || sym->attr.allocatable)
4059 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4060 return gfc_trans_g77_array (sym, body);
4062 gfc_get_backend_locus (&loc);
4063 gfc_set_backend_locus (&sym->declared_at);
4065 /* Descriptor type. */
4066 type = TREE_TYPE (tmpdesc);
4067 gcc_assert (GFC_ARRAY_TYPE_P (type));
4068 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4069 dumdesc = build_fold_indirect_ref (dumdesc);
4070 gfc_start_block (&block);
4072 if (sym->ts.type == BT_CHARACTER
4073 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4074 gfc_trans_init_string_length (sym->ts.cl, &block);
4076 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4078 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4079 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4081 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4083 /* For non-constant shape arrays we only check if the first dimension
4084 is contiguous. Repacking higher dimensions wouldn't gain us
4085 anything as we still don't know the array stride. */
4086 partial = gfc_create_var (boolean_type_node, "partial");
4087 TREE_USED (partial) = 1;
4088 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4089 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4090 gfc_add_modify_expr (&block, partial, tmp);
4094 partial = NULL_TREE;
4097 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4098 here, however I think it does the right thing. */
4101 /* Set the first stride. */
4102 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4103 stride = gfc_evaluate_now (stride, &block);
4105 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4106 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4107 gfc_index_one_node, stride);
4108 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4109 gfc_add_modify_expr (&block, stride, tmp);
4111 /* Allow the user to disable array repacking. */
4112 stmt_unpacked = NULL_TREE;
4116 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4117 /* A library call to repack the array if necessary. */
4118 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4119 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4121 stride = gfc_index_one_node;
4124 /* This is for the case where the array data is used directly without
4125 calling the repack function. */
4126 if (no_repack || partial != NULL_TREE)
4127 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4129 stmt_packed = NULL_TREE;
4131 /* Assign the data pointer. */
4132 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4134 /* Don't repack unknown shape arrays when the first stride is 1. */
4135 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4136 stmt_packed, stmt_unpacked);
4139 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4140 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4142 offset = gfc_index_zero_node;
4143 size = gfc_index_one_node;
4145 /* Evaluate the bounds of the array. */
4146 for (n = 0; n < sym->as->rank; n++)
4148 if (checkparm || !sym->as->upper[n])
4150 /* Get the bounds of the actual parameter. */
4151 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4152 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4156 dubound = NULL_TREE;
4157 dlbound = NULL_TREE;
4160 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4161 if (!INTEGER_CST_P (lbound))
4163 gfc_init_se (&se, NULL);
4164 gfc_conv_expr_type (&se, sym->as->lower[n],
4165 gfc_array_index_type);
4166 gfc_add_block_to_block (&block, &se.pre);
4167 gfc_add_modify_expr (&block, lbound, se.expr);
4170 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4171 /* Set the desired upper bound. */
4172 if (sym->as->upper[n])
4174 /* We know what we want the upper bound to be. */
4175 if (!INTEGER_CST_P (ubound))
4177 gfc_init_se (&se, NULL);
4178 gfc_conv_expr_type (&se, sym->as->upper[n],
4179 gfc_array_index_type);
4180 gfc_add_block_to_block (&block, &se.pre);
4181 gfc_add_modify_expr (&block, ubound, se.expr);
4184 /* Check the sizes match. */
4187 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4190 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4192 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4194 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4195 asprintf (&msg, "%s for dimension %d of array '%s'",
4196 gfc_msg_bounds, n+1, sym->name);
4197 gfc_trans_runtime_check (tmp, msg, &block, &loc);
4203 /* For assumed shape arrays move the upper bound by the same amount
4204 as the lower bound. */
4205 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4206 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4207 gfc_add_modify_expr (&block, ubound, tmp);
4209 /* The offset of this dimension. offset = offset - lbound * stride. */
4210 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4211 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4213 /* The size of this dimension, and the stride of the next. */
4214 if (n + 1 < sym->as->rank)
4216 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4218 if (no_repack || partial != NULL_TREE)
4221 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4224 /* Figure out the stride if not a known constant. */
4225 if (!INTEGER_CST_P (stride))
4228 stmt_packed = NULL_TREE;
4231 /* Calculate stride = size * (ubound + 1 - lbound). */
4232 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4233 gfc_index_one_node, lbound);
4234 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4236 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4241 /* Assign the stride. */
4242 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4243 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4244 stmt_unpacked, stmt_packed);
4246 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4247 gfc_add_modify_expr (&block, stride, tmp);
4252 stride = GFC_TYPE_ARRAY_SIZE (type);
4254 if (stride && !INTEGER_CST_P (stride))
4256 /* Calculate size = stride * (ubound + 1 - lbound). */
4257 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4258 gfc_index_one_node, lbound);
4259 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4261 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4262 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4263 gfc_add_modify_expr (&block, stride, tmp);
4268 /* Set the offset. */
4269 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4270 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4272 gfc_trans_vla_type_sizes (sym, &block);
4274 stmt = gfc_finish_block (&block);
4276 gfc_start_block (&block);
4278 /* Only do the entry/initialization code if the arg is present. */
4279 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4280 optional_arg = (sym->attr.optional
4281 || (sym->ns->proc_name->attr.entry_master
4282 && sym->attr.dummy));
4285 tmp = gfc_conv_expr_present (sym);
4286 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4288 gfc_add_expr_to_block (&block, stmt);
4290 /* Add the main function body. */
4291 gfc_add_expr_to_block (&block, body);
4296 gfc_start_block (&cleanup);
4298 if (sym->attr.intent != INTENT_IN)
4300 /* Copy the data back. */
4301 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4302 gfc_add_expr_to_block (&cleanup, tmp);
4305 /* Free the temporary. */
4306 tmp = gfc_call_free (tmpdesc);
4307 gfc_add_expr_to_block (&cleanup, tmp);
4309 stmt = gfc_finish_block (&cleanup);
4311 /* Only do the cleanup if the array was repacked. */
4312 tmp = build_fold_indirect_ref (dumdesc);
4313 tmp = gfc_conv_descriptor_data_get (tmp);
4314 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4315 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4319 tmp = gfc_conv_expr_present (sym);
4320 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4322 gfc_add_expr_to_block (&block, stmt);
4324 /* We don't need to free any memory allocated by internal_pack as it will
4325 be freed at the end of the function by pop_context. */
4326 return gfc_finish_block (&block);
4330 /* Convert an array for passing as an actual argument. Expressions and
4331 vector subscripts are evaluated and stored in a temporary, which is then
4332 passed. For whole arrays the descriptor is passed. For array sections
4333 a modified copy of the descriptor is passed, but using the original data.
4335 This function is also used for array pointer assignments, and there
4338 - se->want_pointer && !se->direct_byref
4339 EXPR is an actual argument. On exit, se->expr contains a
4340 pointer to the array descriptor.
4342 - !se->want_pointer && !se->direct_byref
4343 EXPR is an actual argument to an intrinsic function or the
4344 left-hand side of a pointer assignment. On exit, se->expr
4345 contains the descriptor for EXPR.
4347 - !se->want_pointer && se->direct_byref
4348 EXPR is the right-hand side of a pointer assignment and
4349 se->expr is the descriptor for the previously-evaluated
4350 left-hand side. The function creates an assignment from
4351 EXPR to se->expr. */
4354 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4368 gcc_assert (ss != gfc_ss_terminator);
4370 /* Special case things we know we can pass easily. */
4371 switch (expr->expr_type)
4374 /* If we have a linear array section, we can pass it directly.
4375 Otherwise we need to copy it into a temporary. */
4377 /* Find the SS for the array section. */
4379 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4380 secss = secss->next;
4382 gcc_assert (secss != gfc_ss_terminator);
4383 info = &secss->data.info;
4385 /* Get the descriptor for the array. */
4386 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4387 desc = info->descriptor;
4389 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4392 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4394 /* Create a new descriptor if the array doesn't have one. */
4397 else if (info->ref->u.ar.type == AR_FULL)
4399 else if (se->direct_byref)
4402 full = gfc_full_array_ref_p (info->ref);
4406 if (se->direct_byref)
4408 /* Copy the descriptor for pointer assignments. */
4409 gfc_add_modify_expr (&se->pre, se->expr, desc);
4411 else if (se->want_pointer)
4413 /* We pass full arrays directly. This means that pointers and
4414 allocatable arrays should also work. */
4415 se->expr = build_fold_addr_expr (desc);
4422 if (expr->ts.type == BT_CHARACTER)
4423 se->string_length = gfc_get_expr_charlen (expr);
4430 /* A transformational function return value will be a temporary
4431 array descriptor. We still need to go through the scalarizer
4432 to create the descriptor. Elemental functions ar handled as
4433 arbitrary expressions, i.e. copy to a temporary. */
4435 /* Look for the SS for this function. */
4436 while (secss != gfc_ss_terminator
4437 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4438 secss = secss->next;
4440 if (se->direct_byref)
4442 gcc_assert (secss != gfc_ss_terminator);
4444 /* For pointer assignments pass the descriptor directly. */
4446 se->expr = build_fold_addr_expr (se->expr);
4447 gfc_conv_expr (se, expr);
4451 if (secss == gfc_ss_terminator)
4453 /* Elemental function. */
4459 /* Transformational function. */
4460 info = &secss->data.info;
4466 /* Constant array constructors don't need a temporary. */
4467 if (ss->type == GFC_SS_CONSTRUCTOR
4468 && expr->ts.type != BT_CHARACTER
4469 && gfc_constant_array_constructor_p (expr->value.constructor))
4472 info = &ss->data.info;
4484 /* Something complicated. Copy it into a temporary. */
4492 gfc_init_loopinfo (&loop);
4494 /* Associate the SS with the loop. */
4495 gfc_add_ss_to_loop (&loop, ss);
4497 /* Tell the scalarizer not to bother creating loop variables, etc. */
4499 loop.array_parameter = 1;
4501 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4502 gcc_assert (!se->direct_byref);
4504 /* Setup the scalarizing loops and bounds. */
4505 gfc_conv_ss_startstride (&loop);
4509 /* Tell the scalarizer to make a temporary. */
4510 loop.temp_ss = gfc_get_ss ();
4511 loop.temp_ss->type = GFC_SS_TEMP;
4512 loop.temp_ss->next = gfc_ss_terminator;
4513 if (expr->ts.type == BT_CHARACTER)
4515 if (expr->ts.cl == NULL)
4517 /* This had better be a substring reference! */
4518 gfc_ref *char_ref = expr->ref;
4519 for (; char_ref; char_ref = char_ref->next)
4520 if (char_ref->type == REF_SUBSTRING)
4523 expr->ts.cl = gfc_get_charlen ();
4524 expr->ts.cl->next = char_ref->u.ss.length->next;
4525 char_ref->u.ss.length->next = expr->ts.cl;
4527 mpz_init_set_ui (char_len, 1);
4528 mpz_add (char_len, char_len,
4529 char_ref->u.ss.end->value.integer);
4530 mpz_sub (char_len, char_len,
4531 char_ref->u.ss.start->value.integer);
4532 expr->ts.cl->backend_decl
4533 = gfc_conv_mpz_to_tree (char_len,
4534 gfc_default_character_kind);
4535 /* Cast is necessary for *-charlen refs. */
4536 expr->ts.cl->backend_decl
4537 = convert (gfc_charlen_type_node,
4538 expr->ts.cl->backend_decl);
4539 mpz_clear (char_len);
4542 gcc_assert (char_ref != NULL);
4543 loop.temp_ss->data.temp.type
4544 = gfc_typenode_for_spec (&expr->ts);
4545 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4547 else if (expr->ts.cl->length
4548 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4550 expr->ts.cl->backend_decl
4551 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4552 expr->ts.cl->length->ts.kind);
4553 loop.temp_ss->data.temp.type
4554 = gfc_typenode_for_spec (&expr->ts);
4555 loop.temp_ss->string_length
4556 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4560 loop.temp_ss->data.temp.type
4561 = gfc_typenode_for_spec (&expr->ts);
4562 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4564 se->string_length = loop.temp_ss->string_length;
4568 loop.temp_ss->data.temp.type
4569 = gfc_typenode_for_spec (&expr->ts);
4570 loop.temp_ss->string_length = NULL;
4572 loop.temp_ss->data.temp.dimen = loop.dimen;
4573 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4576 gfc_conv_loop_setup (&loop);
4580 /* Copy into a temporary and pass that. We don't need to copy the data
4581 back because expressions and vector subscripts must be INTENT_IN. */
4582 /* TODO: Optimize passing function return values. */
4586 /* Start the copying loops. */
4587 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4588 gfc_mark_ss_chain_used (ss, 1);
4589 gfc_start_scalarized_body (&loop, &block);
4591 /* Copy each data element. */
4592 gfc_init_se (&lse, NULL);
4593 gfc_copy_loopinfo_to_se (&lse, &loop);
4594 gfc_init_se (&rse, NULL);
4595 gfc_copy_loopinfo_to_se (&rse, &loop);
4597 lse.ss = loop.temp_ss;
4600 gfc_conv_scalarized_array_ref (&lse, NULL);
4601 if (expr->ts.type == BT_CHARACTER)
4603 gfc_conv_expr (&rse, expr);
4604 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4605 rse.expr = build_fold_indirect_ref (rse.expr);
4608 gfc_conv_expr_val (&rse, expr);
4610 gfc_add_block_to_block (&block, &rse.pre);
4611 gfc_add_block_to_block (&block, &lse.pre);
4613 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4615 /* Finish the copying loops. */
4616 gfc_trans_scalarizing_loops (&loop, &block);
4618 desc = loop.temp_ss->data.info.descriptor;
4620 gcc_assert (is_gimple_lvalue (desc));
4622 else if (expr->expr_type == EXPR_FUNCTION)
4624 desc = info->descriptor;
4625 se->string_length = ss->string_length;
4629 /* We pass sections without copying to a temporary. Make a new
4630 descriptor and point it at the section we want. The loop variable
4631 limits will be the limits of the section.
4632 A function may decide to repack the array to speed up access, but
4633 we're not bothered about that here. */
4642 /* Set the string_length for a character array. */
4643 if (expr->ts.type == BT_CHARACTER)
4644 se->string_length = gfc_get_expr_charlen (expr);
4646 desc = info->descriptor;
4647 gcc_assert (secss && secss != gfc_ss_terminator);
4648 if (se->direct_byref)
4650 /* For pointer assignments we fill in the destination. */
4652 parmtype = TREE_TYPE (parm);
4656 /* Otherwise make a new one. */
4657 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4658 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4659 loop.from, loop.to, 0);
4660 parm = gfc_create_var (parmtype, "parm");
4663 offset = gfc_index_zero_node;
4666 /* The following can be somewhat confusing. We have two
4667 descriptors, a new one and the original array.
4668 {parm, parmtype, dim} refer to the new one.
4669 {desc, type, n, secss, loop} refer to the original, which maybe
4670 a descriptorless array.
4671 The bounds of the scalarization are the bounds of the section.
4672 We don't have to worry about numeric overflows when calculating
4673 the offsets because all elements are within the array data. */
4675 /* Set the dtype. */
4676 tmp = gfc_conv_descriptor_dtype (parm);
4677 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4679 if (se->direct_byref)
4680 base = gfc_index_zero_node;
4681 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4682 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4686 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4687 for (n = 0; n < ndim; n++)
4689 stride = gfc_conv_array_stride (desc, n);
4691 /* Work out the offset. */
4693 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4695 gcc_assert (info->subscript[n]
4696 && info->subscript[n]->type == GFC_SS_SCALAR);
4697 start = info->subscript[n]->data.scalar.expr;
4701 /* Check we haven't somehow got out of sync. */
4702 gcc_assert (info->dim[dim] == n);
4704 /* Evaluate and remember the start of the section. */
4705 start = info->start[dim];
4706 stride = gfc_evaluate_now (stride, &loop.pre);
4709 tmp = gfc_conv_array_lbound (desc, n);
4710 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4712 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4713 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4716 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4718 /* For elemental dimensions, we only need the offset. */
4722 /* Vector subscripts need copying and are handled elsewhere. */
4724 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4726 /* Set the new lower bound. */
4727 from = loop.from[dim];
4730 /* If we have an array section or are assigning to a pointer,
4731 make sure that the lower bound is 1. References to the full
4732 array should otherwise keep the original bounds. */
4734 || info->ref->u.ar.type != AR_FULL
4735 || se->direct_byref)
4736 && !integer_onep (from))
4738 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4739 gfc_index_one_node, from);
4740 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4741 from = gfc_index_one_node;
4743 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4744 gfc_add_modify_expr (&loop.pre, tmp, from);
4746 /* Set the new upper bound. */
4747 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4748 gfc_add_modify_expr (&loop.pre, tmp, to);
4750 /* Multiply the stride by the section stride to get the
4752 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4753 stride, info->stride[dim]);
4755 if (se->direct_byref)
4757 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4760 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4762 tmp = gfc_conv_array_lbound (desc, n);
4763 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4764 tmp, loop.from[dim]);
4765 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
4766 tmp, gfc_conv_array_stride (desc, n));
4767 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
4771 /* Store the new stride. */
4772 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4773 gfc_add_modify_expr (&loop.pre, tmp, stride);
4778 if (se->data_not_needed)
4779 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4782 /* Point the data pointer at the first element in the section. */
4783 tmp = gfc_conv_array_data (desc);
4784 tmp = build_fold_indirect_ref (tmp);
4785 tmp = gfc_build_array_ref (tmp, offset);
4786 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4787 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4790 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4791 && !se->data_not_needed)
4793 /* Set the offset. */
4794 tmp = gfc_conv_descriptor_offset (parm);
4795 gfc_add_modify_expr (&loop.pre, tmp, base);
4799 /* Only the callee knows what the correct offset it, so just set
4801 tmp = gfc_conv_descriptor_offset (parm);
4802 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4807 if (!se->direct_byref)
4809 /* Get a pointer to the new descriptor. */
4810 if (se->want_pointer)
4811 se->expr = build_fold_addr_expr (desc);
4816 gfc_add_block_to_block (&se->pre, &loop.pre);
4817 gfc_add_block_to_block (&se->post, &loop.post);
4819 /* Cleanup the scalarizer. */
4820 gfc_cleanup_loop (&loop);
4824 /* Convert an array for passing as an actual parameter. */
4825 /* TODO: Optimize passing g77 arrays. */
4828 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4832 tree tmp = NULL_TREE;
4834 tree parent = DECL_CONTEXT (current_function_decl);
4835 bool full_array_var, this_array_result;
4839 full_array_var = (expr->expr_type == EXPR_VARIABLE
4840 && expr->ref->u.ar.type == AR_FULL);
4841 sym = full_array_var ? expr->symtree->n.sym : NULL;
4843 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
4845 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
4846 expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
4847 se->string_length = expr->ts.cl->backend_decl;
4850 /* Is this the result of the enclosing procedure? */
4851 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4852 if (this_array_result
4853 && (sym->backend_decl != current_function_decl)
4854 && (sym->backend_decl != parent))
4855 this_array_result = false;
4857 /* Passing address of the array if it is not pointer or assumed-shape. */
4858 if (full_array_var && g77 && !this_array_result)
4860 tmp = gfc_get_symbol_decl (sym);
4862 if (sym->ts.type == BT_CHARACTER)
4863 se->string_length = sym->ts.cl->backend_decl;
4864 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4865 && !sym->attr.allocatable)
4867 /* Some variables are declared directly, others are declared as
4868 pointers and allocated on the heap. */
4869 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4872 se->expr = build_fold_addr_expr (tmp);
4875 if (sym->attr.allocatable)
4877 if (sym->attr.dummy)
4879 gfc_conv_expr_descriptor (se, expr, ss);
4880 se->expr = gfc_conv_array_data (se->expr);
4883 se->expr = gfc_conv_array_data (tmp);
4888 if (this_array_result)
4890 /* Result of the enclosing function. */
4891 gfc_conv_expr_descriptor (se, expr, ss);
4892 se->expr = build_fold_addr_expr (se->expr);
4894 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
4895 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4896 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
4902 /* Every other type of array. */
4903 se->want_pointer = 1;
4904 gfc_conv_expr_descriptor (se, expr, ss);
4908 /* Deallocate the allocatable components of structures that are
4910 if (expr->ts.type == BT_DERIVED
4911 && expr->ts.derived->attr.alloc_comp
4912 && expr->expr_type != EXPR_VARIABLE)
4914 tmp = build_fold_indirect_ref (se->expr);
4915 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4916 gfc_add_expr_to_block (&se->post, tmp);
4922 /* Repack the array. */
4923 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
4924 ptr = gfc_evaluate_now (ptr, &se->pre);
4927 gfc_start_block (&block);
4929 /* Copy the data back. */
4930 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
4931 gfc_add_expr_to_block (&block, tmp);
4933 /* Free the temporary. */
4934 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
4935 gfc_add_expr_to_block (&block, tmp);
4937 stmt = gfc_finish_block (&block);
4939 gfc_init_block (&block);
4940 /* Only if it was repacked. This code needs to be executed before the
4941 loop cleanup code. */
4942 tmp = build_fold_indirect_ref (desc);
4943 tmp = gfc_conv_array_data (tmp);
4944 tmp = build2 (NE_EXPR, boolean_type_node,
4945 fold_convert (TREE_TYPE (tmp), ptr), tmp);
4946 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4948 gfc_add_expr_to_block (&block, tmp);
4949 gfc_add_block_to_block (&block, &se->post);
4951 gfc_init_block (&se->post);
4952 gfc_add_block_to_block (&se->post, &block);
4957 /* Generate code to deallocate an array, if it is allocated. */
4960 gfc_trans_dealloc_allocated (tree descriptor)
4967 gfc_start_block (&block);
4969 var = gfc_conv_descriptor_data_get (descriptor);
4971 tmp = gfc_create_var (gfc_array_index_type, NULL);
4972 ptr = build_fold_addr_expr (tmp);
4974 /* Call array_deallocate with an int* present in the second argument.
4975 Although it is ignored here, it's presence ensures that arrays that
4976 are already deallocated are ignored. */
4977 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
4978 gfc_add_expr_to_block (&block, tmp);
4980 /* Zero the data pointer. */
4981 tmp = build2 (MODIFY_EXPR, void_type_node,
4982 var, build_int_cst (TREE_TYPE (var), 0));
4983 gfc_add_expr_to_block (&block, tmp);
4985 return gfc_finish_block (&block);
4989 /* This helper function calculates the size in words of a full array. */
4992 get_full_array_size (stmtblock_t *block, tree decl, int rank)
4997 idx = gfc_rank_cst[rank - 1];
4998 nelems = gfc_conv_descriptor_ubound (decl, idx);
4999 tmp = gfc_conv_descriptor_lbound (decl, idx);
5000 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5001 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
5002 tmp, gfc_index_one_node);
5003 tmp = gfc_evaluate_now (tmp, block);
5005 nelems = gfc_conv_descriptor_stride (decl, idx);
5006 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5007 return gfc_evaluate_now (tmp, block);
5011 /* Allocate dest to the same size as src, and copy src -> dest. */
5014 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5023 /* If the source is null, set the destination to null. */
5024 gfc_init_block (&block);
5025 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5026 null_data = gfc_finish_block (&block);
5028 gfc_init_block (&block);
5030 nelems = get_full_array_size (&block, src, rank);
5031 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5032 fold_convert (gfc_array_index_type,
5033 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5035 /* Allocate memory to the destination. */
5036 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5038 gfc_conv_descriptor_data_set (&block, dest, tmp);
5040 /* We know the temporary and the value will be the same length,
5041 so can use memcpy. */
5042 tmp = built_in_decls[BUILT_IN_MEMCPY];
5043 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5044 gfc_conv_descriptor_data_get (src), size);
5045 gfc_add_expr_to_block (&block, tmp);
5046 tmp = gfc_finish_block (&block);
5048 /* Null the destination if the source is null; otherwise do
5049 the allocate and copy. */
5050 null_cond = gfc_conv_descriptor_data_get (src);
5051 null_cond = convert (pvoid_type_node, null_cond);
5052 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5054 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5058 /* Recursively traverse an object of derived type, generating code to
5059 deallocate, nullify or copy allocatable components. This is the work horse
5060 function for the functions named in this enum. */
5062 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5065 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5066 tree dest, int rank, int purpose)
5070 stmtblock_t fnblock;
5071 stmtblock_t loopbody;
5081 tree null_cond = NULL_TREE;
5083 gfc_init_block (&fnblock);
5085 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5086 decl = build_fold_indirect_ref (decl);
5088 /* If this an array of derived types with allocatable components
5089 build a loop and recursively call this function. */
5090 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5091 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5093 tmp = gfc_conv_array_data (decl);
5094 var = build_fold_indirect_ref (tmp);
5096 /* Get the number of elements - 1 and set the counter. */
5097 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5099 /* Use the descriptor for an allocatable array. Since this
5100 is a full array reference, we only need the descriptor
5101 information from dimension = rank. */
5102 tmp = get_full_array_size (&fnblock, decl, rank);
5103 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
5104 tmp, gfc_index_one_node);
5106 null_cond = gfc_conv_descriptor_data_get (decl);
5107 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5108 build_int_cst (TREE_TYPE (null_cond), 0));
5112 /* Otherwise use the TYPE_DOMAIN information. */
5113 tmp = array_type_nelts (TREE_TYPE (decl));
5114 tmp = fold_convert (gfc_array_index_type, tmp);
5117 /* Remember that this is, in fact, the no. of elements - 1. */
5118 nelems = gfc_evaluate_now (tmp, &fnblock);
5119 index = gfc_create_var (gfc_array_index_type, "S");
5121 /* Build the body of the loop. */
5122 gfc_init_block (&loopbody);
5124 vref = gfc_build_array_ref (var, index);
5126 if (purpose == COPY_ALLOC_COMP)
5128 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5129 gfc_add_expr_to_block (&fnblock, tmp);
5131 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5132 dref = gfc_build_array_ref (tmp, index);
5133 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5136 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5138 gfc_add_expr_to_block (&loopbody, tmp);
5140 /* Build the loop and return. */
5141 gfc_init_loopinfo (&loop);
5143 loop.from[0] = gfc_index_zero_node;
5144 loop.loopvar[0] = index;
5145 loop.to[0] = nelems;
5146 gfc_trans_scalarizing_loops (&loop, &loopbody);
5147 gfc_add_block_to_block (&fnblock, &loop.pre);
5149 tmp = gfc_finish_block (&fnblock);
5150 if (null_cond != NULL_TREE)
5151 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5156 /* Otherwise, act on the components or recursively call self to
5157 act on a chain of components. */
5158 for (c = der_type->components; c; c = c->next)
5160 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5161 && c->ts.derived->attr.alloc_comp;
5162 cdecl = c->backend_decl;
5163 ctype = TREE_TYPE (cdecl);
5167 case DEALLOCATE_ALLOC_COMP:
5168 /* Do not deallocate the components of ultimate pointer
5170 if (cmp_has_alloc_comps && !c->pointer)
5172 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5173 rank = c->as ? c->as->rank : 0;
5174 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5176 gfc_add_expr_to_block (&fnblock, tmp);
5181 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5182 tmp = gfc_trans_dealloc_allocated (comp);
5183 gfc_add_expr_to_block (&fnblock, tmp);
5187 case NULLIFY_ALLOC_COMP:
5190 else if (c->allocatable)
5192 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5193 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5195 else if (cmp_has_alloc_comps)
5197 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5198 rank = c->as ? c->as->rank : 0;
5199 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5201 gfc_add_expr_to_block (&fnblock, tmp);
5205 case COPY_ALLOC_COMP:
5209 /* We need source and destination components. */
5210 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5211 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5212 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5214 if (c->allocatable && !cmp_has_alloc_comps)
5216 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5217 gfc_add_expr_to_block (&fnblock, tmp);
5220 if (cmp_has_alloc_comps)
5222 rank = c->as ? c->as->rank : 0;
5223 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5224 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5225 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5227 gfc_add_expr_to_block (&fnblock, tmp);
5237 return gfc_finish_block (&fnblock);
5240 /* Recursively traverse an object of derived type, generating code to
5241 nullify allocatable components. */
5244 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5246 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5247 NULLIFY_ALLOC_COMP);
5251 /* Recursively traverse an object of derived type, generating code to
5252 deallocate allocatable components. */
5255 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5257 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5258 DEALLOCATE_ALLOC_COMP);
5262 /* Recursively traverse an object of derived type, generating code to
5263 copy its allocatable components. */
5266 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5268 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5272 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5273 Do likewise, recursively if necessary, with the allocatable components of
5277 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5282 stmtblock_t fnblock;
5285 bool sym_has_alloc_comp;
5287 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5288 && sym->ts.derived->attr.alloc_comp;
5290 /* Make sure the frontend gets these right. */
5291 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5292 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5293 "allocatable attribute or derived type without allocatable "
5296 gfc_init_block (&fnblock);
5298 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5299 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5301 if (sym->ts.type == BT_CHARACTER
5302 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5304 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5305 gfc_trans_vla_type_sizes (sym, &fnblock);
5308 /* Dummy and use associated variables don't need anything special. */
5309 if (sym->attr.dummy || sym->attr.use_assoc)
5311 gfc_add_expr_to_block (&fnblock, body);
5313 return gfc_finish_block (&fnblock);
5316 gfc_get_backend_locus (&loc);
5317 gfc_set_backend_locus (&sym->declared_at);
5318 descriptor = sym->backend_decl;
5320 /* Although static, derived types with default initializers and
5321 allocatable components must not be nulled wholesale; instead they
5322 are treated component by component. */
5323 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5325 /* SAVEd variables are not freed on exit. */
5326 gfc_trans_static_array_pointer (sym);
5330 /* Get the descriptor type. */
5331 type = TREE_TYPE (sym->backend_decl);
5333 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5335 if (!sym->attr.save)
5337 rank = sym->as ? sym->as->rank : 0;
5338 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5339 gfc_add_expr_to_block (&fnblock, tmp);
5342 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5344 /* If the backend_decl is not a descriptor, we must have a pointer
5346 descriptor = build_fold_indirect_ref (sym->backend_decl);
5347 type = TREE_TYPE (descriptor);
5350 /* NULLIFY the data pointer. */
5351 if (GFC_DESCRIPTOR_TYPE_P (type))
5352 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5354 gfc_add_expr_to_block (&fnblock, body);
5356 gfc_set_backend_locus (&loc);
5358 /* Allocatable arrays need to be freed when they go out of scope.
5359 The allocatable components of pointers must not be touched. */
5360 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5361 && !sym->attr.pointer && !sym->attr.save)
5364 rank = sym->as ? sym->as->rank : 0;
5365 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5366 gfc_add_expr_to_block (&fnblock, tmp);
5369 if (sym->attr.allocatable)
5371 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5372 gfc_add_expr_to_block (&fnblock, tmp);
5375 return gfc_finish_block (&fnblock);
5378 /************ Expression Walking Functions ******************/
5380 /* Walk a variable reference.
5382 Possible extension - multiple component subscripts.
5383 x(:,:) = foo%a(:)%b(:)
5385 forall (i=..., j=...)
5386 x(i,j) = foo%a(j)%b(i)
5388 This adds a fair amount of complexity because you need to deal with more
5389 than one ref. Maybe handle in a similar manner to vector subscripts.
5390 Maybe not worth the effort. */
5394 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5402 for (ref = expr->ref; ref; ref = ref->next)
5403 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5406 for (; ref; ref = ref->next)
5408 if (ref->type == REF_SUBSTRING)
5410 newss = gfc_get_ss ();
5411 newss->type = GFC_SS_SCALAR;
5412 newss->expr = ref->u.ss.start;
5416 newss = gfc_get_ss ();
5417 newss->type = GFC_SS_SCALAR;
5418 newss->expr = ref->u.ss.end;
5423 /* We're only interested in array sections from now on. */
5424 if (ref->type != REF_ARRAY)
5431 for (n = 0; n < ar->dimen; n++)
5433 newss = gfc_get_ss ();
5434 newss->type = GFC_SS_SCALAR;
5435 newss->expr = ar->start[n];
5442 newss = gfc_get_ss ();
5443 newss->type = GFC_SS_SECTION;
5446 newss->data.info.dimen = ar->as->rank;
5447 newss->data.info.ref = ref;
5449 /* Make sure array is the same as array(:,:), this way
5450 we don't need to special case all the time. */
5451 ar->dimen = ar->as->rank;
5452 for (n = 0; n < ar->dimen; n++)
5454 newss->data.info.dim[n] = n;
5455 ar->dimen_type[n] = DIMEN_RANGE;
5457 gcc_assert (ar->start[n] == NULL);
5458 gcc_assert (ar->end[n] == NULL);
5459 gcc_assert (ar->stride[n] == NULL);
5465 newss = gfc_get_ss ();
5466 newss->type = GFC_SS_SECTION;
5469 newss->data.info.dimen = 0;
5470 newss->data.info.ref = ref;
5474 /* We add SS chains for all the subscripts in the section. */
5475 for (n = 0; n < ar->dimen; n++)
5479 switch (ar->dimen_type[n])
5482 /* Add SS for elemental (scalar) subscripts. */
5483 gcc_assert (ar->start[n]);
5484 indexss = gfc_get_ss ();
5485 indexss->type = GFC_SS_SCALAR;
5486 indexss->expr = ar->start[n];
5487 indexss->next = gfc_ss_terminator;
5488 indexss->loop_chain = gfc_ss_terminator;
5489 newss->data.info.subscript[n] = indexss;
5493 /* We don't add anything for sections, just remember this
5494 dimension for later. */
5495 newss->data.info.dim[newss->data.info.dimen] = n;
5496 newss->data.info.dimen++;
5500 /* Create a GFC_SS_VECTOR index in which we can store
5501 the vector's descriptor. */
5502 indexss = gfc_get_ss ();
5503 indexss->type = GFC_SS_VECTOR;
5504 indexss->expr = ar->start[n];
5505 indexss->next = gfc_ss_terminator;
5506 indexss->loop_chain = gfc_ss_terminator;
5507 newss->data.info.subscript[n] = indexss;
5508 newss->data.info.dim[newss->data.info.dimen] = n;
5509 newss->data.info.dimen++;
5513 /* We should know what sort of section it is by now. */
5517 /* We should have at least one non-elemental dimension. */
5518 gcc_assert (newss->data.info.dimen > 0);
5523 /* We should know what sort of section it is by now. */
5532 /* Walk an expression operator. If only one operand of a binary expression is
5533 scalar, we must also add the scalar term to the SS chain. */
5536 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5542 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5543 if (expr->value.op.op2 == NULL)
5546 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5548 /* All operands are scalar. Pass back and let the caller deal with it. */
5552 /* All operands require scalarization. */
5553 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5556 /* One of the operands needs scalarization, the other is scalar.
5557 Create a gfc_ss for the scalar expression. */
5558 newss = gfc_get_ss ();
5559 newss->type = GFC_SS_SCALAR;
5562 /* First operand is scalar. We build the chain in reverse order, so
5563 add the scarar SS after the second operand. */
5565 while (head && head->next != ss)
5567 /* Check we haven't somehow broken the chain. */
5571 newss->expr = expr->value.op.op1;
5573 else /* head2 == head */
5575 gcc_assert (head2 == head);
5576 /* Second operand is scalar. */
5577 newss->next = head2;
5579 newss->expr = expr->value.op.op2;
5586 /* Reverse a SS chain. */
5589 gfc_reverse_ss (gfc_ss * ss)
5594 gcc_assert (ss != NULL);
5596 head = gfc_ss_terminator;
5597 while (ss != gfc_ss_terminator)
5600 /* Check we didn't somehow break the chain. */
5601 gcc_assert (next != NULL);
5611 /* Walk the arguments of an elemental function. */
5614 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5622 head = gfc_ss_terminator;
5625 for (; arg; arg = arg->next)
5630 newss = gfc_walk_subexpr (head, arg->expr);
5633 /* Scalar argument. */
5634 newss = gfc_get_ss ();
5636 newss->expr = arg->expr;
5646 while (tail->next != gfc_ss_terminator)
5653 /* If all the arguments are scalar we don't need the argument SS. */
5654 gfc_free_ss_chain (head);
5659 /* Add it onto the existing chain. */
5665 /* Walk a function call. Scalar functions are passed back, and taken out of
5666 scalarization loops. For elemental functions we walk their arguments.
5667 The result of functions returning arrays is stored in a temporary outside
5668 the loop, so that the function is only called once. Hence we do not need
5669 to walk their arguments. */
5672 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5675 gfc_intrinsic_sym *isym;
5678 isym = expr->value.function.isym;
5680 /* Handle intrinsic functions separately. */
5682 return gfc_walk_intrinsic_function (ss, expr, isym);
5684 sym = expr->value.function.esym;
5686 sym = expr->symtree->n.sym;
5688 /* A function that returns arrays. */
5689 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5691 newss = gfc_get_ss ();
5692 newss->type = GFC_SS_FUNCTION;
5695 newss->data.info.dimen = expr->rank;
5699 /* Walk the parameters of an elemental function. For now we always pass
5701 if (sym->attr.elemental)
5702 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5705 /* Scalar functions are OK as these are evaluated outside the scalarization
5706 loop. Pass back and let the caller deal with it. */
5711 /* An array temporary is constructed for array constructors. */
5714 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5719 newss = gfc_get_ss ();
5720 newss->type = GFC_SS_CONSTRUCTOR;
5723 newss->data.info.dimen = expr->rank;
5724 for (n = 0; n < expr->rank; n++)
5725 newss->data.info.dim[n] = n;
5731 /* Walk an expression. Add walked expressions to the head of the SS chain.
5732 A wholly scalar expression will not be added. */
5735 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5739 switch (expr->expr_type)
5742 head = gfc_walk_variable_expr (ss, expr);
5746 head = gfc_walk_op_expr (ss, expr);
5750 head = gfc_walk_function_expr (ss, expr);
5755 case EXPR_STRUCTURE:
5756 /* Pass back and let the caller deal with it. */
5760 head = gfc_walk_array_constructor (ss, expr);
5763 case EXPR_SUBSTRING:
5764 /* Pass back and let the caller deal with it. */
5768 internal_error ("bad expression type during walk (%d)",
5775 /* Entry point for expression walking.
5776 A return value equal to the passed chain means this is
5777 a scalar expression. It is up to the caller to take whatever action is
5778 necessary to translate these. */
5781 gfc_walk_expr (gfc_expr * expr)
5785 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5786 return gfc_reverse_ss (res);