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, except where the loop
789 if (!integer_zerop (loop->from[0]))
790 dest_info->offset = gfc_conv_descriptor_offset (src);
792 dest_info->offset = gfc_index_zero_node;
794 gfc_add_modify_expr (&se->pre,
795 gfc_conv_descriptor_offset (dest),
798 if (dest_info->dimen > loop->temp_dim)
799 loop->temp_dim = dest_info->dimen;
803 /* Return the number of iterations in a loop that starts at START,
804 ends at END, and has step STEP. */
807 gfc_get_iteration_count (tree start, tree end, tree step)
812 type = TREE_TYPE (step);
813 tmp = fold_build2 (MINUS_EXPR, type, end, start);
814 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
815 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
816 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
817 return fold_convert (gfc_array_index_type, tmp);
821 /* Extend the data in array DESC by EXTRA elements. */
824 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
831 if (integer_zerop (extra))
834 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
836 /* Add EXTRA to the upper bound. */
837 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
838 gfc_add_modify_expr (pblock, ubound, tmp);
840 /* Get the value of the current data pointer. */
841 arg0 = gfc_conv_descriptor_data_get (desc);
843 /* Calculate the new array size. */
844 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
845 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
846 arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
847 fold_convert (gfc_array_index_type, size));
849 /* Pick the realloc function. */
850 if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8)
851 tmp = gfor_fndecl_internal_realloc;
855 /* Set the new data pointer. */
856 tmp = build_call_expr (tmp, 2, arg0, arg1);
857 gfc_conv_descriptor_data_set (pblock, desc, tmp);
861 /* Return true if the bounds of iterator I can only be determined
865 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
867 return (i->start->expr_type != EXPR_CONSTANT
868 || i->end->expr_type != EXPR_CONSTANT
869 || i->step->expr_type != EXPR_CONSTANT);
873 /* Split the size of constructor element EXPR into the sum of two terms,
874 one of which can be determined at compile time and one of which must
875 be calculated at run time. Set *SIZE to the former and return true
876 if the latter might be nonzero. */
879 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
881 if (expr->expr_type == EXPR_ARRAY)
882 return gfc_get_array_constructor_size (size, expr->value.constructor);
883 else if (expr->rank > 0)
885 /* Calculate everything at run time. */
886 mpz_set_ui (*size, 0);
891 /* A single element. */
892 mpz_set_ui (*size, 1);
898 /* Like gfc_get_array_constructor_element_size, but applied to the whole
899 of array constructor C. */
902 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
909 mpz_set_ui (*size, 0);
914 for (; c; c = c->next)
917 if (i && gfc_iterator_has_dynamic_bounds (i))
921 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
924 /* Multiply the static part of the element size by the
925 number of iterations. */
926 mpz_sub (val, i->end->value.integer, i->start->value.integer);
927 mpz_fdiv_q (val, val, i->step->value.integer);
928 mpz_add_ui (val, val, 1);
929 if (mpz_sgn (val) > 0)
930 mpz_mul (len, len, val);
934 mpz_add (*size, *size, len);
943 /* Make sure offset is a variable. */
946 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
949 /* We should have already created the offset variable. We cannot
950 create it here because we may be in an inner scope. */
951 gcc_assert (*offsetvar != NULL_TREE);
952 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
953 *poffset = *offsetvar;
954 TREE_USED (*offsetvar) = 1;
958 /* Assign an element of an array constructor. */
961 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
962 tree offset, gfc_se * se, gfc_expr * expr)
966 gfc_conv_expr (se, expr);
968 /* Store the value. */
969 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
970 tmp = gfc_build_array_ref (tmp, offset);
971 if (expr->ts.type == BT_CHARACTER)
973 gfc_conv_string_parameter (se);
974 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
976 /* The temporary is an array of pointers. */
977 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
978 gfc_add_modify_expr (&se->pre, tmp, se->expr);
982 /* The temporary is an array of string values. */
983 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
984 /* We know the temporary and the value will be the same length,
985 so can use memcpy. */
986 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
987 tmp, se->expr, se->string_length);
988 gfc_add_expr_to_block (&se->pre, tmp);
993 /* TODO: Should the frontend already have done this conversion? */
994 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
995 gfc_add_modify_expr (&se->pre, tmp, se->expr);
998 gfc_add_block_to_block (pblock, &se->pre);
999 gfc_add_block_to_block (pblock, &se->post);
1003 /* Add the contents of an array to the constructor. DYNAMIC is as for
1004 gfc_trans_array_constructor_value. */
1007 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1008 tree type ATTRIBUTE_UNUSED,
1009 tree desc, gfc_expr * expr,
1010 tree * poffset, tree * offsetvar,
1021 /* We need this to be a variable so we can increment it. */
1022 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1024 gfc_init_se (&se, NULL);
1026 /* Walk the array expression. */
1027 ss = gfc_walk_expr (expr);
1028 gcc_assert (ss != gfc_ss_terminator);
1030 /* Initialize the scalarizer. */
1031 gfc_init_loopinfo (&loop);
1032 gfc_add_ss_to_loop (&loop, ss);
1034 /* Initialize the loop. */
1035 gfc_conv_ss_startstride (&loop);
1036 gfc_conv_loop_setup (&loop);
1038 /* Make sure the constructed array has room for the new data. */
1041 /* Set SIZE to the total number of elements in the subarray. */
1042 size = gfc_index_one_node;
1043 for (n = 0; n < loop.dimen; n++)
1045 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1046 gfc_index_one_node);
1047 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1050 /* Grow the constructed array by SIZE elements. */
1051 gfc_grow_array (&loop.pre, desc, size);
1054 /* Make the loop body. */
1055 gfc_mark_ss_chain_used (ss, 1);
1056 gfc_start_scalarized_body (&loop, &body);
1057 gfc_copy_loopinfo_to_se (&se, &loop);
1060 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1061 gcc_assert (se.ss == gfc_ss_terminator);
1063 /* Increment the offset. */
1064 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1065 gfc_add_modify_expr (&body, *poffset, tmp);
1067 /* Finish the loop. */
1068 gfc_trans_scalarizing_loops (&loop, &body);
1069 gfc_add_block_to_block (&loop.pre, &loop.post);
1070 tmp = gfc_finish_block (&loop.pre);
1071 gfc_add_expr_to_block (pblock, tmp);
1073 gfc_cleanup_loop (&loop);
1077 /* Assign the values to the elements of an array constructor. DYNAMIC
1078 is true if descriptor DESC only contains enough data for the static
1079 size calculated by gfc_get_array_constructor_size. When true, memory
1080 for the dynamic parts must be allocated using realloc. */
1083 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1084 tree desc, gfc_constructor * c,
1085 tree * poffset, tree * offsetvar,
1094 for (; c; c = c->next)
1096 /* If this is an iterator or an array, the offset must be a variable. */
1097 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1098 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1100 gfc_start_block (&body);
1102 if (c->expr->expr_type == EXPR_ARRAY)
1104 /* Array constructors can be nested. */
1105 gfc_trans_array_constructor_value (&body, type, desc,
1106 c->expr->value.constructor,
1107 poffset, offsetvar, dynamic);
1109 else if (c->expr->rank > 0)
1111 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1112 poffset, offsetvar, dynamic);
1116 /* This code really upsets the gimplifier so don't bother for now. */
1123 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1130 /* Scalar values. */
1131 gfc_init_se (&se, NULL);
1132 gfc_trans_array_ctor_element (&body, desc, *poffset,
1135 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1136 *poffset, gfc_index_one_node);
1140 /* Collect multiple scalar constants into a constructor. */
1148 /* Count the number of consecutive scalar constants. */
1149 while (p && !(p->iterator
1150 || p->expr->expr_type != EXPR_CONSTANT))
1152 gfc_init_se (&se, NULL);
1153 gfc_conv_constant (&se, p->expr);
1154 if (p->expr->ts.type == BT_CHARACTER
1155 && POINTER_TYPE_P (type))
1157 /* For constant character array constructors we build
1158 an array of pointers. */
1159 se.expr = gfc_build_addr_expr (pchar_type_node,
1163 list = tree_cons (NULL_TREE, se.expr, list);
1168 bound = build_int_cst (NULL_TREE, n - 1);
1169 /* Create an array type to hold them. */
1170 tmptype = build_range_type (gfc_array_index_type,
1171 gfc_index_zero_node, bound);
1172 tmptype = build_array_type (type, tmptype);
1174 init = build_constructor_from_list (tmptype, nreverse (list));
1175 TREE_CONSTANT (init) = 1;
1176 TREE_INVARIANT (init) = 1;
1177 TREE_STATIC (init) = 1;
1178 /* Create a static variable to hold the data. */
1179 tmp = gfc_create_var (tmptype, "data");
1180 TREE_STATIC (tmp) = 1;
1181 TREE_CONSTANT (tmp) = 1;
1182 TREE_INVARIANT (tmp) = 1;
1183 TREE_READONLY (tmp) = 1;
1184 DECL_INITIAL (tmp) = init;
1187 /* Use BUILTIN_MEMCPY to assign the values. */
1188 tmp = gfc_conv_descriptor_data_get (desc);
1189 tmp = build_fold_indirect_ref (tmp);
1190 tmp = gfc_build_array_ref (tmp, *poffset);
1191 tmp = build_fold_addr_expr (tmp);
1192 init = build_fold_addr_expr (init);
1194 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1195 bound = build_int_cst (NULL_TREE, n * size);
1196 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1198 gfc_add_expr_to_block (&body, tmp);
1200 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1202 build_int_cst (gfc_array_index_type, n));
1204 if (!INTEGER_CST_P (*poffset))
1206 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1207 *poffset = *offsetvar;
1211 /* The frontend should already have done any expansions possible
1215 /* Pass the code as is. */
1216 tmp = gfc_finish_block (&body);
1217 gfc_add_expr_to_block (pblock, tmp);
1221 /* Build the implied do-loop. */
1231 loopbody = gfc_finish_block (&body);
1233 gfc_init_se (&se, NULL);
1234 gfc_conv_expr (&se, c->iterator->var);
1235 gfc_add_block_to_block (pblock, &se.pre);
1238 /* Make a temporary, store the current value in that
1239 and return it, once the loop is done. */
1240 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1241 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1243 /* Initialize the loop. */
1244 gfc_init_se (&se, NULL);
1245 gfc_conv_expr_val (&se, c->iterator->start);
1246 gfc_add_block_to_block (pblock, &se.pre);
1247 gfc_add_modify_expr (pblock, loopvar, se.expr);
1249 gfc_init_se (&se, NULL);
1250 gfc_conv_expr_val (&se, c->iterator->end);
1251 gfc_add_block_to_block (pblock, &se.pre);
1252 end = gfc_evaluate_now (se.expr, pblock);
1254 gfc_init_se (&se, NULL);
1255 gfc_conv_expr_val (&se, c->iterator->step);
1256 gfc_add_block_to_block (pblock, &se.pre);
1257 step = gfc_evaluate_now (se.expr, pblock);
1259 /* If this array expands dynamically, and the number of iterations
1260 is not constant, we won't have allocated space for the static
1261 part of C->EXPR's size. Do that now. */
1262 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1264 /* Get the number of iterations. */
1265 tmp = gfc_get_iteration_count (loopvar, end, step);
1267 /* Get the static part of C->EXPR's size. */
1268 gfc_get_array_constructor_element_size (&size, c->expr);
1269 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1271 /* Grow the array by TMP * TMP2 elements. */
1272 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1273 gfc_grow_array (pblock, desc, tmp);
1276 /* Generate the loop body. */
1277 exit_label = gfc_build_label_decl (NULL_TREE);
1278 gfc_start_block (&body);
1280 /* Generate the exit condition. Depending on the sign of
1281 the step variable we have to generate the correct
1283 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1284 build_int_cst (TREE_TYPE (step), 0));
1285 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1286 build2 (GT_EXPR, boolean_type_node,
1288 build2 (LT_EXPR, boolean_type_node,
1290 tmp = build1_v (GOTO_EXPR, exit_label);
1291 TREE_USED (exit_label) = 1;
1292 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1293 gfc_add_expr_to_block (&body, tmp);
1295 /* The main loop body. */
1296 gfc_add_expr_to_block (&body, loopbody);
1298 /* Increase loop variable by step. */
1299 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1300 gfc_add_modify_expr (&body, loopvar, tmp);
1302 /* Finish the loop. */
1303 tmp = gfc_finish_block (&body);
1304 tmp = build1_v (LOOP_EXPR, tmp);
1305 gfc_add_expr_to_block (pblock, tmp);
1307 /* Add the exit label. */
1308 tmp = build1_v (LABEL_EXPR, exit_label);
1309 gfc_add_expr_to_block (pblock, tmp);
1311 /* Restore the original value of the loop counter. */
1312 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1319 /* Figure out the string length of a variable reference expression.
1320 Used by get_array_ctor_strlen. */
1323 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1329 /* Don't bother if we already know the length is a constant. */
1330 if (*len && INTEGER_CST_P (*len))
1333 ts = &expr->symtree->n.sym->ts;
1334 for (ref = expr->ref; ref; ref = ref->next)
1339 /* Array references don't change the string length. */
1343 /* Use the length of the component. */
1344 ts = &ref->u.c.component->ts;
1348 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1349 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1351 mpz_init_set_ui (char_len, 1);
1352 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1353 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1354 *len = gfc_conv_mpz_to_tree (char_len,
1355 gfc_default_character_kind);
1356 *len = convert (gfc_charlen_type_node, *len);
1357 mpz_clear (char_len);
1361 /* TODO: Substrings are tricky because we can't evaluate the
1362 expression more than once. For now we just give up, and hope
1363 we can figure it out elsewhere. */
1368 *len = ts->cl->backend_decl;
1372 /* A catch-all to obtain the string length for anything that is not a
1373 constant, array or variable. */
1375 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1380 /* Don't bother if we already know the length is a constant. */
1381 if (*len && INTEGER_CST_P (*len))
1384 if (!e->ref && e->ts.cl->length
1385 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1388 gfc_conv_const_charlen (e->ts.cl);
1389 *len = e->ts.cl->backend_decl;
1393 /* Otherwise, be brutal even if inefficient. */
1394 ss = gfc_walk_expr (e);
1395 gfc_init_se (&se, NULL);
1397 /* No function call, in case of side effects. */
1398 se.no_function_call = 1;
1399 if (ss == gfc_ss_terminator)
1400 gfc_conv_expr (&se, e);
1402 gfc_conv_expr_descriptor (&se, e, ss);
1404 /* Fix the value. */
1405 *len = gfc_evaluate_now (se.string_length, &se.pre);
1407 gfc_add_block_to_block (block, &se.pre);
1408 gfc_add_block_to_block (block, &se.post);
1410 e->ts.cl->backend_decl = *len;
1415 /* Figure out the string length of a character array constructor.
1416 Returns TRUE if all elements are character constants. */
1419 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1427 *len = build_int_cstu (gfc_charlen_type_node, 0);
1431 for (; c; c = c->next)
1433 switch (c->expr->expr_type)
1436 if (!(*len && INTEGER_CST_P (*len)))
1437 *len = build_int_cstu (gfc_charlen_type_node,
1438 c->expr->value.character.length);
1442 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1448 get_array_ctor_var_strlen (c->expr, len);
1453 get_array_ctor_all_strlen (block, c->expr, len);
1461 /* Check whether the array constructor C consists entirely of constant
1462 elements, and if so returns the number of those elements, otherwise
1463 return zero. Note, an empty or NULL array constructor returns zero. */
1465 unsigned HOST_WIDE_INT
1466 gfc_constant_array_constructor_p (gfc_constructor * c)
1468 unsigned HOST_WIDE_INT nelem = 0;
1473 || c->expr->rank > 0
1474 || c->expr->expr_type != EXPR_CONSTANT)
1483 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1484 and the tree type of it's elements, TYPE, return a static constant
1485 variable that is compile-time initialized. */
1488 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1490 tree tmptype, list, init, tmp;
1491 HOST_WIDE_INT nelem;
1497 /* First traverse the constructor list, converting the constants
1498 to tree to build an initializer. */
1501 c = expr->value.constructor;
1504 gfc_init_se (&se, NULL);
1505 gfc_conv_constant (&se, c->expr);
1506 if (c->expr->ts.type == BT_CHARACTER
1507 && POINTER_TYPE_P (type))
1508 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1509 list = tree_cons (NULL_TREE, se.expr, list);
1514 /* Next determine the tree type for the array. We use the gfortran
1515 front-end's gfc_get_nodesc_array_type in order to create a suitable
1516 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1518 memset (&as, 0, sizeof (gfc_array_spec));
1520 as.rank = expr->rank;
1521 as.type = AS_EXPLICIT;
1524 as.lower[0] = gfc_int_expr (0);
1525 as.upper[0] = gfc_int_expr (nelem - 1);
1528 for (i = 0; i < expr->rank; i++)
1530 int tmp = (int) mpz_get_si (expr->shape[i]);
1531 as.lower[i] = gfc_int_expr (0);
1532 as.upper[i] = gfc_int_expr (tmp - 1);
1535 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1537 init = build_constructor_from_list (tmptype, nreverse (list));
1539 TREE_CONSTANT (init) = 1;
1540 TREE_INVARIANT (init) = 1;
1541 TREE_STATIC (init) = 1;
1543 tmp = gfc_create_var (tmptype, "A");
1544 TREE_STATIC (tmp) = 1;
1545 TREE_CONSTANT (tmp) = 1;
1546 TREE_INVARIANT (tmp) = 1;
1547 TREE_READONLY (tmp) = 1;
1548 DECL_INITIAL (tmp) = init;
1554 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1555 This mostly initializes the scalarizer state info structure with the
1556 appropriate values to directly use the array created by the function
1557 gfc_build_constant_array_constructor. */
1560 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1561 gfc_ss * ss, tree type)
1567 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1569 info = &ss->data.info;
1571 info->descriptor = tmp;
1572 info->data = build_fold_addr_expr (tmp);
1573 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1576 for (i = 0; i < info->dimen; i++)
1578 info->delta[i] = gfc_index_zero_node;
1579 info->start[i] = gfc_index_zero_node;
1580 info->end[i] = gfc_index_zero_node;
1581 info->stride[i] = gfc_index_one_node;
1585 if (info->dimen > loop->temp_dim)
1586 loop->temp_dim = info->dimen;
1589 /* Helper routine of gfc_trans_array_constructor to determine if the
1590 bounds of the loop specified by LOOP are constant and simple enough
1591 to use with gfc_trans_constant_array_constructor. Returns the
1592 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1595 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1597 tree size = gfc_index_one_node;
1601 for (i = 0; i < loop->dimen; i++)
1603 /* If the bounds aren't constant, return NULL_TREE. */
1604 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1606 if (!integer_zerop (loop->from[i]))
1608 /* Only allow nonzero "from" in one-dimensional arrays. */
1609 if (loop->dimen != 1)
1611 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1612 loop->to[i], loop->from[i]);
1616 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1617 tmp, gfc_index_one_node);
1618 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1625 /* Array constructors are handled by constructing a temporary, then using that
1626 within the scalarization loop. This is not optimal, but seems by far the
1630 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1639 ss->data.info.dimen = loop->dimen;
1641 c = ss->expr->value.constructor;
1642 if (ss->expr->ts.type == BT_CHARACTER)
1644 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1645 if (!ss->string_length)
1646 gfc_todo_error ("complex character array constructors");
1648 /* It is surprising but still possible to wind up with expressions that
1649 lack a character length.
1650 TODO Find the offending part of the front end and cure this properly.
1651 Concatenation involving arrays is the main culprit. */
1652 if (!ss->expr->ts.cl)
1654 ss->expr->ts.cl = gfc_get_charlen ();
1655 ss->expr->ts.cl->next = gfc_current_ns->cl_list;
1656 gfc_current_ns->cl_list = ss->expr->ts.cl->next;
1659 ss->expr->ts.cl->backend_decl = ss->string_length;
1661 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1663 type = build_pointer_type (type);
1666 type = gfc_typenode_for_spec (&ss->expr->ts);
1668 /* See if the constructor determines the loop bounds. */
1671 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1673 /* We have a multidimensional parameter. */
1675 for (n = 0; n < ss->expr->rank; n++)
1677 loop->from[n] = gfc_index_zero_node;
1678 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1679 gfc_index_integer_kind);
1680 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1681 loop->to[n], gfc_index_one_node);
1685 if (loop->to[0] == NULL_TREE)
1689 /* We should have a 1-dimensional, zero-based loop. */
1690 gcc_assert (loop->dimen == 1);
1691 gcc_assert (integer_zerop (loop->from[0]));
1693 /* Split the constructor size into a static part and a dynamic part.
1694 Allocate the static size up-front and record whether the dynamic
1695 size might be nonzero. */
1697 dynamic = gfc_get_array_constructor_size (&size, c);
1698 mpz_sub_ui (size, size, 1);
1699 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1703 /* Special case constant array constructors. */
1706 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1709 tree size = constant_array_constructor_loop_size (loop);
1710 if (size && compare_tree_int (size, nelem) == 0)
1712 gfc_trans_constant_array_constructor (loop, ss, type);
1718 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1719 type, dynamic, true, false);
1721 desc = ss->data.info.descriptor;
1722 offset = gfc_index_zero_node;
1723 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1724 TREE_NO_WARNING (offsetvar) = 1;
1725 TREE_USED (offsetvar) = 0;
1726 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1727 &offset, &offsetvar, dynamic);
1729 /* If the array grows dynamically, the upper bound of the loop variable
1730 is determined by the array's final upper bound. */
1732 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1734 if (TREE_USED (offsetvar))
1735 pushdecl (offsetvar);
1737 gcc_assert (INTEGER_CST_P (offset));
1739 /* Disable bound checking for now because it's probably broken. */
1740 if (flag_bounds_check)
1748 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1749 called after evaluating all of INFO's vector dimensions. Go through
1750 each such vector dimension and see if we can now fill in any missing
1754 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1763 for (n = 0; n < loop->dimen; n++)
1766 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1767 && loop->to[n] == NULL)
1769 /* Loop variable N indexes vector dimension DIM, and we don't
1770 yet know the upper bound of loop variable N. Set it to the
1771 difference between the vector's upper and lower bounds. */
1772 gcc_assert (loop->from[n] == gfc_index_zero_node);
1773 gcc_assert (info->subscript[dim]
1774 && info->subscript[dim]->type == GFC_SS_VECTOR);
1776 gfc_init_se (&se, NULL);
1777 desc = info->subscript[dim]->data.info.descriptor;
1778 zero = gfc_rank_cst[0];
1779 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1780 gfc_conv_descriptor_ubound (desc, zero),
1781 gfc_conv_descriptor_lbound (desc, zero));
1782 tmp = gfc_evaluate_now (tmp, &loop->pre);
1789 /* Add the pre and post chains for all the scalar expressions in a SS chain
1790 to loop. This is called after the loop parameters have been calculated,
1791 but before the actual scalarizing loops. */
1794 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1799 /* TODO: This can generate bad code if there are ordering dependencies.
1800 eg. a callee allocated function and an unknown size constructor. */
1801 gcc_assert (ss != NULL);
1803 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1810 /* Scalar expression. Evaluate this now. This includes elemental
1811 dimension indices, but not array section bounds. */
1812 gfc_init_se (&se, NULL);
1813 gfc_conv_expr (&se, ss->expr);
1814 gfc_add_block_to_block (&loop->pre, &se.pre);
1816 if (ss->expr->ts.type != BT_CHARACTER)
1818 /* Move the evaluation of scalar expressions outside the
1819 scalarization loop. */
1821 se.expr = convert(gfc_array_index_type, se.expr);
1822 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1823 gfc_add_block_to_block (&loop->pre, &se.post);
1826 gfc_add_block_to_block (&loop->post, &se.post);
1828 ss->data.scalar.expr = se.expr;
1829 ss->string_length = se.string_length;
1832 case GFC_SS_REFERENCE:
1833 /* Scalar reference. Evaluate this now. */
1834 gfc_init_se (&se, NULL);
1835 gfc_conv_expr_reference (&se, ss->expr);
1836 gfc_add_block_to_block (&loop->pre, &se.pre);
1837 gfc_add_block_to_block (&loop->post, &se.post);
1839 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1840 ss->string_length = se.string_length;
1843 case GFC_SS_SECTION:
1844 /* Add the expressions for scalar and vector subscripts. */
1845 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1846 if (ss->data.info.subscript[n])
1847 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1849 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1853 /* Get the vector's descriptor and store it in SS. */
1854 gfc_init_se (&se, NULL);
1855 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1856 gfc_add_block_to_block (&loop->pre, &se.pre);
1857 gfc_add_block_to_block (&loop->post, &se.post);
1858 ss->data.info.descriptor = se.expr;
1861 case GFC_SS_INTRINSIC:
1862 gfc_add_intrinsic_ss_code (loop, ss);
1865 case GFC_SS_FUNCTION:
1866 /* Array function return value. We call the function and save its
1867 result in a temporary for use inside the loop. */
1868 gfc_init_se (&se, NULL);
1871 gfc_conv_expr (&se, ss->expr);
1872 gfc_add_block_to_block (&loop->pre, &se.pre);
1873 gfc_add_block_to_block (&loop->post, &se.post);
1874 ss->string_length = se.string_length;
1877 case GFC_SS_CONSTRUCTOR:
1878 gfc_trans_array_constructor (loop, ss);
1882 case GFC_SS_COMPONENT:
1883 /* Do nothing. These are handled elsewhere. */
1893 /* Translate expressions for the descriptor and data pointer of a SS. */
1897 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1902 /* Get the descriptor for the array to be scalarized. */
1903 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1904 gfc_init_se (&se, NULL);
1905 se.descriptor_only = 1;
1906 gfc_conv_expr_lhs (&se, ss->expr);
1907 gfc_add_block_to_block (block, &se.pre);
1908 ss->data.info.descriptor = se.expr;
1909 ss->string_length = se.string_length;
1913 /* Also the data pointer. */
1914 tmp = gfc_conv_array_data (se.expr);
1915 /* If this is a variable or address of a variable we use it directly.
1916 Otherwise we must evaluate it now to avoid breaking dependency
1917 analysis by pulling the expressions for elemental array indices
1920 || (TREE_CODE (tmp) == ADDR_EXPR
1921 && DECL_P (TREE_OPERAND (tmp, 0)))))
1922 tmp = gfc_evaluate_now (tmp, block);
1923 ss->data.info.data = tmp;
1925 tmp = gfc_conv_array_offset (se.expr);
1926 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1931 /* Initialize a gfc_loopinfo structure. */
1934 gfc_init_loopinfo (gfc_loopinfo * loop)
1938 memset (loop, 0, sizeof (gfc_loopinfo));
1939 gfc_init_block (&loop->pre);
1940 gfc_init_block (&loop->post);
1942 /* Initially scalarize in order. */
1943 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1946 loop->ss = gfc_ss_terminator;
1950 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1954 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1960 /* Return an expression for the data pointer of an array. */
1963 gfc_conv_array_data (tree descriptor)
1967 type = TREE_TYPE (descriptor);
1968 if (GFC_ARRAY_TYPE_P (type))
1970 if (TREE_CODE (type) == POINTER_TYPE)
1974 /* Descriptorless arrays. */
1975 return build_fold_addr_expr (descriptor);
1979 return gfc_conv_descriptor_data_get (descriptor);
1983 /* Return an expression for the base offset of an array. */
1986 gfc_conv_array_offset (tree descriptor)
1990 type = TREE_TYPE (descriptor);
1991 if (GFC_ARRAY_TYPE_P (type))
1992 return GFC_TYPE_ARRAY_OFFSET (type);
1994 return gfc_conv_descriptor_offset (descriptor);
1998 /* Get an expression for the array stride. */
2001 gfc_conv_array_stride (tree descriptor, int dim)
2006 type = TREE_TYPE (descriptor);
2008 /* For descriptorless arrays use the array size. */
2009 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2010 if (tmp != NULL_TREE)
2013 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2018 /* Like gfc_conv_array_stride, but for the lower bound. */
2021 gfc_conv_array_lbound (tree descriptor, int dim)
2026 type = TREE_TYPE (descriptor);
2028 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2029 if (tmp != NULL_TREE)
2032 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2037 /* Like gfc_conv_array_stride, but for the upper bound. */
2040 gfc_conv_array_ubound (tree descriptor, int dim)
2045 type = TREE_TYPE (descriptor);
2047 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2048 if (tmp != NULL_TREE)
2051 /* This should only ever happen when passing an assumed shape array
2052 as an actual parameter. The value will never be used. */
2053 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2054 return gfc_index_zero_node;
2056 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2061 /* Generate code to perform an array index bound check. */
2064 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2065 locus * where, bool check_upper)
2070 const char * name = NULL;
2072 if (!flag_bounds_check)
2075 index = gfc_evaluate_now (index, &se->pre);
2077 /* We find a name for the error message. */
2079 name = se->ss->expr->symtree->name;
2081 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2082 && se->loop->ss->expr->symtree)
2083 name = se->loop->ss->expr->symtree->name;
2085 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2086 && se->loop->ss->loop_chain->expr
2087 && se->loop->ss->loop_chain->expr->symtree)
2088 name = se->loop->ss->loop_chain->expr->symtree->name;
2090 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2091 && se->loop->ss->loop_chain->expr->symtree)
2092 name = se->loop->ss->loop_chain->expr->symtree->name;
2094 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2096 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2097 && se->loop->ss->expr->value.function.name)
2098 name = se->loop->ss->expr->value.function.name;
2100 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2101 || se->loop->ss->type == GFC_SS_SCALAR)
2102 name = "unnamed constant";
2105 /* Check lower bound. */
2106 tmp = gfc_conv_array_lbound (descriptor, n);
2107 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2109 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2110 gfc_msg_fault, name, n+1);
2112 asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
2113 "smaller than %%ld", gfc_msg_fault, n+1);
2114 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2115 fold_convert (long_integer_type_node, index),
2116 fold_convert (long_integer_type_node, tmp));
2119 /* Check upper bound. */
2122 tmp = gfc_conv_array_ubound (descriptor, n);
2123 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2125 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2126 " exceeded", gfc_msg_fault, name, n+1);
2128 asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
2129 "larger than %%ld", gfc_msg_fault, n+1);
2130 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2131 fold_convert (long_integer_type_node, index),
2132 fold_convert (long_integer_type_node, tmp));
2140 /* Return the offset for an index. Performs bound checking for elemental
2141 dimensions. Single element references are processed separately. */
2144 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2145 gfc_array_ref * ar, tree stride)
2151 /* Get the index into the array for this dimension. */
2154 gcc_assert (ar->type != AR_ELEMENT);
2155 switch (ar->dimen_type[dim])
2158 gcc_assert (i == -1);
2159 /* Elemental dimension. */
2160 gcc_assert (info->subscript[dim]
2161 && info->subscript[dim]->type == GFC_SS_SCALAR);
2162 /* We've already translated this value outside the loop. */
2163 index = info->subscript[dim]->data.scalar.expr;
2165 index = gfc_trans_array_bound_check (se, info->descriptor,
2166 index, dim, &ar->where,
2167 (ar->as->type != AS_ASSUMED_SIZE
2168 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2172 gcc_assert (info && se->loop);
2173 gcc_assert (info->subscript[dim]
2174 && info->subscript[dim]->type == GFC_SS_VECTOR);
2175 desc = info->subscript[dim]->data.info.descriptor;
2177 /* Get a zero-based index into the vector. */
2178 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2179 se->loop->loopvar[i], se->loop->from[i]);
2181 /* Multiply the index by the stride. */
2182 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2183 index, gfc_conv_array_stride (desc, 0));
2185 /* Read the vector to get an index into info->descriptor. */
2186 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2187 index = gfc_build_array_ref (data, index);
2188 index = gfc_evaluate_now (index, &se->pre);
2190 /* Do any bounds checking on the final info->descriptor index. */
2191 index = gfc_trans_array_bound_check (se, info->descriptor,
2192 index, dim, &ar->where,
2193 (ar->as->type != AS_ASSUMED_SIZE
2194 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2198 /* Scalarized dimension. */
2199 gcc_assert (info && se->loop);
2201 /* Multiply the loop variable by the stride and delta. */
2202 index = se->loop->loopvar[i];
2203 if (!integer_onep (info->stride[i]))
2204 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2206 if (!integer_zerop (info->delta[i]))
2207 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2217 /* Temporary array or derived type component. */
2218 gcc_assert (se->loop);
2219 index = se->loop->loopvar[se->loop->order[i]];
2220 if (!integer_zerop (info->delta[i]))
2221 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2222 index, info->delta[i]);
2225 /* Multiply by the stride. */
2226 if (!integer_onep (stride))
2227 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2233 /* Build a scalarized reference to an array. */
2236 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2243 info = &se->ss->data.info;
2245 n = se->loop->order[0];
2249 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2251 /* Add the offset for this dimension to the stored offset for all other
2253 if (!integer_zerop (info->offset))
2254 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2256 tmp = build_fold_indirect_ref (info->data);
2257 se->expr = gfc_build_array_ref (tmp, index);
2261 /* Translate access of temporary array. */
2264 gfc_conv_tmp_array_ref (gfc_se * se)
2266 se->string_length = se->ss->string_length;
2267 gfc_conv_scalarized_array_ref (se, NULL);
2271 /* Build an array reference. se->expr already holds the array descriptor.
2272 This should be either a variable, indirect variable reference or component
2273 reference. For arrays which do not have a descriptor, se->expr will be
2275 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2278 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2287 /* Handle scalarized references separately. */
2288 if (ar->type != AR_ELEMENT)
2290 gfc_conv_scalarized_array_ref (se, ar);
2291 gfc_advance_se_ss_chain (se);
2295 index = gfc_index_zero_node;
2297 /* Calculate the offsets from all the dimensions. */
2298 for (n = 0; n < ar->dimen; n++)
2300 /* Calculate the index for this dimension. */
2301 gfc_init_se (&indexse, se);
2302 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2303 gfc_add_block_to_block (&se->pre, &indexse.pre);
2305 if (flag_bounds_check)
2307 /* Check array bounds. */
2311 /* Evaluate the indexse.expr only once. */
2312 indexse.expr = save_expr (indexse.expr);
2315 tmp = gfc_conv_array_lbound (se->expr, n);
2316 cond = fold_build2 (LT_EXPR, boolean_type_node,
2318 asprintf (&msg, "%s for array '%s', "
2319 "lower bound of dimension %d exceeded, %%ld is smaller "
2320 "than %%ld", gfc_msg_fault, sym->name, n+1);
2321 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2322 fold_convert (long_integer_type_node,
2324 fold_convert (long_integer_type_node, tmp));
2327 /* Upper bound, but not for the last dimension of assumed-size
2329 if (n < ar->dimen - 1
2330 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2332 tmp = gfc_conv_array_ubound (se->expr, n);
2333 cond = fold_build2 (GT_EXPR, boolean_type_node,
2335 asprintf (&msg, "%s for array '%s', "
2336 "upper bound of dimension %d exceeded, %%ld is "
2337 "greater than %%ld", gfc_msg_fault, sym->name, n+1);
2338 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2339 fold_convert (long_integer_type_node,
2341 fold_convert (long_integer_type_node, tmp));
2346 /* Multiply the index by the stride. */
2347 stride = gfc_conv_array_stride (se->expr, n);
2348 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2351 /* And add it to the total. */
2352 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2355 tmp = gfc_conv_array_offset (se->expr);
2356 if (!integer_zerop (tmp))
2357 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2359 /* Access the calculated element. */
2360 tmp = gfc_conv_array_data (se->expr);
2361 tmp = build_fold_indirect_ref (tmp);
2362 se->expr = gfc_build_array_ref (tmp, index);
2366 /* Generate the code to be executed immediately before entering a
2367 scalarization loop. */
2370 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2371 stmtblock_t * pblock)
2380 /* This code will be executed before entering the scalarization loop
2381 for this dimension. */
2382 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2384 if ((ss->useflags & flag) == 0)
2387 if (ss->type != GFC_SS_SECTION
2388 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2389 && ss->type != GFC_SS_COMPONENT)
2392 info = &ss->data.info;
2394 if (dim >= info->dimen)
2397 if (dim == info->dimen - 1)
2399 /* For the outermost loop calculate the offset due to any
2400 elemental dimensions. It will have been initialized with the
2401 base offset of the array. */
2404 for (i = 0; i < info->ref->u.ar.dimen; i++)
2406 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2409 gfc_init_se (&se, NULL);
2411 se.expr = info->descriptor;
2412 stride = gfc_conv_array_stride (info->descriptor, i);
2413 index = gfc_conv_array_index_offset (&se, info, i, -1,
2416 gfc_add_block_to_block (pblock, &se.pre);
2418 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2419 info->offset, index);
2420 info->offset = gfc_evaluate_now (info->offset, pblock);
2424 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2427 stride = gfc_conv_array_stride (info->descriptor, 0);
2429 /* Calculate the stride of the innermost loop. Hopefully this will
2430 allow the backend optimizers to do their stuff more effectively.
2432 info->stride0 = gfc_evaluate_now (stride, pblock);
2436 /* Add the offset for the previous loop dimension. */
2441 ar = &info->ref->u.ar;
2442 i = loop->order[dim + 1];
2450 gfc_init_se (&se, NULL);
2452 se.expr = info->descriptor;
2453 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2454 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2456 gfc_add_block_to_block (pblock, &se.pre);
2457 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2458 info->offset, index);
2459 info->offset = gfc_evaluate_now (info->offset, pblock);
2462 /* Remember this offset for the second loop. */
2463 if (dim == loop->temp_dim - 1)
2464 info->saved_offset = info->offset;
2469 /* Start a scalarized expression. Creates a scope and declares loop
2473 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2479 gcc_assert (!loop->array_parameter);
2481 for (dim = loop->dimen - 1; dim >= 0; dim--)
2483 n = loop->order[dim];
2485 gfc_start_block (&loop->code[n]);
2487 /* Create the loop variable. */
2488 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2490 if (dim < loop->temp_dim)
2494 /* Calculate values that will be constant within this loop. */
2495 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2497 gfc_start_block (pbody);
2501 /* Generates the actual loop code for a scalarization loop. */
2504 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2505 stmtblock_t * pbody)
2513 loopbody = gfc_finish_block (pbody);
2515 /* Initialize the loopvar. */
2516 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2518 exit_label = gfc_build_label_decl (NULL_TREE);
2520 /* Generate the loop body. */
2521 gfc_init_block (&block);
2523 /* The exit condition. */
2524 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2525 tmp = build1_v (GOTO_EXPR, exit_label);
2526 TREE_USED (exit_label) = 1;
2527 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2528 gfc_add_expr_to_block (&block, tmp);
2530 /* The main body. */
2531 gfc_add_expr_to_block (&block, loopbody);
2533 /* Increment the loopvar. */
2534 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2535 loop->loopvar[n], gfc_index_one_node);
2536 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2538 /* Build the loop. */
2539 tmp = gfc_finish_block (&block);
2540 tmp = build1_v (LOOP_EXPR, tmp);
2541 gfc_add_expr_to_block (&loop->code[n], tmp);
2543 /* Add the exit label. */
2544 tmp = build1_v (LABEL_EXPR, exit_label);
2545 gfc_add_expr_to_block (&loop->code[n], tmp);
2549 /* Finishes and generates the loops for a scalarized expression. */
2552 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2557 stmtblock_t *pblock;
2561 /* Generate the loops. */
2562 for (dim = 0; dim < loop->dimen; dim++)
2564 n = loop->order[dim];
2565 gfc_trans_scalarized_loop_end (loop, n, pblock);
2566 loop->loopvar[n] = NULL_TREE;
2567 pblock = &loop->code[n];
2570 tmp = gfc_finish_block (pblock);
2571 gfc_add_expr_to_block (&loop->pre, tmp);
2573 /* Clear all the used flags. */
2574 for (ss = loop->ss; ss; ss = ss->loop_chain)
2579 /* Finish the main body of a scalarized expression, and start the secondary
2583 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2587 stmtblock_t *pblock;
2591 /* We finish as many loops as are used by the temporary. */
2592 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2594 n = loop->order[dim];
2595 gfc_trans_scalarized_loop_end (loop, n, pblock);
2596 loop->loopvar[n] = NULL_TREE;
2597 pblock = &loop->code[n];
2600 /* We don't want to finish the outermost loop entirely. */
2601 n = loop->order[loop->temp_dim - 1];
2602 gfc_trans_scalarized_loop_end (loop, n, pblock);
2604 /* Restore the initial offsets. */
2605 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2607 if ((ss->useflags & 2) == 0)
2610 if (ss->type != GFC_SS_SECTION
2611 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2612 && ss->type != GFC_SS_COMPONENT)
2615 ss->data.info.offset = ss->data.info.saved_offset;
2618 /* Restart all the inner loops we just finished. */
2619 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2621 n = loop->order[dim];
2623 gfc_start_block (&loop->code[n]);
2625 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2627 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2630 /* Start a block for the secondary copying code. */
2631 gfc_start_block (body);
2635 /* Calculate the upper bound of an array section. */
2638 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2647 gcc_assert (ss->type == GFC_SS_SECTION);
2649 info = &ss->data.info;
2652 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2653 /* We'll calculate the upper bound once we have access to the
2654 vector's descriptor. */
2657 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2658 desc = info->descriptor;
2659 end = info->ref->u.ar.end[dim];
2663 /* The upper bound was specified. */
2664 gfc_init_se (&se, NULL);
2665 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2666 gfc_add_block_to_block (pblock, &se.pre);
2671 /* No upper bound was specified, so use the bound of the array. */
2672 bound = gfc_conv_array_ubound (desc, dim);
2679 /* Calculate the lower bound of an array section. */
2682 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2692 gcc_assert (ss->type == GFC_SS_SECTION);
2694 info = &ss->data.info;
2697 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2699 /* We use a zero-based index to access the vector. */
2700 info->start[n] = gfc_index_zero_node;
2701 info->end[n] = gfc_index_zero_node;
2702 info->stride[n] = gfc_index_one_node;
2706 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2707 desc = info->descriptor;
2708 start = info->ref->u.ar.start[dim];
2709 end = info->ref->u.ar.end[dim];
2710 stride = info->ref->u.ar.stride[dim];
2712 /* Calculate the start of the range. For vector subscripts this will
2713 be the range of the vector. */
2716 /* Specified section start. */
2717 gfc_init_se (&se, NULL);
2718 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2719 gfc_add_block_to_block (&loop->pre, &se.pre);
2720 info->start[n] = se.expr;
2724 /* No lower bound specified so use the bound of the array. */
2725 info->start[n] = gfc_conv_array_lbound (desc, dim);
2727 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2729 /* Similarly calculate the end. Although this is not used in the
2730 scalarizer, it is needed when checking bounds and where the end
2731 is an expression with side-effects. */
2734 /* Specified section start. */
2735 gfc_init_se (&se, NULL);
2736 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2737 gfc_add_block_to_block (&loop->pre, &se.pre);
2738 info->end[n] = se.expr;
2742 /* No upper bound specified so use the bound of the array. */
2743 info->end[n] = gfc_conv_array_ubound (desc, dim);
2745 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2747 /* Calculate the stride. */
2749 info->stride[n] = gfc_index_one_node;
2752 gfc_init_se (&se, NULL);
2753 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2754 gfc_add_block_to_block (&loop->pre, &se.pre);
2755 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2760 /* Calculates the range start and stride for a SS chain. Also gets the
2761 descriptor and data pointer. The range of vector subscripts is the size
2762 of the vector. Array bounds are also checked. */
2765 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2773 /* Determine the rank of the loop. */
2775 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2779 case GFC_SS_SECTION:
2780 case GFC_SS_CONSTRUCTOR:
2781 case GFC_SS_FUNCTION:
2782 case GFC_SS_COMPONENT:
2783 loop->dimen = ss->data.info.dimen;
2786 /* As usual, lbound and ubound are exceptions!. */
2787 case GFC_SS_INTRINSIC:
2788 switch (ss->expr->value.function.isym->id)
2790 case GFC_ISYM_LBOUND:
2791 case GFC_ISYM_UBOUND:
2792 loop->dimen = ss->data.info.dimen;
2803 if (loop->dimen == 0)
2804 gfc_todo_error ("Unable to determine rank of expression");
2807 /* Loop over all the SS in the chain. */
2808 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2810 if (ss->expr && ss->expr->shape && !ss->shape)
2811 ss->shape = ss->expr->shape;
2815 case GFC_SS_SECTION:
2816 /* Get the descriptor for the array. */
2817 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2819 for (n = 0; n < ss->data.info.dimen; n++)
2820 gfc_conv_section_startstride (loop, ss, n);
2823 case GFC_SS_INTRINSIC:
2824 switch (ss->expr->value.function.isym->id)
2826 /* Fall through to supply start and stride. */
2827 case GFC_ISYM_LBOUND:
2828 case GFC_ISYM_UBOUND:
2834 case GFC_SS_CONSTRUCTOR:
2835 case GFC_SS_FUNCTION:
2836 for (n = 0; n < ss->data.info.dimen; n++)
2838 ss->data.info.start[n] = gfc_index_zero_node;
2839 ss->data.info.end[n] = gfc_index_zero_node;
2840 ss->data.info.stride[n] = gfc_index_one_node;
2849 /* The rest is just runtime bound checking. */
2850 if (flag_bounds_check)
2853 tree lbound, ubound;
2855 tree size[GFC_MAX_DIMENSIONS];
2856 tree stride_pos, stride_neg, non_zerosized, tmp2;
2861 gfc_start_block (&block);
2863 for (n = 0; n < loop->dimen; n++)
2864 size[n] = NULL_TREE;
2866 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2868 if (ss->type != GFC_SS_SECTION)
2871 /* TODO: range checking for mapped dimensions. */
2872 info = &ss->data.info;
2874 /* This code only checks ranges. Elemental and vector
2875 dimensions are checked later. */
2876 for (n = 0; n < loop->dimen; n++)
2881 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2884 if (n == info->ref->u.ar.dimen - 1
2885 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2886 || info->ref->u.ar.as->cp_was_assumed))
2887 check_upper = false;
2891 /* Zero stride is not allowed. */
2892 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2893 gfc_index_zero_node);
2894 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2895 "of array '%s'", info->dim[n]+1,
2896 ss->expr->symtree->name);
2897 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg);
2900 desc = ss->data.info.descriptor;
2902 /* This is the run-time equivalent of resolve.c's
2903 check_dimension(). The logical is more readable there
2904 than it is here, with all the trees. */
2905 lbound = gfc_conv_array_lbound (desc, dim);
2908 ubound = gfc_conv_array_ubound (desc, dim);
2912 /* non_zerosized is true when the selected range is not
2914 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2915 info->stride[n], gfc_index_zero_node);
2916 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2918 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2921 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2922 info->stride[n], gfc_index_zero_node);
2923 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2925 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2927 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2928 stride_pos, stride_neg);
2930 /* Check the start of the range against the lower and upper
2931 bounds of the array, if the range is not empty. */
2932 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2934 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2935 non_zerosized, tmp);
2936 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2937 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
2938 info->dim[n]+1, ss->expr->symtree->name);
2939 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2940 fold_convert (long_integer_type_node,
2942 fold_convert (long_integer_type_node,
2948 tmp = fold_build2 (GT_EXPR, boolean_type_node,
2949 info->start[n], ubound);
2950 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2951 non_zerosized, tmp);
2952 asprintf (&msg, "%s, upper bound of dimension %d of array "
2953 "'%s' exceeded, %%ld is greater than %%ld",
2954 gfc_msg_fault, info->dim[n]+1,
2955 ss->expr->symtree->name);
2956 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2957 fold_convert (long_integer_type_node, info->start[n]),
2958 fold_convert (long_integer_type_node, ubound));
2962 /* Compute the last element of the range, which is not
2963 necessarily "end" (think 0:5:3, which doesn't contain 5)
2964 and check it against both lower and upper bounds. */
2965 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2967 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2969 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2972 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2973 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2974 non_zerosized, tmp);
2975 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2976 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
2977 info->dim[n]+1, ss->expr->symtree->name);
2978 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2979 fold_convert (long_integer_type_node,
2981 fold_convert (long_integer_type_node,
2987 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2988 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2989 non_zerosized, tmp);
2990 asprintf (&msg, "%s, upper bound of dimension %d of array "
2991 "'%s' exceeded, %%ld is greater than %%ld",
2992 gfc_msg_fault, info->dim[n]+1,
2993 ss->expr->symtree->name);
2994 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2995 fold_convert (long_integer_type_node, tmp2),
2996 fold_convert (long_integer_type_node, ubound));
3000 /* Check the section sizes match. */
3001 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3003 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3005 /* We remember the size of the first section, and check all the
3006 others against this. */
3010 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3011 asprintf (&msg, "%s, size mismatch for dimension %d "
3012 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3013 info->dim[n]+1, ss->expr->symtree->name);
3014 gfc_trans_runtime_check (tmp3, &block, &ss->expr->where, msg,
3015 fold_convert (long_integer_type_node, tmp),
3016 fold_convert (long_integer_type_node, size[n]));
3020 size[n] = gfc_evaluate_now (tmp, &block);
3024 tmp = gfc_finish_block (&block);
3025 gfc_add_expr_to_block (&loop->pre, tmp);
3030 /* Return true if the two SS could be aliased, i.e. both point to the same data
3032 /* TODO: resolve aliases based on frontend expressions. */
3035 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3042 lsym = lss->expr->symtree->n.sym;
3043 rsym = rss->expr->symtree->n.sym;
3044 if (gfc_symbols_could_alias (lsym, rsym))
3047 if (rsym->ts.type != BT_DERIVED
3048 && lsym->ts.type != BT_DERIVED)
3051 /* For derived types we must check all the component types. We can ignore
3052 array references as these will have the same base type as the previous
3054 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3056 if (lref->type != REF_COMPONENT)
3059 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3062 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3065 if (rref->type != REF_COMPONENT)
3068 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3073 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3075 if (rref->type != REF_COMPONENT)
3078 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3086 /* Resolve array data dependencies. Creates a temporary if required. */
3087 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3091 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3101 loop->temp_ss = NULL;
3102 aref = dest->data.info.ref;
3105 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3107 if (ss->type != GFC_SS_SECTION)
3110 if (gfc_could_be_alias (dest, ss)
3111 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3117 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3119 lref = dest->expr->ref;
3120 rref = ss->expr->ref;
3122 nDepend = gfc_dep_resolver (lref, rref);
3126 /* TODO : loop shifting. */
3129 /* Mark the dimensions for LOOP SHIFTING */
3130 for (n = 0; n < loop->dimen; n++)
3132 int dim = dest->data.info.dim[n];
3134 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3136 else if (! gfc_is_same_range (&lref->u.ar,
3137 &rref->u.ar, dim, 0))
3141 /* Put all the dimensions with dependencies in the
3144 for (n = 0; n < loop->dimen; n++)
3146 gcc_assert (loop->order[n] == n);
3148 loop->order[dim++] = n;
3151 for (n = 0; n < loop->dimen; n++)
3154 loop->order[dim++] = n;
3157 gcc_assert (dim == loop->dimen);
3166 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3167 if (GFC_ARRAY_TYPE_P (base_type)
3168 || GFC_DESCRIPTOR_TYPE_P (base_type))
3169 base_type = gfc_get_element_type (base_type);
3170 loop->temp_ss = gfc_get_ss ();
3171 loop->temp_ss->type = GFC_SS_TEMP;
3172 loop->temp_ss->data.temp.type = base_type;
3173 loop->temp_ss->string_length = dest->string_length;
3174 loop->temp_ss->data.temp.dimen = loop->dimen;
3175 loop->temp_ss->next = gfc_ss_terminator;
3176 gfc_add_ss_to_loop (loop, loop->temp_ss);
3179 loop->temp_ss = NULL;
3183 /* Initialize the scalarization loop. Creates the loop variables. Determines
3184 the range of the loop variables. Creates a temporary if required.
3185 Calculates how to transform from loop variables to array indices for each
3186 expression. Also generates code for scalar expressions which have been
3187 moved outside the loop. */
3190 gfc_conv_loop_setup (gfc_loopinfo * loop)
3195 gfc_ss_info *specinfo;
3199 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3200 bool dynamic[GFC_MAX_DIMENSIONS];
3206 for (n = 0; n < loop->dimen; n++)
3210 /* We use one SS term, and use that to determine the bounds of the
3211 loop for this dimension. We try to pick the simplest term. */
3212 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3216 /* The frontend has worked out the size for us. */
3221 if (ss->type == GFC_SS_CONSTRUCTOR)
3223 /* An unknown size constructor will always be rank one.
3224 Higher rank constructors will either have known shape,
3225 or still be wrapped in a call to reshape. */
3226 gcc_assert (loop->dimen == 1);
3228 /* Always prefer to use the constructor bounds if the size
3229 can be determined at compile time. Prefer not to otherwise,
3230 since the general case involves realloc, and it's better to
3231 avoid that overhead if possible. */
3232 c = ss->expr->value.constructor;
3233 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3234 if (!dynamic[n] || !loopspec[n])
3239 /* TODO: Pick the best bound if we have a choice between a
3240 function and something else. */
3241 if (ss->type == GFC_SS_FUNCTION)
3247 if (ss->type != GFC_SS_SECTION)
3251 specinfo = &loopspec[n]->data.info;
3254 info = &ss->data.info;
3258 /* Criteria for choosing a loop specifier (most important first):
3259 doesn't need realloc
3265 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3267 else if (integer_onep (info->stride[n])
3268 && !integer_onep (specinfo->stride[n]))
3270 else if (INTEGER_CST_P (info->stride[n])
3271 && !INTEGER_CST_P (specinfo->stride[n]))
3273 else if (INTEGER_CST_P (info->start[n])
3274 && !INTEGER_CST_P (specinfo->start[n]))
3276 /* We don't work out the upper bound.
3277 else if (INTEGER_CST_P (info->finish[n])
3278 && ! INTEGER_CST_P (specinfo->finish[n]))
3279 loopspec[n] = ss; */
3283 gfc_todo_error ("Unable to find scalarization loop specifier");
3285 info = &loopspec[n]->data.info;
3287 /* Set the extents of this range. */
3288 cshape = loopspec[n]->shape;
3289 if (cshape && INTEGER_CST_P (info->start[n])
3290 && INTEGER_CST_P (info->stride[n]))
3292 loop->from[n] = info->start[n];
3293 mpz_set (i, cshape[n]);
3294 mpz_sub_ui (i, i, 1);
3295 /* To = from + (size - 1) * stride. */
3296 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3297 if (!integer_onep (info->stride[n]))
3298 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3299 tmp, info->stride[n]);
3300 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3301 loop->from[n], tmp);
3305 loop->from[n] = info->start[n];
3306 switch (loopspec[n]->type)
3308 case GFC_SS_CONSTRUCTOR:
3309 /* The upper bound is calculated when we expand the
3311 gcc_assert (loop->to[n] == NULL_TREE);
3314 case GFC_SS_SECTION:
3315 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3319 case GFC_SS_FUNCTION:
3320 /* The loop bound will be set when we generate the call. */
3321 gcc_assert (loop->to[n] == NULL_TREE);
3329 /* Transform everything so we have a simple incrementing variable. */
3330 if (integer_onep (info->stride[n]))
3331 info->delta[n] = gfc_index_zero_node;
3334 /* Set the delta for this section. */
3335 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3336 /* Number of iterations is (end - start + step) / step.
3337 with start = 0, this simplifies to
3339 for (i = 0; i<=last; i++){...}; */
3340 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3341 loop->to[n], loop->from[n]);
3342 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3343 tmp, info->stride[n]);
3344 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3345 /* Make the loop variable start at 0. */
3346 loop->from[n] = gfc_index_zero_node;
3350 /* Add all the scalar code that can be taken out of the loops.
3351 This may include calculating the loop bounds, so do it before
3352 allocating the temporary. */
3353 gfc_add_loop_ss_code (loop, loop->ss, false);
3355 /* If we want a temporary then create it. */
3356 if (loop->temp_ss != NULL)
3358 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3359 tmp = loop->temp_ss->data.temp.type;
3360 len = loop->temp_ss->string_length;
3361 n = loop->temp_ss->data.temp.dimen;
3362 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3363 loop->temp_ss->type = GFC_SS_SECTION;
3364 loop->temp_ss->data.info.dimen = n;
3365 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3366 &loop->temp_ss->data.info, tmp, false, true,
3370 for (n = 0; n < loop->temp_dim; n++)
3371 loopspec[loop->order[n]] = NULL;
3375 /* For array parameters we don't have loop variables, so don't calculate the
3377 if (loop->array_parameter)
3380 /* Calculate the translation from loop variables to array indices. */
3381 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3383 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3386 info = &ss->data.info;
3388 for (n = 0; n < info->dimen; n++)
3392 /* If we are specifying the range the delta is already set. */
3393 if (loopspec[n] != ss)
3395 /* Calculate the offset relative to the loop variable.
3396 First multiply by the stride. */
3397 tmp = loop->from[n];
3398 if (!integer_onep (info->stride[n]))
3399 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3400 tmp, info->stride[n]);
3402 /* Then subtract this from our starting value. */
3403 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3404 info->start[n], tmp);
3406 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3413 /* Fills in an array descriptor, and returns the size of the array. The size
3414 will be a simple_val, ie a variable or a constant. Also calculates the
3415 offset of the base. Returns the size of the array.
3419 for (n = 0; n < rank; n++)
3421 a.lbound[n] = specified_lower_bound;
3422 offset = offset + a.lbond[n] * stride;
3424 a.ubound[n] = specified_upper_bound;
3425 a.stride[n] = stride;
3426 size = ubound + size; //size = ubound + 1 - lbound
3427 stride = stride * size;
3434 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3435 gfc_expr ** lower, gfc_expr ** upper,
3436 stmtblock_t * pblock)
3448 stmtblock_t thenblock;
3449 stmtblock_t elseblock;
3454 type = TREE_TYPE (descriptor);
3456 stride = gfc_index_one_node;
3457 offset = gfc_index_zero_node;
3459 /* Set the dtype. */
3460 tmp = gfc_conv_descriptor_dtype (descriptor);
3461 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3463 or_expr = NULL_TREE;
3465 for (n = 0; n < rank; n++)
3467 /* We have 3 possibilities for determining the size of the array:
3468 lower == NULL => lbound = 1, ubound = upper[n]
3469 upper[n] = NULL => lbound = 1, ubound = lower[n]
3470 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3473 /* Set lower bound. */
3474 gfc_init_se (&se, NULL);
3476 se.expr = gfc_index_one_node;
3479 gcc_assert (lower[n]);
3482 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3483 gfc_add_block_to_block (pblock, &se.pre);
3487 se.expr = gfc_index_one_node;
3491 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3492 gfc_add_modify_expr (pblock, tmp, se.expr);
3494 /* Work out the offset for this component. */
3495 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3496 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3498 /* Start the calculation for the size of this dimension. */
3499 size = build2 (MINUS_EXPR, gfc_array_index_type,
3500 gfc_index_one_node, se.expr);
3502 /* Set upper bound. */
3503 gfc_init_se (&se, NULL);
3504 gcc_assert (ubound);
3505 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3506 gfc_add_block_to_block (pblock, &se.pre);
3508 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3509 gfc_add_modify_expr (pblock, tmp, se.expr);
3511 /* Store the stride. */
3512 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3513 gfc_add_modify_expr (pblock, tmp, stride);
3515 /* Calculate the size of this dimension. */
3516 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3518 /* Check whether the size for this dimension is negative. */
3519 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3520 gfc_index_zero_node);
3524 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3526 /* Multiply the stride by the number of elements in this dimension. */
3527 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3528 stride = gfc_evaluate_now (stride, pblock);
3531 /* The stride is the number of elements in the array, so multiply by the
3532 size of an element to get the total size. */
3533 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3534 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3535 fold_convert (gfc_array_index_type, tmp));
3537 if (poffset != NULL)
3539 offset = gfc_evaluate_now (offset, pblock);
3543 if (integer_zerop (or_expr))
3545 if (integer_onep (or_expr))
3546 return gfc_index_zero_node;
3548 var = gfc_create_var (TREE_TYPE (size), "size");
3549 gfc_start_block (&thenblock);
3550 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3551 thencase = gfc_finish_block (&thenblock);
3553 gfc_start_block (&elseblock);
3554 gfc_add_modify_expr (&elseblock, var, size);
3555 elsecase = gfc_finish_block (&elseblock);
3557 tmp = gfc_evaluate_now (or_expr, pblock);
3558 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3559 gfc_add_expr_to_block (pblock, tmp);
3565 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3566 the work for an ALLOCATE statement. */
3570 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3579 gfc_ref *ref, *prev_ref = NULL;
3580 bool allocatable_array;
3584 /* Find the last reference in the chain. */
3585 while (ref && ref->next != NULL)
3587 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3592 if (ref == NULL || ref->type != REF_ARRAY)
3596 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3598 allocatable_array = prev_ref->u.c.component->allocatable;
3600 /* Figure out the size of the array. */
3601 switch (ref->u.ar.type)
3605 upper = ref->u.ar.start;
3609 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3611 lower = ref->u.ar.as->lower;
3612 upper = ref->u.ar.as->upper;
3616 lower = ref->u.ar.start;
3617 upper = ref->u.ar.end;
3625 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3626 lower, upper, &se->pre);
3628 /* Allocate memory to store the data. */
3629 pointer = gfc_conv_descriptor_data_get (se->expr);
3630 STRIP_NOPS (pointer);
3632 if (TYPE_PRECISION (gfc_array_index_type) == 32 ||
3633 TYPE_PRECISION (gfc_array_index_type) == 64)
3635 if (allocatable_array)
3636 allocate = gfor_fndecl_allocate_array;
3638 allocate = gfor_fndecl_allocate;
3643 /* The allocate_array variants take the old pointer as first argument. */
3644 if (allocatable_array)
3645 tmp = build_call_expr (allocate, 3, pointer, size, pstat);
3647 tmp = build_call_expr (allocate, 2, size, pstat);
3648 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3649 gfc_add_expr_to_block (&se->pre, tmp);
3651 tmp = gfc_conv_descriptor_offset (se->expr);
3652 gfc_add_modify_expr (&se->pre, tmp, offset);
3654 if (expr->ts.type == BT_DERIVED
3655 && expr->ts.derived->attr.alloc_comp)
3657 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3658 ref->u.ar.as->rank);
3659 gfc_add_expr_to_block (&se->pre, tmp);
3666 /* Deallocate an array variable. Also used when an allocated variable goes
3671 gfc_array_deallocate (tree descriptor, tree pstat)
3677 gfc_start_block (&block);
3678 /* Get a pointer to the data. */
3679 var = gfc_conv_descriptor_data_get (descriptor);
3682 /* Parameter is the address of the data component. */
3683 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
3684 gfc_add_expr_to_block (&block, tmp);
3686 /* Zero the data pointer. */
3687 tmp = build2 (MODIFY_EXPR, void_type_node,
3688 var, build_int_cst (TREE_TYPE (var), 0));
3689 gfc_add_expr_to_block (&block, tmp);
3691 return gfc_finish_block (&block);
3695 /* Create an array constructor from an initialization expression.
3696 We assume the frontend already did any expansions and conversions. */
3699 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3706 unsigned HOST_WIDE_INT lo;
3708 VEC(constructor_elt,gc) *v = NULL;
3710 switch (expr->expr_type)
3713 case EXPR_STRUCTURE:
3714 /* A single scalar or derived type value. Create an array with all
3715 elements equal to that value. */
3716 gfc_init_se (&se, NULL);
3718 if (expr->expr_type == EXPR_CONSTANT)
3719 gfc_conv_constant (&se, expr);
3721 gfc_conv_structure (&se, expr, 1);
3723 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3724 gcc_assert (tmp && INTEGER_CST_P (tmp));
3725 hi = TREE_INT_CST_HIGH (tmp);
3726 lo = TREE_INT_CST_LOW (tmp);
3730 /* This will probably eat buckets of memory for large arrays. */
3731 while (hi != 0 || lo != 0)
3733 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3741 /* Create a vector of all the elements. */
3742 for (c = expr->value.constructor; c; c = c->next)
3746 /* Problems occur when we get something like
3747 integer :: a(lots) = (/(i, i=1,lots)/) */
3748 /* TODO: Unexpanded array initializers. */
3750 ("Possible frontend bug: array constructor not expanded");
3752 if (mpz_cmp_si (c->n.offset, 0) != 0)
3753 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3757 if (mpz_cmp_si (c->repeat, 0) != 0)
3761 mpz_set (maxval, c->repeat);
3762 mpz_add (maxval, c->n.offset, maxval);
3763 mpz_sub_ui (maxval, maxval, 1);
3764 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3765 if (mpz_cmp_si (c->n.offset, 0) != 0)
3767 mpz_add_ui (maxval, c->n.offset, 1);
3768 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3771 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3773 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3779 gfc_init_se (&se, NULL);
3780 switch (c->expr->expr_type)
3783 gfc_conv_constant (&se, c->expr);
3784 if (range == NULL_TREE)
3785 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3788 if (index != NULL_TREE)
3789 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3790 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3794 case EXPR_STRUCTURE:
3795 gfc_conv_structure (&se, c->expr, 1);
3796 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3806 return gfc_build_null_descriptor (type);
3812 /* Create a constructor from the list of elements. */
3813 tmp = build_constructor (type, v);
3814 TREE_CONSTANT (tmp) = 1;
3815 TREE_INVARIANT (tmp) = 1;
3820 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3821 returns the size (in elements) of the array. */
3824 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3825 stmtblock_t * pblock)
3840 size = gfc_index_one_node;
3841 offset = gfc_index_zero_node;
3842 for (dim = 0; dim < as->rank; dim++)
3844 /* Evaluate non-constant array bound expressions. */
3845 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3846 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3848 gfc_init_se (&se, NULL);
3849 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3850 gfc_add_block_to_block (pblock, &se.pre);
3851 gfc_add_modify_expr (pblock, lbound, se.expr);
3853 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3854 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3856 gfc_init_se (&se, NULL);
3857 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3858 gfc_add_block_to_block (pblock, &se.pre);
3859 gfc_add_modify_expr (pblock, ubound, se.expr);
3861 /* The offset of this dimension. offset = offset - lbound * stride. */
3862 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3863 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3865 /* The size of this dimension, and the stride of the next. */
3866 if (dim + 1 < as->rank)
3867 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3869 stride = GFC_TYPE_ARRAY_SIZE (type);
3871 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3873 /* Calculate stride = size * (ubound + 1 - lbound). */
3874 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3875 gfc_index_one_node, lbound);
3876 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3877 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3879 gfc_add_modify_expr (pblock, stride, tmp);
3881 stride = gfc_evaluate_now (tmp, pblock);
3883 /* Make sure that negative size arrays are translated
3884 to being zero size. */
3885 tmp = build2 (GE_EXPR, boolean_type_node,
3886 stride, gfc_index_zero_node);
3887 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3888 stride, gfc_index_zero_node);
3889 gfc_add_modify_expr (pblock, stride, tmp);
3895 gfc_trans_vla_type_sizes (sym, pblock);
3902 /* Generate code to initialize/allocate an array variable. */
3905 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3914 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3916 /* Do nothing for USEd variables. */
3917 if (sym->attr.use_assoc)
3920 type = TREE_TYPE (decl);
3921 gcc_assert (GFC_ARRAY_TYPE_P (type));
3922 onstack = TREE_CODE (type) != POINTER_TYPE;
3924 gfc_start_block (&block);
3926 /* Evaluate character string length. */
3927 if (sym->ts.type == BT_CHARACTER
3928 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3930 gfc_trans_init_string_length (sym->ts.cl, &block);
3932 gfc_trans_vla_type_sizes (sym, &block);
3934 /* Emit a DECL_EXPR for this variable, which will cause the
3935 gimplifier to allocate storage, and all that good stuff. */
3936 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3937 gfc_add_expr_to_block (&block, tmp);
3942 gfc_add_expr_to_block (&block, fnbody);
3943 return gfc_finish_block (&block);
3946 type = TREE_TYPE (type);
3948 gcc_assert (!sym->attr.use_assoc);
3949 gcc_assert (!TREE_STATIC (decl));
3950 gcc_assert (!sym->module);
3952 if (sym->ts.type == BT_CHARACTER
3953 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3954 gfc_trans_init_string_length (sym->ts.cl, &block);
3956 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3958 /* Don't actually allocate space for Cray Pointees. */
3959 if (sym->attr.cray_pointee)
3961 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3962 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3963 gfc_add_expr_to_block (&block, fnbody);
3964 return gfc_finish_block (&block);
3967 /* The size is the number of elements in the array, so multiply by the
3968 size of an element to get the total size. */
3969 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3970 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
3971 fold_convert (gfc_array_index_type, tmp));
3973 /* Allocate memory to hold the data. */
3974 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3975 gfc_add_modify_expr (&block, decl, tmp);
3977 /* Set offset of the array. */
3978 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3979 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3982 /* Automatic arrays should not have initializers. */
3983 gcc_assert (!sym->value);
3985 gfc_add_expr_to_block (&block, fnbody);
3987 /* Free the temporary. */
3988 tmp = gfc_call_free (convert (pvoid_type_node, decl));
3989 gfc_add_expr_to_block (&block, tmp);
3991 return gfc_finish_block (&block);
3995 /* Generate entry and exit code for g77 calling convention arrays. */
3998 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4008 gfc_get_backend_locus (&loc);
4009 gfc_set_backend_locus (&sym->declared_at);
4011 /* Descriptor type. */
4012 parm = sym->backend_decl;
4013 type = TREE_TYPE (parm);
4014 gcc_assert (GFC_ARRAY_TYPE_P (type));
4016 gfc_start_block (&block);
4018 if (sym->ts.type == BT_CHARACTER
4019 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4020 gfc_trans_init_string_length (sym->ts.cl, &block);
4022 /* Evaluate the bounds of the array. */
4023 gfc_trans_array_bounds (type, sym, &offset, &block);
4025 /* Set the offset. */
4026 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4027 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4029 /* Set the pointer itself if we aren't using the parameter directly. */
4030 if (TREE_CODE (parm) != PARM_DECL)
4032 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4033 gfc_add_modify_expr (&block, parm, tmp);
4035 stmt = gfc_finish_block (&block);
4037 gfc_set_backend_locus (&loc);
4039 gfc_start_block (&block);
4041 /* Add the initialization code to the start of the function. */
4043 if (sym->attr.optional || sym->attr.not_always_present)
4045 tmp = gfc_conv_expr_present (sym);
4046 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4049 gfc_add_expr_to_block (&block, stmt);
4050 gfc_add_expr_to_block (&block, body);
4052 return gfc_finish_block (&block);
4056 /* Modify the descriptor of an array parameter so that it has the
4057 correct lower bound. Also move the upper bound accordingly.
4058 If the array is not packed, it will be copied into a temporary.
4059 For each dimension we set the new lower and upper bounds. Then we copy the
4060 stride and calculate the offset for this dimension. We also work out
4061 what the stride of a packed array would be, and see it the two match.
4062 If the array need repacking, we set the stride to the values we just
4063 calculated, recalculate the offset and copy the array data.
4064 Code is also added to copy the data back at the end of the function.
4068 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4075 stmtblock_t cleanup;
4083 tree stride, stride2;
4093 /* Do nothing for pointer and allocatable arrays. */
4094 if (sym->attr.pointer || sym->attr.allocatable)
4097 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4098 return gfc_trans_g77_array (sym, body);
4100 gfc_get_backend_locus (&loc);
4101 gfc_set_backend_locus (&sym->declared_at);
4103 /* Descriptor type. */
4104 type = TREE_TYPE (tmpdesc);
4105 gcc_assert (GFC_ARRAY_TYPE_P (type));
4106 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4107 dumdesc = build_fold_indirect_ref (dumdesc);
4108 gfc_start_block (&block);
4110 if (sym->ts.type == BT_CHARACTER
4111 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4112 gfc_trans_init_string_length (sym->ts.cl, &block);
4114 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4116 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4117 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4119 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4121 /* For non-constant shape arrays we only check if the first dimension
4122 is contiguous. Repacking higher dimensions wouldn't gain us
4123 anything as we still don't know the array stride. */
4124 partial = gfc_create_var (boolean_type_node, "partial");
4125 TREE_USED (partial) = 1;
4126 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4127 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4128 gfc_add_modify_expr (&block, partial, tmp);
4132 partial = NULL_TREE;
4135 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4136 here, however I think it does the right thing. */
4139 /* Set the first stride. */
4140 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4141 stride = gfc_evaluate_now (stride, &block);
4143 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4144 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4145 gfc_index_one_node, stride);
4146 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4147 gfc_add_modify_expr (&block, stride, tmp);
4149 /* Allow the user to disable array repacking. */
4150 stmt_unpacked = NULL_TREE;
4154 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4155 /* A library call to repack the array if necessary. */
4156 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4157 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4159 stride = gfc_index_one_node;
4162 /* This is for the case where the array data is used directly without
4163 calling the repack function. */
4164 if (no_repack || partial != NULL_TREE)
4165 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4167 stmt_packed = NULL_TREE;
4169 /* Assign the data pointer. */
4170 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4172 /* Don't repack unknown shape arrays when the first stride is 1. */
4173 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4174 stmt_packed, stmt_unpacked);
4177 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4178 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4180 offset = gfc_index_zero_node;
4181 size = gfc_index_one_node;
4183 /* Evaluate the bounds of the array. */
4184 for (n = 0; n < sym->as->rank; n++)
4186 if (checkparm || !sym->as->upper[n])
4188 /* Get the bounds of the actual parameter. */
4189 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4190 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4194 dubound = NULL_TREE;
4195 dlbound = NULL_TREE;
4198 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4199 if (!INTEGER_CST_P (lbound))
4201 gfc_init_se (&se, NULL);
4202 gfc_conv_expr_type (&se, sym->as->lower[n],
4203 gfc_array_index_type);
4204 gfc_add_block_to_block (&block, &se.pre);
4205 gfc_add_modify_expr (&block, lbound, se.expr);
4208 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4209 /* Set the desired upper bound. */
4210 if (sym->as->upper[n])
4212 /* We know what we want the upper bound to be. */
4213 if (!INTEGER_CST_P (ubound))
4215 gfc_init_se (&se, NULL);
4216 gfc_conv_expr_type (&se, sym->as->upper[n],
4217 gfc_array_index_type);
4218 gfc_add_block_to_block (&block, &se.pre);
4219 gfc_add_modify_expr (&block, ubound, se.expr);
4222 /* Check the sizes match. */
4225 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4228 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4230 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4232 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4233 asprintf (&msg, "%s for dimension %d of array '%s'",
4234 gfc_msg_bounds, n+1, sym->name);
4235 gfc_trans_runtime_check (tmp, &block, &loc, msg);
4241 /* For assumed shape arrays move the upper bound by the same amount
4242 as the lower bound. */
4243 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4244 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4245 gfc_add_modify_expr (&block, ubound, tmp);
4247 /* The offset of this dimension. offset = offset - lbound * stride. */
4248 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4249 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4251 /* The size of this dimension, and the stride of the next. */
4252 if (n + 1 < sym->as->rank)
4254 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4256 if (no_repack || partial != NULL_TREE)
4259 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4262 /* Figure out the stride if not a known constant. */
4263 if (!INTEGER_CST_P (stride))
4266 stmt_packed = NULL_TREE;
4269 /* Calculate stride = size * (ubound + 1 - lbound). */
4270 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4271 gfc_index_one_node, lbound);
4272 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4274 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4279 /* Assign the stride. */
4280 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4281 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4282 stmt_unpacked, stmt_packed);
4284 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4285 gfc_add_modify_expr (&block, stride, tmp);
4290 stride = GFC_TYPE_ARRAY_SIZE (type);
4292 if (stride && !INTEGER_CST_P (stride))
4294 /* Calculate size = stride * (ubound + 1 - lbound). */
4295 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4296 gfc_index_one_node, lbound);
4297 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4299 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4300 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4301 gfc_add_modify_expr (&block, stride, tmp);
4306 /* Set the offset. */
4307 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4308 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4310 gfc_trans_vla_type_sizes (sym, &block);
4312 stmt = gfc_finish_block (&block);
4314 gfc_start_block (&block);
4316 /* Only do the entry/initialization code if the arg is present. */
4317 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4318 optional_arg = (sym->attr.optional
4319 || (sym->ns->proc_name->attr.entry_master
4320 && sym->attr.dummy));
4323 tmp = gfc_conv_expr_present (sym);
4324 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4326 gfc_add_expr_to_block (&block, stmt);
4328 /* Add the main function body. */
4329 gfc_add_expr_to_block (&block, body);
4334 gfc_start_block (&cleanup);
4336 if (sym->attr.intent != INTENT_IN)
4338 /* Copy the data back. */
4339 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4340 gfc_add_expr_to_block (&cleanup, tmp);
4343 /* Free the temporary. */
4344 tmp = gfc_call_free (tmpdesc);
4345 gfc_add_expr_to_block (&cleanup, tmp);
4347 stmt = gfc_finish_block (&cleanup);
4349 /* Only do the cleanup if the array was repacked. */
4350 tmp = build_fold_indirect_ref (dumdesc);
4351 tmp = gfc_conv_descriptor_data_get (tmp);
4352 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4353 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4357 tmp = gfc_conv_expr_present (sym);
4358 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4360 gfc_add_expr_to_block (&block, stmt);
4362 /* We don't need to free any memory allocated by internal_pack as it will
4363 be freed at the end of the function by pop_context. */
4364 return gfc_finish_block (&block);
4368 /* Convert an array for passing as an actual argument. Expressions and
4369 vector subscripts are evaluated and stored in a temporary, which is then
4370 passed. For whole arrays the descriptor is passed. For array sections
4371 a modified copy of the descriptor is passed, but using the original data.
4373 This function is also used for array pointer assignments, and there
4376 - se->want_pointer && !se->direct_byref
4377 EXPR is an actual argument. On exit, se->expr contains a
4378 pointer to the array descriptor.
4380 - !se->want_pointer && !se->direct_byref
4381 EXPR is an actual argument to an intrinsic function or the
4382 left-hand side of a pointer assignment. On exit, se->expr
4383 contains the descriptor for EXPR.
4385 - !se->want_pointer && se->direct_byref
4386 EXPR is the right-hand side of a pointer assignment and
4387 se->expr is the descriptor for the previously-evaluated
4388 left-hand side. The function creates an assignment from
4389 EXPR to se->expr. */
4392 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4406 gcc_assert (ss != gfc_ss_terminator);
4408 /* Special case things we know we can pass easily. */
4409 switch (expr->expr_type)
4412 /* If we have a linear array section, we can pass it directly.
4413 Otherwise we need to copy it into a temporary. */
4415 /* Find the SS for the array section. */
4417 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4418 secss = secss->next;
4420 gcc_assert (secss != gfc_ss_terminator);
4421 info = &secss->data.info;
4423 /* Get the descriptor for the array. */
4424 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4425 desc = info->descriptor;
4427 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4430 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4432 /* Create a new descriptor if the array doesn't have one. */
4435 else if (info->ref->u.ar.type == AR_FULL)
4437 else if (se->direct_byref)
4440 full = gfc_full_array_ref_p (info->ref);
4444 if (se->direct_byref)
4446 /* Copy the descriptor for pointer assignments. */
4447 gfc_add_modify_expr (&se->pre, se->expr, desc);
4449 else if (se->want_pointer)
4451 /* We pass full arrays directly. This means that pointers and
4452 allocatable arrays should also work. */
4453 se->expr = build_fold_addr_expr (desc);
4460 if (expr->ts.type == BT_CHARACTER)
4461 se->string_length = gfc_get_expr_charlen (expr);
4468 /* A transformational function return value will be a temporary
4469 array descriptor. We still need to go through the scalarizer
4470 to create the descriptor. Elemental functions ar handled as
4471 arbitrary expressions, i.e. copy to a temporary. */
4473 /* Look for the SS for this function. */
4474 while (secss != gfc_ss_terminator
4475 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4476 secss = secss->next;
4478 if (se->direct_byref)
4480 gcc_assert (secss != gfc_ss_terminator);
4482 /* For pointer assignments pass the descriptor directly. */
4484 se->expr = build_fold_addr_expr (se->expr);
4485 gfc_conv_expr (se, expr);
4489 if (secss == gfc_ss_terminator)
4491 /* Elemental function. */
4497 /* Transformational function. */
4498 info = &secss->data.info;
4504 /* Constant array constructors don't need a temporary. */
4505 if (ss->type == GFC_SS_CONSTRUCTOR
4506 && expr->ts.type != BT_CHARACTER
4507 && gfc_constant_array_constructor_p (expr->value.constructor))
4510 info = &ss->data.info;
4522 /* Something complicated. Copy it into a temporary. */
4530 gfc_init_loopinfo (&loop);
4532 /* Associate the SS with the loop. */
4533 gfc_add_ss_to_loop (&loop, ss);
4535 /* Tell the scalarizer not to bother creating loop variables, etc. */
4537 loop.array_parameter = 1;
4539 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4540 gcc_assert (!se->direct_byref);
4542 /* Setup the scalarizing loops and bounds. */
4543 gfc_conv_ss_startstride (&loop);
4547 /* Tell the scalarizer to make a temporary. */
4548 loop.temp_ss = gfc_get_ss ();
4549 loop.temp_ss->type = GFC_SS_TEMP;
4550 loop.temp_ss->next = gfc_ss_terminator;
4551 if (expr->ts.type == BT_CHARACTER)
4553 if (expr->ts.cl == NULL)
4555 /* This had better be a substring reference! */
4556 gfc_ref *char_ref = expr->ref;
4557 for (; char_ref; char_ref = char_ref->next)
4558 if (char_ref->type == REF_SUBSTRING)
4561 expr->ts.cl = gfc_get_charlen ();
4562 expr->ts.cl->next = char_ref->u.ss.length->next;
4563 char_ref->u.ss.length->next = expr->ts.cl;
4565 mpz_init_set_ui (char_len, 1);
4566 mpz_add (char_len, char_len,
4567 char_ref->u.ss.end->value.integer);
4568 mpz_sub (char_len, char_len,
4569 char_ref->u.ss.start->value.integer);
4570 expr->ts.cl->backend_decl
4571 = gfc_conv_mpz_to_tree (char_len,
4572 gfc_default_character_kind);
4573 /* Cast is necessary for *-charlen refs. */
4574 expr->ts.cl->backend_decl
4575 = convert (gfc_charlen_type_node,
4576 expr->ts.cl->backend_decl);
4577 mpz_clear (char_len);
4580 gcc_assert (char_ref != NULL);
4581 loop.temp_ss->data.temp.type
4582 = gfc_typenode_for_spec (&expr->ts);
4583 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4585 else if (expr->ts.cl->length
4586 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4588 gfc_conv_const_charlen (expr->ts.cl);
4589 loop.temp_ss->data.temp.type
4590 = gfc_typenode_for_spec (&expr->ts);
4591 loop.temp_ss->string_length
4592 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4596 loop.temp_ss->data.temp.type
4597 = gfc_typenode_for_spec (&expr->ts);
4598 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4600 se->string_length = loop.temp_ss->string_length;
4604 loop.temp_ss->data.temp.type
4605 = gfc_typenode_for_spec (&expr->ts);
4606 loop.temp_ss->string_length = NULL;
4608 loop.temp_ss->data.temp.dimen = loop.dimen;
4609 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4612 gfc_conv_loop_setup (&loop);
4616 /* Copy into a temporary and pass that. We don't need to copy the data
4617 back because expressions and vector subscripts must be INTENT_IN. */
4618 /* TODO: Optimize passing function return values. */
4622 /* Start the copying loops. */
4623 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4624 gfc_mark_ss_chain_used (ss, 1);
4625 gfc_start_scalarized_body (&loop, &block);
4627 /* Copy each data element. */
4628 gfc_init_se (&lse, NULL);
4629 gfc_copy_loopinfo_to_se (&lse, &loop);
4630 gfc_init_se (&rse, NULL);
4631 gfc_copy_loopinfo_to_se (&rse, &loop);
4633 lse.ss = loop.temp_ss;
4636 gfc_conv_scalarized_array_ref (&lse, NULL);
4637 if (expr->ts.type == BT_CHARACTER)
4639 gfc_conv_expr (&rse, expr);
4640 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4641 rse.expr = build_fold_indirect_ref (rse.expr);
4644 gfc_conv_expr_val (&rse, expr);
4646 gfc_add_block_to_block (&block, &rse.pre);
4647 gfc_add_block_to_block (&block, &lse.pre);
4649 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4651 /* Finish the copying loops. */
4652 gfc_trans_scalarizing_loops (&loop, &block);
4654 desc = loop.temp_ss->data.info.descriptor;
4656 gcc_assert (is_gimple_lvalue (desc));
4658 else if (expr->expr_type == EXPR_FUNCTION)
4660 desc = info->descriptor;
4661 se->string_length = ss->string_length;
4665 /* We pass sections without copying to a temporary. Make a new
4666 descriptor and point it at the section we want. The loop variable
4667 limits will be the limits of the section.
4668 A function may decide to repack the array to speed up access, but
4669 we're not bothered about that here. */
4678 /* Set the string_length for a character array. */
4679 if (expr->ts.type == BT_CHARACTER)
4680 se->string_length = gfc_get_expr_charlen (expr);
4682 desc = info->descriptor;
4683 gcc_assert (secss && secss != gfc_ss_terminator);
4684 if (se->direct_byref)
4686 /* For pointer assignments we fill in the destination. */
4688 parmtype = TREE_TYPE (parm);
4692 /* Otherwise make a new one. */
4693 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4694 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4695 loop.from, loop.to, 0);
4696 parm = gfc_create_var (parmtype, "parm");
4699 offset = gfc_index_zero_node;
4702 /* The following can be somewhat confusing. We have two
4703 descriptors, a new one and the original array.
4704 {parm, parmtype, dim} refer to the new one.
4705 {desc, type, n, secss, loop} refer to the original, which maybe
4706 a descriptorless array.
4707 The bounds of the scalarization are the bounds of the section.
4708 We don't have to worry about numeric overflows when calculating
4709 the offsets because all elements are within the array data. */
4711 /* Set the dtype. */
4712 tmp = gfc_conv_descriptor_dtype (parm);
4713 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4715 /* Set offset for assignments to pointer only to zero if it is not
4717 if (se->direct_byref
4718 && info->ref && info->ref->u.ar.type != AR_FULL)
4719 base = gfc_index_zero_node;
4720 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4721 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4725 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4726 for (n = 0; n < ndim; n++)
4728 stride = gfc_conv_array_stride (desc, n);
4730 /* Work out the offset. */
4732 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4734 gcc_assert (info->subscript[n]
4735 && info->subscript[n]->type == GFC_SS_SCALAR);
4736 start = info->subscript[n]->data.scalar.expr;
4740 /* Check we haven't somehow got out of sync. */
4741 gcc_assert (info->dim[dim] == n);
4743 /* Evaluate and remember the start of the section. */
4744 start = info->start[dim];
4745 stride = gfc_evaluate_now (stride, &loop.pre);
4748 tmp = gfc_conv_array_lbound (desc, n);
4749 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4751 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4752 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4755 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4757 /* For elemental dimensions, we only need the offset. */
4761 /* Vector subscripts need copying and are handled elsewhere. */
4763 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4765 /* Set the new lower bound. */
4766 from = loop.from[dim];
4769 /* If we have an array section or are assigning make sure that
4770 the lower bound is 1. References to the full
4771 array should otherwise keep the original bounds. */
4773 || info->ref->u.ar.type != AR_FULL)
4774 && !integer_onep (from))
4776 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4777 gfc_index_one_node, from);
4778 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4779 from = gfc_index_one_node;
4781 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4782 gfc_add_modify_expr (&loop.pre, tmp, from);
4784 /* Set the new upper bound. */
4785 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4786 gfc_add_modify_expr (&loop.pre, tmp, to);
4788 /* Multiply the stride by the section stride to get the
4790 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4791 stride, info->stride[dim]);
4793 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
4795 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4798 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4800 tmp = gfc_conv_array_lbound (desc, n);
4801 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4802 tmp, loop.from[dim]);
4803 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
4804 tmp, gfc_conv_array_stride (desc, n));
4805 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
4809 /* Store the new stride. */
4810 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4811 gfc_add_modify_expr (&loop.pre, tmp, stride);
4816 if (se->data_not_needed)
4817 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4820 /* Point the data pointer at the first element in the section. */
4821 tmp = gfc_conv_array_data (desc);
4822 tmp = build_fold_indirect_ref (tmp);
4823 tmp = gfc_build_array_ref (tmp, offset);
4824 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4825 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4828 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4829 && !se->data_not_needed)
4831 /* Set the offset. */
4832 tmp = gfc_conv_descriptor_offset (parm);
4833 gfc_add_modify_expr (&loop.pre, tmp, base);
4837 /* Only the callee knows what the correct offset it, so just set
4839 tmp = gfc_conv_descriptor_offset (parm);
4840 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4845 if (!se->direct_byref)
4847 /* Get a pointer to the new descriptor. */
4848 if (se->want_pointer)
4849 se->expr = build_fold_addr_expr (desc);
4854 gfc_add_block_to_block (&se->pre, &loop.pre);
4855 gfc_add_block_to_block (&se->post, &loop.post);
4857 /* Cleanup the scalarizer. */
4858 gfc_cleanup_loop (&loop);
4862 /* Convert an array for passing as an actual parameter. */
4863 /* TODO: Optimize passing g77 arrays. */
4866 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4870 tree tmp = NULL_TREE;
4872 tree parent = DECL_CONTEXT (current_function_decl);
4873 bool full_array_var, this_array_result;
4877 full_array_var = (expr->expr_type == EXPR_VARIABLE
4878 && expr->ref->u.ar.type == AR_FULL);
4879 sym = full_array_var ? expr->symtree->n.sym : NULL;
4881 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
4883 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
4884 expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
4885 se->string_length = expr->ts.cl->backend_decl;
4888 /* Is this the result of the enclosing procedure? */
4889 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4890 if (this_array_result
4891 && (sym->backend_decl != current_function_decl)
4892 && (sym->backend_decl != parent))
4893 this_array_result = false;
4895 /* Passing address of the array if it is not pointer or assumed-shape. */
4896 if (full_array_var && g77 && !this_array_result)
4898 tmp = gfc_get_symbol_decl (sym);
4900 if (sym->ts.type == BT_CHARACTER)
4901 se->string_length = sym->ts.cl->backend_decl;
4902 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4903 && !sym->attr.allocatable)
4905 /* Some variables are declared directly, others are declared as
4906 pointers and allocated on the heap. */
4907 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4910 se->expr = build_fold_addr_expr (tmp);
4913 if (sym->attr.allocatable)
4915 if (sym->attr.dummy)
4917 gfc_conv_expr_descriptor (se, expr, ss);
4918 se->expr = gfc_conv_array_data (se->expr);
4921 se->expr = gfc_conv_array_data (tmp);
4926 if (this_array_result)
4928 /* Result of the enclosing function. */
4929 gfc_conv_expr_descriptor (se, expr, ss);
4930 se->expr = build_fold_addr_expr (se->expr);
4932 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
4933 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4934 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
4940 /* Every other type of array. */
4941 se->want_pointer = 1;
4942 gfc_conv_expr_descriptor (se, expr, ss);
4946 /* Deallocate the allocatable components of structures that are
4948 if (expr->ts.type == BT_DERIVED
4949 && expr->ts.derived->attr.alloc_comp
4950 && expr->expr_type != EXPR_VARIABLE)
4952 tmp = build_fold_indirect_ref (se->expr);
4953 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4954 gfc_add_expr_to_block (&se->post, tmp);
4960 /* Repack the array. */
4961 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
4962 ptr = gfc_evaluate_now (ptr, &se->pre);
4965 gfc_start_block (&block);
4967 /* Copy the data back. */
4968 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
4969 gfc_add_expr_to_block (&block, tmp);
4971 /* Free the temporary. */
4972 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
4973 gfc_add_expr_to_block (&block, tmp);
4975 stmt = gfc_finish_block (&block);
4977 gfc_init_block (&block);
4978 /* Only if it was repacked. This code needs to be executed before the
4979 loop cleanup code. */
4980 tmp = build_fold_indirect_ref (desc);
4981 tmp = gfc_conv_array_data (tmp);
4982 tmp = build2 (NE_EXPR, boolean_type_node,
4983 fold_convert (TREE_TYPE (tmp), ptr), tmp);
4984 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4986 gfc_add_expr_to_block (&block, tmp);
4987 gfc_add_block_to_block (&block, &se->post);
4989 gfc_init_block (&se->post);
4990 gfc_add_block_to_block (&se->post, &block);
4995 /* Generate code to deallocate an array, if it is allocated. */
4998 gfc_trans_dealloc_allocated (tree descriptor)
5005 gfc_start_block (&block);
5007 var = gfc_conv_descriptor_data_get (descriptor);
5009 tmp = gfc_create_var (gfc_array_index_type, NULL);
5010 ptr = build_fold_addr_expr (tmp);
5012 /* Call array_deallocate with an int* present in the second argument.
5013 Although it is ignored here, it's presence ensures that arrays that
5014 are already deallocated are ignored. */
5015 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
5016 gfc_add_expr_to_block (&block, tmp);
5018 /* Zero the data pointer. */
5019 tmp = build2 (MODIFY_EXPR, void_type_node,
5020 var, build_int_cst (TREE_TYPE (var), 0));
5021 gfc_add_expr_to_block (&block, tmp);
5023 return gfc_finish_block (&block);
5027 /* This helper function calculates the size in words of a full array. */
5030 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5035 idx = gfc_rank_cst[rank - 1];
5036 nelems = gfc_conv_descriptor_ubound (decl, idx);
5037 tmp = gfc_conv_descriptor_lbound (decl, idx);
5038 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5039 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
5040 tmp, gfc_index_one_node);
5041 tmp = gfc_evaluate_now (tmp, block);
5043 nelems = gfc_conv_descriptor_stride (decl, idx);
5044 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5045 return gfc_evaluate_now (tmp, block);
5049 /* Allocate dest to the same size as src, and copy src -> dest. */
5052 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5061 /* If the source is null, set the destination to null. */
5062 gfc_init_block (&block);
5063 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5064 null_data = gfc_finish_block (&block);
5066 gfc_init_block (&block);
5068 nelems = get_full_array_size (&block, src, rank);
5069 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5070 fold_convert (gfc_array_index_type,
5071 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5073 /* Allocate memory to the destination. */
5074 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5076 gfc_conv_descriptor_data_set (&block, dest, tmp);
5078 /* We know the temporary and the value will be the same length,
5079 so can use memcpy. */
5080 tmp = built_in_decls[BUILT_IN_MEMCPY];
5081 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5082 gfc_conv_descriptor_data_get (src), size);
5083 gfc_add_expr_to_block (&block, tmp);
5084 tmp = gfc_finish_block (&block);
5086 /* Null the destination if the source is null; otherwise do
5087 the allocate and copy. */
5088 null_cond = gfc_conv_descriptor_data_get (src);
5089 null_cond = convert (pvoid_type_node, null_cond);
5090 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5092 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5096 /* Recursively traverse an object of derived type, generating code to
5097 deallocate, nullify or copy allocatable components. This is the work horse
5098 function for the functions named in this enum. */
5100 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5103 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5104 tree dest, int rank, int purpose)
5108 stmtblock_t fnblock;
5109 stmtblock_t loopbody;
5119 tree null_cond = NULL_TREE;
5121 gfc_init_block (&fnblock);
5123 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5124 decl = build_fold_indirect_ref (decl);
5126 /* If this an array of derived types with allocatable components
5127 build a loop and recursively call this function. */
5128 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5129 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5131 tmp = gfc_conv_array_data (decl);
5132 var = build_fold_indirect_ref (tmp);
5134 /* Get the number of elements - 1 and set the counter. */
5135 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5137 /* Use the descriptor for an allocatable array. Since this
5138 is a full array reference, we only need the descriptor
5139 information from dimension = rank. */
5140 tmp = get_full_array_size (&fnblock, decl, rank);
5141 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
5142 tmp, gfc_index_one_node);
5144 null_cond = gfc_conv_descriptor_data_get (decl);
5145 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5146 build_int_cst (TREE_TYPE (null_cond), 0));
5150 /* Otherwise use the TYPE_DOMAIN information. */
5151 tmp = array_type_nelts (TREE_TYPE (decl));
5152 tmp = fold_convert (gfc_array_index_type, tmp);
5155 /* Remember that this is, in fact, the no. of elements - 1. */
5156 nelems = gfc_evaluate_now (tmp, &fnblock);
5157 index = gfc_create_var (gfc_array_index_type, "S");
5159 /* Build the body of the loop. */
5160 gfc_init_block (&loopbody);
5162 vref = gfc_build_array_ref (var, index);
5164 if (purpose == COPY_ALLOC_COMP)
5166 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5167 gfc_add_expr_to_block (&fnblock, tmp);
5169 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5170 dref = gfc_build_array_ref (tmp, index);
5171 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5174 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5176 gfc_add_expr_to_block (&loopbody, tmp);
5178 /* Build the loop and return. */
5179 gfc_init_loopinfo (&loop);
5181 loop.from[0] = gfc_index_zero_node;
5182 loop.loopvar[0] = index;
5183 loop.to[0] = nelems;
5184 gfc_trans_scalarizing_loops (&loop, &loopbody);
5185 gfc_add_block_to_block (&fnblock, &loop.pre);
5187 tmp = gfc_finish_block (&fnblock);
5188 if (null_cond != NULL_TREE)
5189 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5194 /* Otherwise, act on the components or recursively call self to
5195 act on a chain of components. */
5196 for (c = der_type->components; c; c = c->next)
5198 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5199 && c->ts.derived->attr.alloc_comp;
5200 cdecl = c->backend_decl;
5201 ctype = TREE_TYPE (cdecl);
5205 case DEALLOCATE_ALLOC_COMP:
5206 /* Do not deallocate the components of ultimate pointer
5208 if (cmp_has_alloc_comps && !c->pointer)
5210 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5211 rank = c->as ? c->as->rank : 0;
5212 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5214 gfc_add_expr_to_block (&fnblock, tmp);
5219 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5220 tmp = gfc_trans_dealloc_allocated (comp);
5221 gfc_add_expr_to_block (&fnblock, tmp);
5225 case NULLIFY_ALLOC_COMP:
5228 else if (c->allocatable)
5230 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5231 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5233 else if (cmp_has_alloc_comps)
5235 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5236 rank = c->as ? c->as->rank : 0;
5237 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5239 gfc_add_expr_to_block (&fnblock, tmp);
5243 case COPY_ALLOC_COMP:
5247 /* We need source and destination components. */
5248 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5249 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5250 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5252 if (c->allocatable && !cmp_has_alloc_comps)
5254 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5255 gfc_add_expr_to_block (&fnblock, tmp);
5258 if (cmp_has_alloc_comps)
5260 rank = c->as ? c->as->rank : 0;
5261 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5262 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5263 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5265 gfc_add_expr_to_block (&fnblock, tmp);
5275 return gfc_finish_block (&fnblock);
5278 /* Recursively traverse an object of derived type, generating code to
5279 nullify allocatable components. */
5282 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5284 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5285 NULLIFY_ALLOC_COMP);
5289 /* Recursively traverse an object of derived type, generating code to
5290 deallocate allocatable components. */
5293 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5295 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5296 DEALLOCATE_ALLOC_COMP);
5300 /* Recursively traverse an object of derived type, generating code to
5301 copy its allocatable components. */
5304 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5306 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5310 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5311 Do likewise, recursively if necessary, with the allocatable components of
5315 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5320 stmtblock_t fnblock;
5323 bool sym_has_alloc_comp;
5325 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5326 && sym->ts.derived->attr.alloc_comp;
5328 /* Make sure the frontend gets these right. */
5329 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5330 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5331 "allocatable attribute or derived type without allocatable "
5334 gfc_init_block (&fnblock);
5336 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5337 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5339 if (sym->ts.type == BT_CHARACTER
5340 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5342 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5343 gfc_trans_vla_type_sizes (sym, &fnblock);
5346 /* Dummy and use associated variables don't need anything special. */
5347 if (sym->attr.dummy || sym->attr.use_assoc)
5349 gfc_add_expr_to_block (&fnblock, body);
5351 return gfc_finish_block (&fnblock);
5354 gfc_get_backend_locus (&loc);
5355 gfc_set_backend_locus (&sym->declared_at);
5356 descriptor = sym->backend_decl;
5358 /* Although static, derived types with default initializers and
5359 allocatable components must not be nulled wholesale; instead they
5360 are treated component by component. */
5361 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5363 /* SAVEd variables are not freed on exit. */
5364 gfc_trans_static_array_pointer (sym);
5368 /* Get the descriptor type. */
5369 type = TREE_TYPE (sym->backend_decl);
5371 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5373 if (!sym->attr.save)
5375 rank = sym->as ? sym->as->rank : 0;
5376 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5377 gfc_add_expr_to_block (&fnblock, tmp);
5380 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5382 /* If the backend_decl is not a descriptor, we must have a pointer
5384 descriptor = build_fold_indirect_ref (sym->backend_decl);
5385 type = TREE_TYPE (descriptor);
5388 /* NULLIFY the data pointer. */
5389 if (GFC_DESCRIPTOR_TYPE_P (type))
5390 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5392 gfc_add_expr_to_block (&fnblock, body);
5394 gfc_set_backend_locus (&loc);
5396 /* Allocatable arrays need to be freed when they go out of scope.
5397 The allocatable components of pointers must not be touched. */
5398 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5399 && !sym->attr.pointer && !sym->attr.save)
5402 rank = sym->as ? sym->as->rank : 0;
5403 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5404 gfc_add_expr_to_block (&fnblock, tmp);
5407 if (sym->attr.allocatable)
5409 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5410 gfc_add_expr_to_block (&fnblock, tmp);
5413 return gfc_finish_block (&fnblock);
5416 /************ Expression Walking Functions ******************/
5418 /* Walk a variable reference.
5420 Possible extension - multiple component subscripts.
5421 x(:,:) = foo%a(:)%b(:)
5423 forall (i=..., j=...)
5424 x(i,j) = foo%a(j)%b(i)
5426 This adds a fair amount of complexity because you need to deal with more
5427 than one ref. Maybe handle in a similar manner to vector subscripts.
5428 Maybe not worth the effort. */
5432 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5440 for (ref = expr->ref; ref; ref = ref->next)
5441 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5444 for (; ref; ref = ref->next)
5446 if (ref->type == REF_SUBSTRING)
5448 newss = gfc_get_ss ();
5449 newss->type = GFC_SS_SCALAR;
5450 newss->expr = ref->u.ss.start;
5454 newss = gfc_get_ss ();
5455 newss->type = GFC_SS_SCALAR;
5456 newss->expr = ref->u.ss.end;
5461 /* We're only interested in array sections from now on. */
5462 if (ref->type != REF_ARRAY)
5469 for (n = 0; n < ar->dimen; n++)
5471 newss = gfc_get_ss ();
5472 newss->type = GFC_SS_SCALAR;
5473 newss->expr = ar->start[n];
5480 newss = gfc_get_ss ();
5481 newss->type = GFC_SS_SECTION;
5484 newss->data.info.dimen = ar->as->rank;
5485 newss->data.info.ref = ref;
5487 /* Make sure array is the same as array(:,:), this way
5488 we don't need to special case all the time. */
5489 ar->dimen = ar->as->rank;
5490 for (n = 0; n < ar->dimen; n++)
5492 newss->data.info.dim[n] = n;
5493 ar->dimen_type[n] = DIMEN_RANGE;
5495 gcc_assert (ar->start[n] == NULL);
5496 gcc_assert (ar->end[n] == NULL);
5497 gcc_assert (ar->stride[n] == NULL);
5503 newss = gfc_get_ss ();
5504 newss->type = GFC_SS_SECTION;
5507 newss->data.info.dimen = 0;
5508 newss->data.info.ref = ref;
5512 /* We add SS chains for all the subscripts in the section. */
5513 for (n = 0; n < ar->dimen; n++)
5517 switch (ar->dimen_type[n])
5520 /* Add SS for elemental (scalar) subscripts. */
5521 gcc_assert (ar->start[n]);
5522 indexss = gfc_get_ss ();
5523 indexss->type = GFC_SS_SCALAR;
5524 indexss->expr = ar->start[n];
5525 indexss->next = gfc_ss_terminator;
5526 indexss->loop_chain = gfc_ss_terminator;
5527 newss->data.info.subscript[n] = indexss;
5531 /* We don't add anything for sections, just remember this
5532 dimension for later. */
5533 newss->data.info.dim[newss->data.info.dimen] = n;
5534 newss->data.info.dimen++;
5538 /* Create a GFC_SS_VECTOR index in which we can store
5539 the vector's descriptor. */
5540 indexss = gfc_get_ss ();
5541 indexss->type = GFC_SS_VECTOR;
5542 indexss->expr = ar->start[n];
5543 indexss->next = gfc_ss_terminator;
5544 indexss->loop_chain = gfc_ss_terminator;
5545 newss->data.info.subscript[n] = indexss;
5546 newss->data.info.dim[newss->data.info.dimen] = n;
5547 newss->data.info.dimen++;
5551 /* We should know what sort of section it is by now. */
5555 /* We should have at least one non-elemental dimension. */
5556 gcc_assert (newss->data.info.dimen > 0);
5561 /* We should know what sort of section it is by now. */
5570 /* Walk an expression operator. If only one operand of a binary expression is
5571 scalar, we must also add the scalar term to the SS chain. */
5574 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5580 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5581 if (expr->value.op.op2 == NULL)
5584 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5586 /* All operands are scalar. Pass back and let the caller deal with it. */
5590 /* All operands require scalarization. */
5591 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5594 /* One of the operands needs scalarization, the other is scalar.
5595 Create a gfc_ss for the scalar expression. */
5596 newss = gfc_get_ss ();
5597 newss->type = GFC_SS_SCALAR;
5600 /* First operand is scalar. We build the chain in reverse order, so
5601 add the scarar SS after the second operand. */
5603 while (head && head->next != ss)
5605 /* Check we haven't somehow broken the chain. */
5609 newss->expr = expr->value.op.op1;
5611 else /* head2 == head */
5613 gcc_assert (head2 == head);
5614 /* Second operand is scalar. */
5615 newss->next = head2;
5617 newss->expr = expr->value.op.op2;
5624 /* Reverse a SS chain. */
5627 gfc_reverse_ss (gfc_ss * ss)
5632 gcc_assert (ss != NULL);
5634 head = gfc_ss_terminator;
5635 while (ss != gfc_ss_terminator)
5638 /* Check we didn't somehow break the chain. */
5639 gcc_assert (next != NULL);
5649 /* Walk the arguments of an elemental function. */
5652 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5660 head = gfc_ss_terminator;
5663 for (; arg; arg = arg->next)
5668 newss = gfc_walk_subexpr (head, arg->expr);
5671 /* Scalar argument. */
5672 newss = gfc_get_ss ();
5674 newss->expr = arg->expr;
5684 while (tail->next != gfc_ss_terminator)
5691 /* If all the arguments are scalar we don't need the argument SS. */
5692 gfc_free_ss_chain (head);
5697 /* Add it onto the existing chain. */
5703 /* Walk a function call. Scalar functions are passed back, and taken out of
5704 scalarization loops. For elemental functions we walk their arguments.
5705 The result of functions returning arrays is stored in a temporary outside
5706 the loop, so that the function is only called once. Hence we do not need
5707 to walk their arguments. */
5710 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5713 gfc_intrinsic_sym *isym;
5716 isym = expr->value.function.isym;
5718 /* Handle intrinsic functions separately. */
5720 return gfc_walk_intrinsic_function (ss, expr, isym);
5722 sym = expr->value.function.esym;
5724 sym = expr->symtree->n.sym;
5726 /* A function that returns arrays. */
5727 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5729 newss = gfc_get_ss ();
5730 newss->type = GFC_SS_FUNCTION;
5733 newss->data.info.dimen = expr->rank;
5737 /* Walk the parameters of an elemental function. For now we always pass
5739 if (sym->attr.elemental)
5740 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5743 /* Scalar functions are OK as these are evaluated outside the scalarization
5744 loop. Pass back and let the caller deal with it. */
5749 /* An array temporary is constructed for array constructors. */
5752 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5757 newss = gfc_get_ss ();
5758 newss->type = GFC_SS_CONSTRUCTOR;
5761 newss->data.info.dimen = expr->rank;
5762 for (n = 0; n < expr->rank; n++)
5763 newss->data.info.dim[n] = n;
5769 /* Walk an expression. Add walked expressions to the head of the SS chain.
5770 A wholly scalar expression will not be added. */
5773 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5777 switch (expr->expr_type)
5780 head = gfc_walk_variable_expr (ss, expr);
5784 head = gfc_walk_op_expr (ss, expr);
5788 head = gfc_walk_function_expr (ss, expr);
5793 case EXPR_STRUCTURE:
5794 /* Pass back and let the caller deal with it. */
5798 head = gfc_walk_array_constructor (ss, expr);
5801 case EXPR_SUBSTRING:
5802 /* Pass back and let the caller deal with it. */
5806 internal_error ("bad expression type during walk (%d)",
5813 /* Entry point for expression walking.
5814 A return value equal to the passed chain means this is
5815 a scalar expression. It is up to the caller to take whatever action is
5816 necessary to translate these. */
5819 gfc_walk_expr (gfc_expr * expr)
5823 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5824 return gfc_reverse_ss (res);