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, NULL);
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, size_type_node, fold_convert (size_type_node, tmp),
847 fold_convert (size_type_node, size));
849 /* Call the realloc() function. */
850 tmp = gfc_call_realloc (pblock, arg0, arg1);
851 gfc_conv_descriptor_data_set (pblock, desc, tmp);
855 /* Return true if the bounds of iterator I can only be determined
859 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
861 return (i->start->expr_type != EXPR_CONSTANT
862 || i->end->expr_type != EXPR_CONSTANT
863 || i->step->expr_type != EXPR_CONSTANT);
867 /* Split the size of constructor element EXPR into the sum of two terms,
868 one of which can be determined at compile time and one of which must
869 be calculated at run time. Set *SIZE to the former and return true
870 if the latter might be nonzero. */
873 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
875 if (expr->expr_type == EXPR_ARRAY)
876 return gfc_get_array_constructor_size (size, expr->value.constructor);
877 else if (expr->rank > 0)
879 /* Calculate everything at run time. */
880 mpz_set_ui (*size, 0);
885 /* A single element. */
886 mpz_set_ui (*size, 1);
892 /* Like gfc_get_array_constructor_element_size, but applied to the whole
893 of array constructor C. */
896 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
903 mpz_set_ui (*size, 0);
908 for (; c; c = c->next)
911 if (i && gfc_iterator_has_dynamic_bounds (i))
915 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
918 /* Multiply the static part of the element size by the
919 number of iterations. */
920 mpz_sub (val, i->end->value.integer, i->start->value.integer);
921 mpz_fdiv_q (val, val, i->step->value.integer);
922 mpz_add_ui (val, val, 1);
923 if (mpz_sgn (val) > 0)
924 mpz_mul (len, len, val);
928 mpz_add (*size, *size, len);
937 /* Make sure offset is a variable. */
940 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
943 /* We should have already created the offset variable. We cannot
944 create it here because we may be in an inner scope. */
945 gcc_assert (*offsetvar != NULL_TREE);
946 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
947 *poffset = *offsetvar;
948 TREE_USED (*offsetvar) = 1;
952 /* Assign an element of an array constructor. */
955 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
956 tree offset, gfc_se * se, gfc_expr * expr)
960 gfc_conv_expr (se, expr);
962 /* Store the value. */
963 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
964 tmp = gfc_build_array_ref (tmp, offset, NULL);
965 if (expr->ts.type == BT_CHARACTER)
967 gfc_conv_string_parameter (se);
968 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
970 /* The temporary is an array of pointers. */
971 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
972 gfc_add_modify_expr (&se->pre, tmp, se->expr);
976 /* The temporary is an array of string values. */
977 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
978 /* We know the temporary and the value will be the same length,
979 so can use memcpy. */
980 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
981 tmp, se->expr, se->string_length);
982 gfc_add_expr_to_block (&se->pre, tmp);
987 /* TODO: Should the frontend already have done this conversion? */
988 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
989 gfc_add_modify_expr (&se->pre, tmp, se->expr);
992 gfc_add_block_to_block (pblock, &se->pre);
993 gfc_add_block_to_block (pblock, &se->post);
997 /* Add the contents of an array to the constructor. DYNAMIC is as for
998 gfc_trans_array_constructor_value. */
1001 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1002 tree type ATTRIBUTE_UNUSED,
1003 tree desc, gfc_expr * expr,
1004 tree * poffset, tree * offsetvar,
1015 /* We need this to be a variable so we can increment it. */
1016 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1018 gfc_init_se (&se, NULL);
1020 /* Walk the array expression. */
1021 ss = gfc_walk_expr (expr);
1022 gcc_assert (ss != gfc_ss_terminator);
1024 /* Initialize the scalarizer. */
1025 gfc_init_loopinfo (&loop);
1026 gfc_add_ss_to_loop (&loop, ss);
1028 /* Initialize the loop. */
1029 gfc_conv_ss_startstride (&loop);
1030 gfc_conv_loop_setup (&loop);
1032 /* Make sure the constructed array has room for the new data. */
1035 /* Set SIZE to the total number of elements in the subarray. */
1036 size = gfc_index_one_node;
1037 for (n = 0; n < loop.dimen; n++)
1039 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1040 gfc_index_one_node);
1041 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1044 /* Grow the constructed array by SIZE elements. */
1045 gfc_grow_array (&loop.pre, desc, size);
1048 /* Make the loop body. */
1049 gfc_mark_ss_chain_used (ss, 1);
1050 gfc_start_scalarized_body (&loop, &body);
1051 gfc_copy_loopinfo_to_se (&se, &loop);
1054 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1055 gcc_assert (se.ss == gfc_ss_terminator);
1057 /* Increment the offset. */
1058 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1059 gfc_add_modify_expr (&body, *poffset, tmp);
1061 /* Finish the loop. */
1062 gfc_trans_scalarizing_loops (&loop, &body);
1063 gfc_add_block_to_block (&loop.pre, &loop.post);
1064 tmp = gfc_finish_block (&loop.pre);
1065 gfc_add_expr_to_block (pblock, tmp);
1067 gfc_cleanup_loop (&loop);
1071 /* Assign the values to the elements of an array constructor. DYNAMIC
1072 is true if descriptor DESC only contains enough data for the static
1073 size calculated by gfc_get_array_constructor_size. When true, memory
1074 for the dynamic parts must be allocated using realloc. */
1077 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1078 tree desc, gfc_constructor * c,
1079 tree * poffset, tree * offsetvar,
1088 for (; c; c = c->next)
1090 /* If this is an iterator or an array, the offset must be a variable. */
1091 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1092 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1094 gfc_start_block (&body);
1096 if (c->expr->expr_type == EXPR_ARRAY)
1098 /* Array constructors can be nested. */
1099 gfc_trans_array_constructor_value (&body, type, desc,
1100 c->expr->value.constructor,
1101 poffset, offsetvar, dynamic);
1103 else if (c->expr->rank > 0)
1105 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1106 poffset, offsetvar, dynamic);
1110 /* This code really upsets the gimplifier so don't bother for now. */
1117 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1124 /* Scalar values. */
1125 gfc_init_se (&se, NULL);
1126 gfc_trans_array_ctor_element (&body, desc, *poffset,
1129 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1130 *poffset, gfc_index_one_node);
1134 /* Collect multiple scalar constants into a constructor. */
1142 /* Count the number of consecutive scalar constants. */
1143 while (p && !(p->iterator
1144 || p->expr->expr_type != EXPR_CONSTANT))
1146 gfc_init_se (&se, NULL);
1147 gfc_conv_constant (&se, p->expr);
1148 if (p->expr->ts.type == BT_CHARACTER
1149 && POINTER_TYPE_P (type))
1151 /* For constant character array constructors we build
1152 an array of pointers. */
1153 se.expr = gfc_build_addr_expr (pchar_type_node,
1157 list = tree_cons (NULL_TREE, se.expr, list);
1162 bound = build_int_cst (NULL_TREE, n - 1);
1163 /* Create an array type to hold them. */
1164 tmptype = build_range_type (gfc_array_index_type,
1165 gfc_index_zero_node, bound);
1166 tmptype = build_array_type (type, tmptype);
1168 init = build_constructor_from_list (tmptype, nreverse (list));
1169 TREE_CONSTANT (init) = 1;
1170 TREE_INVARIANT (init) = 1;
1171 TREE_STATIC (init) = 1;
1172 /* Create a static variable to hold the data. */
1173 tmp = gfc_create_var (tmptype, "data");
1174 TREE_STATIC (tmp) = 1;
1175 TREE_CONSTANT (tmp) = 1;
1176 TREE_INVARIANT (tmp) = 1;
1177 TREE_READONLY (tmp) = 1;
1178 DECL_INITIAL (tmp) = init;
1181 /* Use BUILTIN_MEMCPY to assign the values. */
1182 tmp = gfc_conv_descriptor_data_get (desc);
1183 tmp = build_fold_indirect_ref (tmp);
1184 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1185 tmp = build_fold_addr_expr (tmp);
1186 init = build_fold_addr_expr (init);
1188 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1189 bound = build_int_cst (NULL_TREE, n * size);
1190 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1192 gfc_add_expr_to_block (&body, tmp);
1194 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1196 build_int_cst (gfc_array_index_type, n));
1198 if (!INTEGER_CST_P (*poffset))
1200 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1201 *poffset = *offsetvar;
1205 /* The frontend should already have done any expansions possible
1209 /* Pass the code as is. */
1210 tmp = gfc_finish_block (&body);
1211 gfc_add_expr_to_block (pblock, tmp);
1215 /* Build the implied do-loop. */
1225 loopbody = gfc_finish_block (&body);
1227 gfc_init_se (&se, NULL);
1228 gfc_conv_expr (&se, c->iterator->var);
1229 gfc_add_block_to_block (pblock, &se.pre);
1232 /* Make a temporary, store the current value in that
1233 and return it, once the loop is done. */
1234 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1235 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1237 /* Initialize the loop. */
1238 gfc_init_se (&se, NULL);
1239 gfc_conv_expr_val (&se, c->iterator->start);
1240 gfc_add_block_to_block (pblock, &se.pre);
1241 gfc_add_modify_expr (pblock, loopvar, se.expr);
1243 gfc_init_se (&se, NULL);
1244 gfc_conv_expr_val (&se, c->iterator->end);
1245 gfc_add_block_to_block (pblock, &se.pre);
1246 end = gfc_evaluate_now (se.expr, pblock);
1248 gfc_init_se (&se, NULL);
1249 gfc_conv_expr_val (&se, c->iterator->step);
1250 gfc_add_block_to_block (pblock, &se.pre);
1251 step = gfc_evaluate_now (se.expr, pblock);
1253 /* If this array expands dynamically, and the number of iterations
1254 is not constant, we won't have allocated space for the static
1255 part of C->EXPR's size. Do that now. */
1256 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1258 /* Get the number of iterations. */
1259 tmp = gfc_get_iteration_count (loopvar, end, step);
1261 /* Get the static part of C->EXPR's size. */
1262 gfc_get_array_constructor_element_size (&size, c->expr);
1263 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1265 /* Grow the array by TMP * TMP2 elements. */
1266 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1267 gfc_grow_array (pblock, desc, tmp);
1270 /* Generate the loop body. */
1271 exit_label = gfc_build_label_decl (NULL_TREE);
1272 gfc_start_block (&body);
1274 /* Generate the exit condition. Depending on the sign of
1275 the step variable we have to generate the correct
1277 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1278 build_int_cst (TREE_TYPE (step), 0));
1279 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1280 build2 (GT_EXPR, boolean_type_node,
1282 build2 (LT_EXPR, boolean_type_node,
1284 tmp = build1_v (GOTO_EXPR, exit_label);
1285 TREE_USED (exit_label) = 1;
1286 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1287 gfc_add_expr_to_block (&body, tmp);
1289 /* The main loop body. */
1290 gfc_add_expr_to_block (&body, loopbody);
1292 /* Increase loop variable by step. */
1293 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1294 gfc_add_modify_expr (&body, loopvar, tmp);
1296 /* Finish the loop. */
1297 tmp = gfc_finish_block (&body);
1298 tmp = build1_v (LOOP_EXPR, tmp);
1299 gfc_add_expr_to_block (pblock, tmp);
1301 /* Add the exit label. */
1302 tmp = build1_v (LABEL_EXPR, exit_label);
1303 gfc_add_expr_to_block (pblock, tmp);
1305 /* Restore the original value of the loop counter. */
1306 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1313 /* Figure out the string length of a variable reference expression.
1314 Used by get_array_ctor_strlen. */
1317 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1323 /* Don't bother if we already know the length is a constant. */
1324 if (*len && INTEGER_CST_P (*len))
1327 ts = &expr->symtree->n.sym->ts;
1328 for (ref = expr->ref; ref; ref = ref->next)
1333 /* Array references don't change the string length. */
1337 /* Use the length of the component. */
1338 ts = &ref->u.c.component->ts;
1342 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1343 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1345 mpz_init_set_ui (char_len, 1);
1346 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1347 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1348 *len = gfc_conv_mpz_to_tree (char_len,
1349 gfc_default_character_kind);
1350 *len = convert (gfc_charlen_type_node, *len);
1351 mpz_clear (char_len);
1355 /* TODO: Substrings are tricky because we can't evaluate the
1356 expression more than once. For now we just give up, and hope
1357 we can figure it out elsewhere. */
1362 *len = ts->cl->backend_decl;
1366 /* A catch-all to obtain the string length for anything that is not a
1367 constant, array or variable. */
1369 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1374 /* Don't bother if we already know the length is a constant. */
1375 if (*len && INTEGER_CST_P (*len))
1378 if (!e->ref && e->ts.cl && e->ts.cl->length
1379 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1382 gfc_conv_const_charlen (e->ts.cl);
1383 *len = e->ts.cl->backend_decl;
1387 /* Otherwise, be brutal even if inefficient. */
1388 ss = gfc_walk_expr (e);
1389 gfc_init_se (&se, NULL);
1391 /* No function call, in case of side effects. */
1392 se.no_function_call = 1;
1393 if (ss == gfc_ss_terminator)
1394 gfc_conv_expr (&se, e);
1396 gfc_conv_expr_descriptor (&se, e, ss);
1398 /* Fix the value. */
1399 *len = gfc_evaluate_now (se.string_length, &se.pre);
1401 gfc_add_block_to_block (block, &se.pre);
1402 gfc_add_block_to_block (block, &se.post);
1404 e->ts.cl->backend_decl = *len;
1409 /* Figure out the string length of a character array constructor.
1410 Returns TRUE if all elements are character constants. */
1413 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1416 tree first_len = NULL_TREE;
1422 *len = build_int_cstu (gfc_charlen_type_node, 0);
1426 for (; c; c = c->next)
1428 switch (c->expr->expr_type)
1431 if (!(*len && INTEGER_CST_P (*len)))
1432 *len = build_int_cstu (gfc_charlen_type_node,
1433 c->expr->value.character.length);
1437 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1443 get_array_ctor_var_strlen (c->expr, len);
1448 get_array_ctor_all_strlen (block, c->expr, len);
1451 if (flag_bounds_check)
1457 /* Verify that all constructor elements are of the same
1459 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1461 gfc_trans_runtime_check
1462 (cond, block, &c->expr->where,
1463 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1464 fold_convert (long_integer_type_node, first_len),
1465 fold_convert (long_integer_type_node, *len));
1473 /* Check whether the array constructor C consists entirely of constant
1474 elements, and if so returns the number of those elements, otherwise
1475 return zero. Note, an empty or NULL array constructor returns zero. */
1477 unsigned HOST_WIDE_INT
1478 gfc_constant_array_constructor_p (gfc_constructor * c)
1480 unsigned HOST_WIDE_INT nelem = 0;
1485 || c->expr->rank > 0
1486 || c->expr->expr_type != EXPR_CONSTANT)
1495 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1496 and the tree type of it's elements, TYPE, return a static constant
1497 variable that is compile-time initialized. */
1500 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1502 tree tmptype, list, init, tmp;
1503 HOST_WIDE_INT nelem;
1509 /* First traverse the constructor list, converting the constants
1510 to tree to build an initializer. */
1513 c = expr->value.constructor;
1516 gfc_init_se (&se, NULL);
1517 gfc_conv_constant (&se, c->expr);
1518 if (c->expr->ts.type == BT_CHARACTER
1519 && POINTER_TYPE_P (type))
1520 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1521 list = tree_cons (NULL_TREE, se.expr, list);
1526 /* Next determine the tree type for the array. We use the gfortran
1527 front-end's gfc_get_nodesc_array_type in order to create a suitable
1528 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1530 memset (&as, 0, sizeof (gfc_array_spec));
1532 as.rank = expr->rank;
1533 as.type = AS_EXPLICIT;
1536 as.lower[0] = gfc_int_expr (0);
1537 as.upper[0] = gfc_int_expr (nelem - 1);
1540 for (i = 0; i < expr->rank; i++)
1542 int tmp = (int) mpz_get_si (expr->shape[i]);
1543 as.lower[i] = gfc_int_expr (0);
1544 as.upper[i] = gfc_int_expr (tmp - 1);
1547 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1549 init = build_constructor_from_list (tmptype, nreverse (list));
1551 TREE_CONSTANT (init) = 1;
1552 TREE_INVARIANT (init) = 1;
1553 TREE_STATIC (init) = 1;
1555 tmp = gfc_create_var (tmptype, "A");
1556 TREE_STATIC (tmp) = 1;
1557 TREE_CONSTANT (tmp) = 1;
1558 TREE_INVARIANT (tmp) = 1;
1559 TREE_READONLY (tmp) = 1;
1560 DECL_INITIAL (tmp) = init;
1566 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1567 This mostly initializes the scalarizer state info structure with the
1568 appropriate values to directly use the array created by the function
1569 gfc_build_constant_array_constructor. */
1572 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1573 gfc_ss * ss, tree type)
1579 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1581 info = &ss->data.info;
1583 info->descriptor = tmp;
1584 info->data = build_fold_addr_expr (tmp);
1585 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1588 for (i = 0; i < info->dimen; i++)
1590 info->delta[i] = gfc_index_zero_node;
1591 info->start[i] = gfc_index_zero_node;
1592 info->end[i] = gfc_index_zero_node;
1593 info->stride[i] = gfc_index_one_node;
1597 if (info->dimen > loop->temp_dim)
1598 loop->temp_dim = info->dimen;
1601 /* Helper routine of gfc_trans_array_constructor to determine if the
1602 bounds of the loop specified by LOOP are constant and simple enough
1603 to use with gfc_trans_constant_array_constructor. Returns the
1604 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1607 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1609 tree size = gfc_index_one_node;
1613 for (i = 0; i < loop->dimen; i++)
1615 /* If the bounds aren't constant, return NULL_TREE. */
1616 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1618 if (!integer_zerop (loop->from[i]))
1620 /* Only allow nonzero "from" in one-dimensional arrays. */
1621 if (loop->dimen != 1)
1623 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1624 loop->to[i], loop->from[i]);
1628 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1629 tmp, gfc_index_one_node);
1630 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1637 /* Array constructors are handled by constructing a temporary, then using that
1638 within the scalarization loop. This is not optimal, but seems by far the
1642 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1651 ss->data.info.dimen = loop->dimen;
1653 c = ss->expr->value.constructor;
1654 if (ss->expr->ts.type == BT_CHARACTER)
1656 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1658 /* Complex character array constructors should have been taken care of
1659 and not end up here. */
1660 gcc_assert (ss->string_length);
1662 ss->expr->ts.cl->backend_decl = ss->string_length;
1664 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1666 type = build_pointer_type (type);
1669 type = gfc_typenode_for_spec (&ss->expr->ts);
1671 /* See if the constructor determines the loop bounds. */
1674 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1676 /* We have a multidimensional parameter. */
1678 for (n = 0; n < ss->expr->rank; n++)
1680 loop->from[n] = gfc_index_zero_node;
1681 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1682 gfc_index_integer_kind);
1683 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1684 loop->to[n], gfc_index_one_node);
1688 if (loop->to[0] == NULL_TREE)
1692 /* We should have a 1-dimensional, zero-based loop. */
1693 gcc_assert (loop->dimen == 1);
1694 gcc_assert (integer_zerop (loop->from[0]));
1696 /* Split the constructor size into a static part and a dynamic part.
1697 Allocate the static size up-front and record whether the dynamic
1698 size might be nonzero. */
1700 dynamic = gfc_get_array_constructor_size (&size, c);
1701 mpz_sub_ui (size, size, 1);
1702 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1706 /* Special case constant array constructors. */
1709 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1712 tree size = constant_array_constructor_loop_size (loop);
1713 if (size && compare_tree_int (size, nelem) == 0)
1715 gfc_trans_constant_array_constructor (loop, ss, type);
1721 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1722 type, dynamic, true, false);
1724 desc = ss->data.info.descriptor;
1725 offset = gfc_index_zero_node;
1726 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1727 TREE_NO_WARNING (offsetvar) = 1;
1728 TREE_USED (offsetvar) = 0;
1729 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1730 &offset, &offsetvar, dynamic);
1732 /* If the array grows dynamically, the upper bound of the loop variable
1733 is determined by the array's final upper bound. */
1735 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1737 if (TREE_USED (offsetvar))
1738 pushdecl (offsetvar);
1740 gcc_assert (INTEGER_CST_P (offset));
1742 /* Disable bound checking for now because it's probably broken. */
1743 if (flag_bounds_check)
1751 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1752 called after evaluating all of INFO's vector dimensions. Go through
1753 each such vector dimension and see if we can now fill in any missing
1757 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1766 for (n = 0; n < loop->dimen; n++)
1769 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1770 && loop->to[n] == NULL)
1772 /* Loop variable N indexes vector dimension DIM, and we don't
1773 yet know the upper bound of loop variable N. Set it to the
1774 difference between the vector's upper and lower bounds. */
1775 gcc_assert (loop->from[n] == gfc_index_zero_node);
1776 gcc_assert (info->subscript[dim]
1777 && info->subscript[dim]->type == GFC_SS_VECTOR);
1779 gfc_init_se (&se, NULL);
1780 desc = info->subscript[dim]->data.info.descriptor;
1781 zero = gfc_rank_cst[0];
1782 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1783 gfc_conv_descriptor_ubound (desc, zero),
1784 gfc_conv_descriptor_lbound (desc, zero));
1785 tmp = gfc_evaluate_now (tmp, &loop->pre);
1792 /* Add the pre and post chains for all the scalar expressions in a SS chain
1793 to loop. This is called after the loop parameters have been calculated,
1794 but before the actual scalarizing loops. */
1797 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1802 /* TODO: This can generate bad code if there are ordering dependencies.
1803 eg. a callee allocated function and an unknown size constructor. */
1804 gcc_assert (ss != NULL);
1806 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1813 /* Scalar expression. Evaluate this now. This includes elemental
1814 dimension indices, but not array section bounds. */
1815 gfc_init_se (&se, NULL);
1816 gfc_conv_expr (&se, ss->expr);
1817 gfc_add_block_to_block (&loop->pre, &se.pre);
1819 if (ss->expr->ts.type != BT_CHARACTER)
1821 /* Move the evaluation of scalar expressions outside the
1822 scalarization loop. */
1824 se.expr = convert(gfc_array_index_type, se.expr);
1825 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1826 gfc_add_block_to_block (&loop->pre, &se.post);
1829 gfc_add_block_to_block (&loop->post, &se.post);
1831 ss->data.scalar.expr = se.expr;
1832 ss->string_length = se.string_length;
1835 case GFC_SS_REFERENCE:
1836 /* Scalar reference. Evaluate this now. */
1837 gfc_init_se (&se, NULL);
1838 gfc_conv_expr_reference (&se, ss->expr);
1839 gfc_add_block_to_block (&loop->pre, &se.pre);
1840 gfc_add_block_to_block (&loop->post, &se.post);
1842 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1843 ss->string_length = se.string_length;
1846 case GFC_SS_SECTION:
1847 /* Add the expressions for scalar and vector subscripts. */
1848 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1849 if (ss->data.info.subscript[n])
1850 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1852 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1856 /* Get the vector's descriptor and store it in SS. */
1857 gfc_init_se (&se, NULL);
1858 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1859 gfc_add_block_to_block (&loop->pre, &se.pre);
1860 gfc_add_block_to_block (&loop->post, &se.post);
1861 ss->data.info.descriptor = se.expr;
1864 case GFC_SS_INTRINSIC:
1865 gfc_add_intrinsic_ss_code (loop, ss);
1868 case GFC_SS_FUNCTION:
1869 /* Array function return value. We call the function and save its
1870 result in a temporary for use inside the loop. */
1871 gfc_init_se (&se, NULL);
1874 gfc_conv_expr (&se, ss->expr);
1875 gfc_add_block_to_block (&loop->pre, &se.pre);
1876 gfc_add_block_to_block (&loop->post, &se.post);
1877 ss->string_length = se.string_length;
1880 case GFC_SS_CONSTRUCTOR:
1881 gfc_trans_array_constructor (loop, ss);
1885 case GFC_SS_COMPONENT:
1886 /* Do nothing. These are handled elsewhere. */
1896 /* Translate expressions for the descriptor and data pointer of a SS. */
1900 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1905 /* Get the descriptor for the array to be scalarized. */
1906 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1907 gfc_init_se (&se, NULL);
1908 se.descriptor_only = 1;
1909 gfc_conv_expr_lhs (&se, ss->expr);
1910 gfc_add_block_to_block (block, &se.pre);
1911 ss->data.info.descriptor = se.expr;
1912 ss->string_length = se.string_length;
1916 /* Also the data pointer. */
1917 tmp = gfc_conv_array_data (se.expr);
1918 /* If this is a variable or address of a variable we use it directly.
1919 Otherwise we must evaluate it now to avoid breaking dependency
1920 analysis by pulling the expressions for elemental array indices
1923 || (TREE_CODE (tmp) == ADDR_EXPR
1924 && DECL_P (TREE_OPERAND (tmp, 0)))))
1925 tmp = gfc_evaluate_now (tmp, block);
1926 ss->data.info.data = tmp;
1928 tmp = gfc_conv_array_offset (se.expr);
1929 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1934 /* Initialize a gfc_loopinfo structure. */
1937 gfc_init_loopinfo (gfc_loopinfo * loop)
1941 memset (loop, 0, sizeof (gfc_loopinfo));
1942 gfc_init_block (&loop->pre);
1943 gfc_init_block (&loop->post);
1945 /* Initially scalarize in order. */
1946 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1949 loop->ss = gfc_ss_terminator;
1953 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1957 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1963 /* Return an expression for the data pointer of an array. */
1966 gfc_conv_array_data (tree descriptor)
1970 type = TREE_TYPE (descriptor);
1971 if (GFC_ARRAY_TYPE_P (type))
1973 if (TREE_CODE (type) == POINTER_TYPE)
1977 /* Descriptorless arrays. */
1978 return build_fold_addr_expr (descriptor);
1982 return gfc_conv_descriptor_data_get (descriptor);
1986 /* Return an expression for the base offset of an array. */
1989 gfc_conv_array_offset (tree descriptor)
1993 type = TREE_TYPE (descriptor);
1994 if (GFC_ARRAY_TYPE_P (type))
1995 return GFC_TYPE_ARRAY_OFFSET (type);
1997 return gfc_conv_descriptor_offset (descriptor);
2001 /* Get an expression for the array stride. */
2004 gfc_conv_array_stride (tree descriptor, int dim)
2009 type = TREE_TYPE (descriptor);
2011 /* For descriptorless arrays use the array size. */
2012 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2013 if (tmp != NULL_TREE)
2016 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2021 /* Like gfc_conv_array_stride, but for the lower bound. */
2024 gfc_conv_array_lbound (tree descriptor, int dim)
2029 type = TREE_TYPE (descriptor);
2031 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2032 if (tmp != NULL_TREE)
2035 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2040 /* Like gfc_conv_array_stride, but for the upper bound. */
2043 gfc_conv_array_ubound (tree descriptor, int dim)
2048 type = TREE_TYPE (descriptor);
2050 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2051 if (tmp != NULL_TREE)
2054 /* This should only ever happen when passing an assumed shape array
2055 as an actual parameter. The value will never be used. */
2056 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2057 return gfc_index_zero_node;
2059 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2064 /* Generate code to perform an array index bound check. */
2067 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2068 locus * where, bool check_upper)
2073 const char * name = NULL;
2075 if (!flag_bounds_check)
2078 index = gfc_evaluate_now (index, &se->pre);
2080 /* We find a name for the error message. */
2082 name = se->ss->expr->symtree->name;
2084 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2085 && se->loop->ss->expr->symtree)
2086 name = se->loop->ss->expr->symtree->name;
2088 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2089 && se->loop->ss->loop_chain->expr
2090 && se->loop->ss->loop_chain->expr->symtree)
2091 name = se->loop->ss->loop_chain->expr->symtree->name;
2093 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2094 && se->loop->ss->loop_chain->expr->symtree)
2095 name = se->loop->ss->loop_chain->expr->symtree->name;
2097 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2099 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2100 && se->loop->ss->expr->value.function.name)
2101 name = se->loop->ss->expr->value.function.name;
2103 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2104 || se->loop->ss->type == GFC_SS_SCALAR)
2105 name = "unnamed constant";
2108 /* Check lower bound. */
2109 tmp = gfc_conv_array_lbound (descriptor, n);
2110 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2112 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2113 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2115 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2116 gfc_msg_fault, n+1);
2117 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2118 fold_convert (long_integer_type_node, index),
2119 fold_convert (long_integer_type_node, tmp));
2122 /* Check upper bound. */
2125 tmp = gfc_conv_array_ubound (descriptor, n);
2126 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2128 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2129 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2131 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2132 gfc_msg_fault, n+1);
2133 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2134 fold_convert (long_integer_type_node, index),
2135 fold_convert (long_integer_type_node, tmp));
2143 /* Return the offset for an index. Performs bound checking for elemental
2144 dimensions. Single element references are processed separately. */
2147 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2148 gfc_array_ref * ar, tree stride)
2154 /* Get the index into the array for this dimension. */
2157 gcc_assert (ar->type != AR_ELEMENT);
2158 switch (ar->dimen_type[dim])
2161 gcc_assert (i == -1);
2162 /* Elemental dimension. */
2163 gcc_assert (info->subscript[dim]
2164 && info->subscript[dim]->type == GFC_SS_SCALAR);
2165 /* We've already translated this value outside the loop. */
2166 index = info->subscript[dim]->data.scalar.expr;
2168 index = gfc_trans_array_bound_check (se, info->descriptor,
2169 index, dim, &ar->where,
2170 (ar->as->type != AS_ASSUMED_SIZE
2171 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2175 gcc_assert (info && se->loop);
2176 gcc_assert (info->subscript[dim]
2177 && info->subscript[dim]->type == GFC_SS_VECTOR);
2178 desc = info->subscript[dim]->data.info.descriptor;
2180 /* Get a zero-based index into the vector. */
2181 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2182 se->loop->loopvar[i], se->loop->from[i]);
2184 /* Multiply the index by the stride. */
2185 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2186 index, gfc_conv_array_stride (desc, 0));
2188 /* Read the vector to get an index into info->descriptor. */
2189 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2190 index = gfc_build_array_ref (data, index, NULL);
2191 index = gfc_evaluate_now (index, &se->pre);
2193 /* Do any bounds checking on the final info->descriptor index. */
2194 index = gfc_trans_array_bound_check (se, info->descriptor,
2195 index, dim, &ar->where,
2196 (ar->as->type != AS_ASSUMED_SIZE
2197 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2201 /* Scalarized dimension. */
2202 gcc_assert (info && se->loop);
2204 /* Multiply the loop variable by the stride and delta. */
2205 index = se->loop->loopvar[i];
2206 if (!integer_onep (info->stride[i]))
2207 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2209 if (!integer_zerop (info->delta[i]))
2210 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2220 /* Temporary array or derived type component. */
2221 gcc_assert (se->loop);
2222 index = se->loop->loopvar[se->loop->order[i]];
2223 if (!integer_zerop (info->delta[i]))
2224 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2225 index, info->delta[i]);
2228 /* Multiply by the stride. */
2229 if (!integer_onep (stride))
2230 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2236 /* Build a scalarized reference to an array. */
2239 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2242 tree decl = NULL_TREE;
2247 info = &se->ss->data.info;
2249 n = se->loop->order[0];
2253 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2255 /* Add the offset for this dimension to the stored offset for all other
2257 if (!integer_zerop (info->offset))
2258 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2260 if (se->ss->expr && is_subref_array (se->ss->expr))
2261 decl = se->ss->expr->symtree->n.sym->backend_decl;
2263 tmp = build_fold_indirect_ref (info->data);
2264 se->expr = gfc_build_array_ref (tmp, index, decl);
2268 /* Translate access of temporary array. */
2271 gfc_conv_tmp_array_ref (gfc_se * se)
2273 se->string_length = se->ss->string_length;
2274 gfc_conv_scalarized_array_ref (se, NULL);
2278 /* Build an array reference. se->expr already holds the array descriptor.
2279 This should be either a variable, indirect variable reference or component
2280 reference. For arrays which do not have a descriptor, se->expr will be
2282 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2285 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2294 /* Handle scalarized references separately. */
2295 if (ar->type != AR_ELEMENT)
2297 gfc_conv_scalarized_array_ref (se, ar);
2298 gfc_advance_se_ss_chain (se);
2302 index = gfc_index_zero_node;
2304 /* Calculate the offsets from all the dimensions. */
2305 for (n = 0; n < ar->dimen; n++)
2307 /* Calculate the index for this dimension. */
2308 gfc_init_se (&indexse, se);
2309 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2310 gfc_add_block_to_block (&se->pre, &indexse.pre);
2312 if (flag_bounds_check)
2314 /* Check array bounds. */
2318 /* Evaluate the indexse.expr only once. */
2319 indexse.expr = save_expr (indexse.expr);
2322 tmp = gfc_conv_array_lbound (se->expr, n);
2323 cond = fold_build2 (LT_EXPR, boolean_type_node,
2325 asprintf (&msg, "%s for array '%s', "
2326 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2327 gfc_msg_fault, sym->name, n+1);
2328 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2329 fold_convert (long_integer_type_node,
2331 fold_convert (long_integer_type_node, tmp));
2334 /* Upper bound, but not for the last dimension of assumed-size
2336 if (n < ar->dimen - 1
2337 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2339 tmp = gfc_conv_array_ubound (se->expr, n);
2340 cond = fold_build2 (GT_EXPR, boolean_type_node,
2342 asprintf (&msg, "%s for array '%s', "
2343 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2344 gfc_msg_fault, sym->name, n+1);
2345 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2346 fold_convert (long_integer_type_node,
2348 fold_convert (long_integer_type_node, tmp));
2353 /* Multiply the index by the stride. */
2354 stride = gfc_conv_array_stride (se->expr, n);
2355 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2358 /* And add it to the total. */
2359 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2362 tmp = gfc_conv_array_offset (se->expr);
2363 if (!integer_zerop (tmp))
2364 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2366 /* Access the calculated element. */
2367 tmp = gfc_conv_array_data (se->expr);
2368 tmp = build_fold_indirect_ref (tmp);
2369 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2373 /* Generate the code to be executed immediately before entering a
2374 scalarization loop. */
2377 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2378 stmtblock_t * pblock)
2387 /* This code will be executed before entering the scalarization loop
2388 for this dimension. */
2389 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2391 if ((ss->useflags & flag) == 0)
2394 if (ss->type != GFC_SS_SECTION
2395 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2396 && ss->type != GFC_SS_COMPONENT)
2399 info = &ss->data.info;
2401 if (dim >= info->dimen)
2404 if (dim == info->dimen - 1)
2406 /* For the outermost loop calculate the offset due to any
2407 elemental dimensions. It will have been initialized with the
2408 base offset of the array. */
2411 for (i = 0; i < info->ref->u.ar.dimen; i++)
2413 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2416 gfc_init_se (&se, NULL);
2418 se.expr = info->descriptor;
2419 stride = gfc_conv_array_stride (info->descriptor, i);
2420 index = gfc_conv_array_index_offset (&se, info, i, -1,
2423 gfc_add_block_to_block (pblock, &se.pre);
2425 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2426 info->offset, index);
2427 info->offset = gfc_evaluate_now (info->offset, pblock);
2431 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2434 stride = gfc_conv_array_stride (info->descriptor, 0);
2436 /* Calculate the stride of the innermost loop. Hopefully this will
2437 allow the backend optimizers to do their stuff more effectively.
2439 info->stride0 = gfc_evaluate_now (stride, pblock);
2443 /* Add the offset for the previous loop dimension. */
2448 ar = &info->ref->u.ar;
2449 i = loop->order[dim + 1];
2457 gfc_init_se (&se, NULL);
2459 se.expr = info->descriptor;
2460 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2461 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2463 gfc_add_block_to_block (pblock, &se.pre);
2464 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2465 info->offset, index);
2466 info->offset = gfc_evaluate_now (info->offset, pblock);
2469 /* Remember this offset for the second loop. */
2470 if (dim == loop->temp_dim - 1)
2471 info->saved_offset = info->offset;
2476 /* Start a scalarized expression. Creates a scope and declares loop
2480 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2486 gcc_assert (!loop->array_parameter);
2488 for (dim = loop->dimen - 1; dim >= 0; dim--)
2490 n = loop->order[dim];
2492 gfc_start_block (&loop->code[n]);
2494 /* Create the loop variable. */
2495 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2497 if (dim < loop->temp_dim)
2501 /* Calculate values that will be constant within this loop. */
2502 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2504 gfc_start_block (pbody);
2508 /* Generates the actual loop code for a scalarization loop. */
2511 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2512 stmtblock_t * pbody)
2520 loopbody = gfc_finish_block (pbody);
2522 /* Initialize the loopvar. */
2523 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2525 exit_label = gfc_build_label_decl (NULL_TREE);
2527 /* Generate the loop body. */
2528 gfc_init_block (&block);
2530 /* The exit condition. */
2531 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2532 tmp = build1_v (GOTO_EXPR, exit_label);
2533 TREE_USED (exit_label) = 1;
2534 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2535 gfc_add_expr_to_block (&block, tmp);
2537 /* The main body. */
2538 gfc_add_expr_to_block (&block, loopbody);
2540 /* Increment the loopvar. */
2541 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2542 loop->loopvar[n], gfc_index_one_node);
2543 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2545 /* Build the loop. */
2546 tmp = gfc_finish_block (&block);
2547 tmp = build1_v (LOOP_EXPR, tmp);
2548 gfc_add_expr_to_block (&loop->code[n], tmp);
2550 /* Add the exit label. */
2551 tmp = build1_v (LABEL_EXPR, exit_label);
2552 gfc_add_expr_to_block (&loop->code[n], tmp);
2556 /* Finishes and generates the loops for a scalarized expression. */
2559 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2564 stmtblock_t *pblock;
2568 /* Generate the loops. */
2569 for (dim = 0; dim < loop->dimen; dim++)
2571 n = loop->order[dim];
2572 gfc_trans_scalarized_loop_end (loop, n, pblock);
2573 loop->loopvar[n] = NULL_TREE;
2574 pblock = &loop->code[n];
2577 tmp = gfc_finish_block (pblock);
2578 gfc_add_expr_to_block (&loop->pre, tmp);
2580 /* Clear all the used flags. */
2581 for (ss = loop->ss; ss; ss = ss->loop_chain)
2586 /* Finish the main body of a scalarized expression, and start the secondary
2590 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2594 stmtblock_t *pblock;
2598 /* We finish as many loops as are used by the temporary. */
2599 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2601 n = loop->order[dim];
2602 gfc_trans_scalarized_loop_end (loop, n, pblock);
2603 loop->loopvar[n] = NULL_TREE;
2604 pblock = &loop->code[n];
2607 /* We don't want to finish the outermost loop entirely. */
2608 n = loop->order[loop->temp_dim - 1];
2609 gfc_trans_scalarized_loop_end (loop, n, pblock);
2611 /* Restore the initial offsets. */
2612 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2614 if ((ss->useflags & 2) == 0)
2617 if (ss->type != GFC_SS_SECTION
2618 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2619 && ss->type != GFC_SS_COMPONENT)
2622 ss->data.info.offset = ss->data.info.saved_offset;
2625 /* Restart all the inner loops we just finished. */
2626 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2628 n = loop->order[dim];
2630 gfc_start_block (&loop->code[n]);
2632 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2634 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2637 /* Start a block for the secondary copying code. */
2638 gfc_start_block (body);
2642 /* Calculate the upper bound of an array section. */
2645 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2654 gcc_assert (ss->type == GFC_SS_SECTION);
2656 info = &ss->data.info;
2659 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2660 /* We'll calculate the upper bound once we have access to the
2661 vector's descriptor. */
2664 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2665 desc = info->descriptor;
2666 end = info->ref->u.ar.end[dim];
2670 /* The upper bound was specified. */
2671 gfc_init_se (&se, NULL);
2672 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2673 gfc_add_block_to_block (pblock, &se.pre);
2678 /* No upper bound was specified, so use the bound of the array. */
2679 bound = gfc_conv_array_ubound (desc, dim);
2686 /* Calculate the lower bound of an array section. */
2689 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2699 gcc_assert (ss->type == GFC_SS_SECTION);
2701 info = &ss->data.info;
2704 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2706 /* We use a zero-based index to access the vector. */
2707 info->start[n] = gfc_index_zero_node;
2708 info->end[n] = gfc_index_zero_node;
2709 info->stride[n] = gfc_index_one_node;
2713 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2714 desc = info->descriptor;
2715 start = info->ref->u.ar.start[dim];
2716 end = info->ref->u.ar.end[dim];
2717 stride = info->ref->u.ar.stride[dim];
2719 /* Calculate the start of the range. For vector subscripts this will
2720 be the range of the vector. */
2723 /* Specified section start. */
2724 gfc_init_se (&se, NULL);
2725 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2726 gfc_add_block_to_block (&loop->pre, &se.pre);
2727 info->start[n] = se.expr;
2731 /* No lower bound specified so use the bound of the array. */
2732 info->start[n] = gfc_conv_array_lbound (desc, dim);
2734 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2736 /* Similarly calculate the end. Although this is not used in the
2737 scalarizer, it is needed when checking bounds and where the end
2738 is an expression with side-effects. */
2741 /* Specified section start. */
2742 gfc_init_se (&se, NULL);
2743 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2744 gfc_add_block_to_block (&loop->pre, &se.pre);
2745 info->end[n] = se.expr;
2749 /* No upper bound specified so use the bound of the array. */
2750 info->end[n] = gfc_conv_array_ubound (desc, dim);
2752 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2754 /* Calculate the stride. */
2756 info->stride[n] = gfc_index_one_node;
2759 gfc_init_se (&se, NULL);
2760 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2761 gfc_add_block_to_block (&loop->pre, &se.pre);
2762 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2767 /* Calculates the range start and stride for a SS chain. Also gets the
2768 descriptor and data pointer. The range of vector subscripts is the size
2769 of the vector. Array bounds are also checked. */
2772 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2780 /* Determine the rank of the loop. */
2782 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2786 case GFC_SS_SECTION:
2787 case GFC_SS_CONSTRUCTOR:
2788 case GFC_SS_FUNCTION:
2789 case GFC_SS_COMPONENT:
2790 loop->dimen = ss->data.info.dimen;
2793 /* As usual, lbound and ubound are exceptions!. */
2794 case GFC_SS_INTRINSIC:
2795 switch (ss->expr->value.function.isym->id)
2797 case GFC_ISYM_LBOUND:
2798 case GFC_ISYM_UBOUND:
2799 loop->dimen = ss->data.info.dimen;
2810 /* We should have determined the rank of the expression by now. If
2811 not, that's bad news. */
2812 gcc_assert (loop->dimen != 0);
2814 /* Loop over all the SS in the chain. */
2815 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2817 if (ss->expr && ss->expr->shape && !ss->shape)
2818 ss->shape = ss->expr->shape;
2822 case GFC_SS_SECTION:
2823 /* Get the descriptor for the array. */
2824 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2826 for (n = 0; n < ss->data.info.dimen; n++)
2827 gfc_conv_section_startstride (loop, ss, n);
2830 case GFC_SS_INTRINSIC:
2831 switch (ss->expr->value.function.isym->id)
2833 /* Fall through to supply start and stride. */
2834 case GFC_ISYM_LBOUND:
2835 case GFC_ISYM_UBOUND:
2841 case GFC_SS_CONSTRUCTOR:
2842 case GFC_SS_FUNCTION:
2843 for (n = 0; n < ss->data.info.dimen; n++)
2845 ss->data.info.start[n] = gfc_index_zero_node;
2846 ss->data.info.end[n] = gfc_index_zero_node;
2847 ss->data.info.stride[n] = gfc_index_one_node;
2856 /* The rest is just runtime bound checking. */
2857 if (flag_bounds_check)
2860 tree lbound, ubound;
2862 tree size[GFC_MAX_DIMENSIONS];
2863 tree stride_pos, stride_neg, non_zerosized, tmp2;
2868 gfc_start_block (&block);
2870 for (n = 0; n < loop->dimen; n++)
2871 size[n] = NULL_TREE;
2873 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2875 if (ss->type != GFC_SS_SECTION)
2878 /* TODO: range checking for mapped dimensions. */
2879 info = &ss->data.info;
2881 /* This code only checks ranges. Elemental and vector
2882 dimensions are checked later. */
2883 for (n = 0; n < loop->dimen; n++)
2888 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2891 if (dim == info->ref->u.ar.dimen - 1
2892 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2893 || info->ref->u.ar.as->cp_was_assumed))
2894 check_upper = false;
2898 /* Zero stride is not allowed. */
2899 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2900 gfc_index_zero_node);
2901 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2902 "of array '%s'", info->dim[n]+1,
2903 ss->expr->symtree->name);
2904 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg);
2907 desc = ss->data.info.descriptor;
2909 /* This is the run-time equivalent of resolve.c's
2910 check_dimension(). The logical is more readable there
2911 than it is here, with all the trees. */
2912 lbound = gfc_conv_array_lbound (desc, dim);
2915 ubound = gfc_conv_array_ubound (desc, dim);
2919 /* non_zerosized is true when the selected range is not
2921 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2922 info->stride[n], gfc_index_zero_node);
2923 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2925 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2928 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2929 info->stride[n], gfc_index_zero_node);
2930 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2932 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2934 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2935 stride_pos, stride_neg);
2937 /* Check the start of the range against the lower and upper
2938 bounds of the array, if the range is not empty. */
2939 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2941 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2942 non_zerosized, tmp);
2943 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2944 " exceeded (%%ld < %%ld)", gfc_msg_fault,
2945 info->dim[n]+1, ss->expr->symtree->name);
2946 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2947 fold_convert (long_integer_type_node,
2949 fold_convert (long_integer_type_node,
2955 tmp = fold_build2 (GT_EXPR, boolean_type_node,
2956 info->start[n], ubound);
2957 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2958 non_zerosized, tmp);
2959 asprintf (&msg, "%s, upper bound of dimension %d of array "
2960 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
2961 info->dim[n]+1, ss->expr->symtree->name);
2962 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2963 fold_convert (long_integer_type_node, info->start[n]),
2964 fold_convert (long_integer_type_node, ubound));
2968 /* Compute the last element of the range, which is not
2969 necessarily "end" (think 0:5:3, which doesn't contain 5)
2970 and check it against both lower and upper bounds. */
2971 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2973 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2975 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2978 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2979 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2980 non_zerosized, tmp);
2981 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2982 " exceeded (%%ld < %%ld)", gfc_msg_fault,
2983 info->dim[n]+1, ss->expr->symtree->name);
2984 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2985 fold_convert (long_integer_type_node,
2987 fold_convert (long_integer_type_node,
2993 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2994 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2995 non_zerosized, tmp);
2996 asprintf (&msg, "%s, upper bound of dimension %d of array "
2997 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
2998 info->dim[n]+1, ss->expr->symtree->name);
2999 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
3000 fold_convert (long_integer_type_node, tmp2),
3001 fold_convert (long_integer_type_node, ubound));
3005 /* Check the section sizes match. */
3006 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3008 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3010 /* We remember the size of the first section, and check all the
3011 others against this. */
3016 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3018 /* For optional arguments, only check bounds if the
3019 argument is present. */
3020 if (ss->expr->symtree->n.sym->attr.optional
3021 || ss->expr->symtree->n.sym->attr.not_always_present)
3025 cond = gfc_conv_expr_present (ss->expr->symtree->n.sym);
3026 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3030 asprintf (&msg, "%s, size mismatch for dimension %d "
3031 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3032 info->dim[n]+1, ss->expr->symtree->name);
3033 gfc_trans_runtime_check (tmp3, &block, &ss->expr->where, msg,
3034 fold_convert (long_integer_type_node, tmp),
3035 fold_convert (long_integer_type_node, size[n]));
3039 size[n] = gfc_evaluate_now (tmp, &block);
3043 tmp = gfc_finish_block (&block);
3044 gfc_add_expr_to_block (&loop->pre, tmp);
3049 /* Return true if the two SS could be aliased, i.e. both point to the same data
3051 /* TODO: resolve aliases based on frontend expressions. */
3054 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3061 lsym = lss->expr->symtree->n.sym;
3062 rsym = rss->expr->symtree->n.sym;
3063 if (gfc_symbols_could_alias (lsym, rsym))
3066 if (rsym->ts.type != BT_DERIVED
3067 && lsym->ts.type != BT_DERIVED)
3070 /* For derived types we must check all the component types. We can ignore
3071 array references as these will have the same base type as the previous
3073 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3075 if (lref->type != REF_COMPONENT)
3078 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3081 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3084 if (rref->type != REF_COMPONENT)
3087 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3092 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3094 if (rref->type != REF_COMPONENT)
3097 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3105 /* Resolve array data dependencies. Creates a temporary if required. */
3106 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3110 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3120 loop->temp_ss = NULL;
3121 aref = dest->data.info.ref;
3124 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3126 if (ss->type != GFC_SS_SECTION)
3129 if (gfc_could_be_alias (dest, ss)
3130 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3136 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3138 lref = dest->expr->ref;
3139 rref = ss->expr->ref;
3141 nDepend = gfc_dep_resolver (lref, rref);
3145 /* TODO : loop shifting. */
3148 /* Mark the dimensions for LOOP SHIFTING */
3149 for (n = 0; n < loop->dimen; n++)
3151 int dim = dest->data.info.dim[n];
3153 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3155 else if (! gfc_is_same_range (&lref->u.ar,
3156 &rref->u.ar, dim, 0))
3160 /* Put all the dimensions with dependencies in the
3163 for (n = 0; n < loop->dimen; n++)
3165 gcc_assert (loop->order[n] == n);
3167 loop->order[dim++] = n;
3170 for (n = 0; n < loop->dimen; n++)
3173 loop->order[dim++] = n;
3176 gcc_assert (dim == loop->dimen);
3185 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3186 if (GFC_ARRAY_TYPE_P (base_type)
3187 || GFC_DESCRIPTOR_TYPE_P (base_type))
3188 base_type = gfc_get_element_type (base_type);
3189 loop->temp_ss = gfc_get_ss ();
3190 loop->temp_ss->type = GFC_SS_TEMP;
3191 loop->temp_ss->data.temp.type = base_type;
3192 loop->temp_ss->string_length = dest->string_length;
3193 loop->temp_ss->data.temp.dimen = loop->dimen;
3194 loop->temp_ss->next = gfc_ss_terminator;
3195 gfc_add_ss_to_loop (loop, loop->temp_ss);
3198 loop->temp_ss = NULL;
3202 /* Initialize the scalarization loop. Creates the loop variables. Determines
3203 the range of the loop variables. Creates a temporary if required.
3204 Calculates how to transform from loop variables to array indices for each
3205 expression. Also generates code for scalar expressions which have been
3206 moved outside the loop. */
3209 gfc_conv_loop_setup (gfc_loopinfo * loop)
3214 gfc_ss_info *specinfo;
3218 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3219 bool dynamic[GFC_MAX_DIMENSIONS];
3225 for (n = 0; n < loop->dimen; n++)
3229 /* We use one SS term, and use that to determine the bounds of the
3230 loop for this dimension. We try to pick the simplest term. */
3231 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3235 /* The frontend has worked out the size for us. */
3240 if (ss->type == GFC_SS_CONSTRUCTOR)
3242 /* An unknown size constructor will always be rank one.
3243 Higher rank constructors will either have known shape,
3244 or still be wrapped in a call to reshape. */
3245 gcc_assert (loop->dimen == 1);
3247 /* Always prefer to use the constructor bounds if the size
3248 can be determined at compile time. Prefer not to otherwise,
3249 since the general case involves realloc, and it's better to
3250 avoid that overhead if possible. */
3251 c = ss->expr->value.constructor;
3252 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3253 if (!dynamic[n] || !loopspec[n])
3258 /* TODO: Pick the best bound if we have a choice between a
3259 function and something else. */
3260 if (ss->type == GFC_SS_FUNCTION)
3266 if (ss->type != GFC_SS_SECTION)
3270 specinfo = &loopspec[n]->data.info;
3273 info = &ss->data.info;
3277 /* Criteria for choosing a loop specifier (most important first):
3278 doesn't need realloc
3284 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3286 else if (integer_onep (info->stride[n])
3287 && !integer_onep (specinfo->stride[n]))
3289 else if (INTEGER_CST_P (info->stride[n])
3290 && !INTEGER_CST_P (specinfo->stride[n]))
3292 else if (INTEGER_CST_P (info->start[n])
3293 && !INTEGER_CST_P (specinfo->start[n]))
3295 /* We don't work out the upper bound.
3296 else if (INTEGER_CST_P (info->finish[n])
3297 && ! INTEGER_CST_P (specinfo->finish[n]))
3298 loopspec[n] = ss; */
3301 /* We should have found the scalarization loop specifier. If not,
3303 gcc_assert (loopspec[n]);
3305 info = &loopspec[n]->data.info;
3307 /* Set the extents of this range. */
3308 cshape = loopspec[n]->shape;
3309 if (cshape && INTEGER_CST_P (info->start[n])
3310 && INTEGER_CST_P (info->stride[n]))
3312 loop->from[n] = info->start[n];
3313 mpz_set (i, cshape[n]);
3314 mpz_sub_ui (i, i, 1);
3315 /* To = from + (size - 1) * stride. */
3316 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3317 if (!integer_onep (info->stride[n]))
3318 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3319 tmp, info->stride[n]);
3320 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3321 loop->from[n], tmp);
3325 loop->from[n] = info->start[n];
3326 switch (loopspec[n]->type)
3328 case GFC_SS_CONSTRUCTOR:
3329 /* The upper bound is calculated when we expand the
3331 gcc_assert (loop->to[n] == NULL_TREE);
3334 case GFC_SS_SECTION:
3335 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3339 case GFC_SS_FUNCTION:
3340 /* The loop bound will be set when we generate the call. */
3341 gcc_assert (loop->to[n] == NULL_TREE);
3349 /* Transform everything so we have a simple incrementing variable. */
3350 if (integer_onep (info->stride[n]))
3351 info->delta[n] = gfc_index_zero_node;
3354 /* Set the delta for this section. */
3355 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3356 /* Number of iterations is (end - start + step) / step.
3357 with start = 0, this simplifies to
3359 for (i = 0; i<=last; i++){...}; */
3360 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3361 loop->to[n], loop->from[n]);
3362 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3363 tmp, info->stride[n]);
3364 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3365 /* Make the loop variable start at 0. */
3366 loop->from[n] = gfc_index_zero_node;
3370 /* Add all the scalar code that can be taken out of the loops.
3371 This may include calculating the loop bounds, so do it before
3372 allocating the temporary. */
3373 gfc_add_loop_ss_code (loop, loop->ss, false);
3375 /* If we want a temporary then create it. */
3376 if (loop->temp_ss != NULL)
3378 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3380 /* Make absolutely sure that this is a complete type. */
3381 if (loop->temp_ss->string_length)
3382 loop->temp_ss->data.temp.type
3383 = gfc_get_character_type_len (gfc_default_character_kind,
3384 loop->temp_ss->string_length);
3386 tmp = loop->temp_ss->data.temp.type;
3387 len = loop->temp_ss->string_length;
3388 n = loop->temp_ss->data.temp.dimen;
3389 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3390 loop->temp_ss->type = GFC_SS_SECTION;
3391 loop->temp_ss->data.info.dimen = n;
3392 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3393 &loop->temp_ss->data.info, tmp, false, true,
3397 for (n = 0; n < loop->temp_dim; n++)
3398 loopspec[loop->order[n]] = NULL;
3402 /* For array parameters we don't have loop variables, so don't calculate the
3404 if (loop->array_parameter)
3407 /* Calculate the translation from loop variables to array indices. */
3408 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3410 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3413 info = &ss->data.info;
3415 for (n = 0; n < info->dimen; n++)
3419 /* If we are specifying the range the delta is already set. */
3420 if (loopspec[n] != ss)
3422 /* Calculate the offset relative to the loop variable.
3423 First multiply by the stride. */
3424 tmp = loop->from[n];
3425 if (!integer_onep (info->stride[n]))
3426 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3427 tmp, info->stride[n]);
3429 /* Then subtract this from our starting value. */
3430 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3431 info->start[n], tmp);
3433 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3440 /* Fills in an array descriptor, and returns the size of the array. The size
3441 will be a simple_val, ie a variable or a constant. Also calculates the
3442 offset of the base. Returns the size of the array.
3446 for (n = 0; n < rank; n++)
3448 a.lbound[n] = specified_lower_bound;
3449 offset = offset + a.lbond[n] * stride;
3451 a.ubound[n] = specified_upper_bound;
3452 a.stride[n] = stride;
3453 size = ubound + size; //size = ubound + 1 - lbound
3454 stride = stride * size;
3461 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3462 gfc_expr ** lower, gfc_expr ** upper,
3463 stmtblock_t * pblock)
3475 stmtblock_t thenblock;
3476 stmtblock_t elseblock;
3481 type = TREE_TYPE (descriptor);
3483 stride = gfc_index_one_node;
3484 offset = gfc_index_zero_node;
3486 /* Set the dtype. */
3487 tmp = gfc_conv_descriptor_dtype (descriptor);
3488 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3490 or_expr = NULL_TREE;
3492 for (n = 0; n < rank; n++)
3494 /* We have 3 possibilities for determining the size of the array:
3495 lower == NULL => lbound = 1, ubound = upper[n]
3496 upper[n] = NULL => lbound = 1, ubound = lower[n]
3497 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3500 /* Set lower bound. */
3501 gfc_init_se (&se, NULL);
3503 se.expr = gfc_index_one_node;
3506 gcc_assert (lower[n]);
3509 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3510 gfc_add_block_to_block (pblock, &se.pre);
3514 se.expr = gfc_index_one_node;
3518 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3519 gfc_add_modify_expr (pblock, tmp, se.expr);
3521 /* Work out the offset for this component. */
3522 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3523 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3525 /* Start the calculation for the size of this dimension. */
3526 size = build2 (MINUS_EXPR, gfc_array_index_type,
3527 gfc_index_one_node, se.expr);
3529 /* Set upper bound. */
3530 gfc_init_se (&se, NULL);
3531 gcc_assert (ubound);
3532 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3533 gfc_add_block_to_block (pblock, &se.pre);
3535 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3536 gfc_add_modify_expr (pblock, tmp, se.expr);
3538 /* Store the stride. */
3539 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3540 gfc_add_modify_expr (pblock, tmp, stride);
3542 /* Calculate the size of this dimension. */
3543 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3545 /* Check whether the size for this dimension is negative. */
3546 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3547 gfc_index_zero_node);
3551 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3553 /* Multiply the stride by the number of elements in this dimension. */
3554 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3555 stride = gfc_evaluate_now (stride, pblock);
3558 /* The stride is the number of elements in the array, so multiply by the
3559 size of an element to get the total size. */
3560 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3561 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3562 fold_convert (gfc_array_index_type, tmp));
3564 if (poffset != NULL)
3566 offset = gfc_evaluate_now (offset, pblock);
3570 if (integer_zerop (or_expr))
3572 if (integer_onep (or_expr))
3573 return gfc_index_zero_node;
3575 var = gfc_create_var (TREE_TYPE (size), "size");
3576 gfc_start_block (&thenblock);
3577 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3578 thencase = gfc_finish_block (&thenblock);
3580 gfc_start_block (&elseblock);
3581 gfc_add_modify_expr (&elseblock, var, size);
3582 elsecase = gfc_finish_block (&elseblock);
3584 tmp = gfc_evaluate_now (or_expr, pblock);
3585 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3586 gfc_add_expr_to_block (pblock, tmp);
3592 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3593 the work for an ALLOCATE statement. */
3597 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3605 gfc_ref *ref, *prev_ref = NULL;
3606 bool allocatable_array;
3610 /* Find the last reference in the chain. */
3611 while (ref && ref->next != NULL)
3613 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3618 if (ref == NULL || ref->type != REF_ARRAY)
3622 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3624 allocatable_array = prev_ref->u.c.component->allocatable;
3626 /* Figure out the size of the array. */
3627 switch (ref->u.ar.type)
3631 upper = ref->u.ar.start;
3635 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3637 lower = ref->u.ar.as->lower;
3638 upper = ref->u.ar.as->upper;
3642 lower = ref->u.ar.start;
3643 upper = ref->u.ar.end;
3651 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3652 lower, upper, &se->pre);
3654 /* Allocate memory to store the data. */
3655 pointer = gfc_conv_descriptor_data_get (se->expr);
3656 STRIP_NOPS (pointer);
3658 /* The allocate_array variants take the old pointer as first argument. */
3659 if (allocatable_array)
3660 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
3662 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3663 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3664 gfc_add_expr_to_block (&se->pre, tmp);
3666 tmp = gfc_conv_descriptor_offset (se->expr);
3667 gfc_add_modify_expr (&se->pre, tmp, offset);
3669 if (expr->ts.type == BT_DERIVED
3670 && expr->ts.derived->attr.alloc_comp)
3672 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3673 ref->u.ar.as->rank);
3674 gfc_add_expr_to_block (&se->pre, tmp);
3681 /* Deallocate an array variable. Also used when an allocated variable goes
3686 gfc_array_deallocate (tree descriptor, tree pstat)
3692 gfc_start_block (&block);
3693 /* Get a pointer to the data. */
3694 var = gfc_conv_descriptor_data_get (descriptor);
3697 /* Parameter is the address of the data component. */
3698 tmp = gfc_deallocate_with_status (var, pstat, false);
3699 gfc_add_expr_to_block (&block, tmp);
3701 /* Zero the data pointer. */
3702 tmp = build2 (MODIFY_EXPR, void_type_node,
3703 var, build_int_cst (TREE_TYPE (var), 0));
3704 gfc_add_expr_to_block (&block, tmp);
3706 return gfc_finish_block (&block);
3710 /* Create an array constructor from an initialization expression.
3711 We assume the frontend already did any expansions and conversions. */
3714 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3721 unsigned HOST_WIDE_INT lo;
3723 VEC(constructor_elt,gc) *v = NULL;
3725 switch (expr->expr_type)
3728 case EXPR_STRUCTURE:
3729 /* A single scalar or derived type value. Create an array with all
3730 elements equal to that value. */
3731 gfc_init_se (&se, NULL);
3733 if (expr->expr_type == EXPR_CONSTANT)
3734 gfc_conv_constant (&se, expr);
3736 gfc_conv_structure (&se, expr, 1);
3738 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3739 gcc_assert (tmp && INTEGER_CST_P (tmp));
3740 hi = TREE_INT_CST_HIGH (tmp);
3741 lo = TREE_INT_CST_LOW (tmp);
3745 /* This will probably eat buckets of memory for large arrays. */
3746 while (hi != 0 || lo != 0)
3748 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3756 /* Create a vector of all the elements. */
3757 for (c = expr->value.constructor; c; c = c->next)
3761 /* Problems occur when we get something like
3762 integer :: a(lots) = (/(i, i=1,lots)/) */
3763 /* TODO: Unexpanded array initializers. */
3765 ("Possible frontend bug: array constructor not expanded");
3767 if (mpz_cmp_si (c->n.offset, 0) != 0)
3768 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3772 if (mpz_cmp_si (c->repeat, 0) != 0)
3776 mpz_set (maxval, c->repeat);
3777 mpz_add (maxval, c->n.offset, maxval);
3778 mpz_sub_ui (maxval, maxval, 1);
3779 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3780 if (mpz_cmp_si (c->n.offset, 0) != 0)
3782 mpz_add_ui (maxval, c->n.offset, 1);
3783 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3786 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3788 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3794 gfc_init_se (&se, NULL);
3795 switch (c->expr->expr_type)
3798 gfc_conv_constant (&se, c->expr);
3799 if (range == NULL_TREE)
3800 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3803 if (index != NULL_TREE)
3804 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3805 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3809 case EXPR_STRUCTURE:
3810 gfc_conv_structure (&se, c->expr, 1);
3811 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3821 return gfc_build_null_descriptor (type);
3827 /* Create a constructor from the list of elements. */
3828 tmp = build_constructor (type, v);
3829 TREE_CONSTANT (tmp) = 1;
3830 TREE_INVARIANT (tmp) = 1;
3835 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3836 returns the size (in elements) of the array. */
3839 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3840 stmtblock_t * pblock)
3855 size = gfc_index_one_node;
3856 offset = gfc_index_zero_node;
3857 for (dim = 0; dim < as->rank; dim++)
3859 /* Evaluate non-constant array bound expressions. */
3860 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3861 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3863 gfc_init_se (&se, NULL);
3864 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3865 gfc_add_block_to_block (pblock, &se.pre);
3866 gfc_add_modify_expr (pblock, lbound, se.expr);
3868 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3869 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3871 gfc_init_se (&se, NULL);
3872 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3873 gfc_add_block_to_block (pblock, &se.pre);
3874 gfc_add_modify_expr (pblock, ubound, se.expr);
3876 /* The offset of this dimension. offset = offset - lbound * stride. */
3877 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3878 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3880 /* The size of this dimension, and the stride of the next. */
3881 if (dim + 1 < as->rank)
3882 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3884 stride = GFC_TYPE_ARRAY_SIZE (type);
3886 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3888 /* Calculate stride = size * (ubound + 1 - lbound). */
3889 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3890 gfc_index_one_node, lbound);
3891 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3892 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3894 gfc_add_modify_expr (pblock, stride, tmp);
3896 stride = gfc_evaluate_now (tmp, pblock);
3898 /* Make sure that negative size arrays are translated
3899 to being zero size. */
3900 tmp = build2 (GE_EXPR, boolean_type_node,
3901 stride, gfc_index_zero_node);
3902 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3903 stride, gfc_index_zero_node);
3904 gfc_add_modify_expr (pblock, stride, tmp);
3910 gfc_trans_vla_type_sizes (sym, pblock);
3917 /* Generate code to initialize/allocate an array variable. */
3920 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3929 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3931 /* Do nothing for USEd variables. */
3932 if (sym->attr.use_assoc)
3935 type = TREE_TYPE (decl);
3936 gcc_assert (GFC_ARRAY_TYPE_P (type));
3937 onstack = TREE_CODE (type) != POINTER_TYPE;
3939 gfc_start_block (&block);
3941 /* Evaluate character string length. */
3942 if (sym->ts.type == BT_CHARACTER
3943 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3945 gfc_conv_string_length (sym->ts.cl, &block);
3947 gfc_trans_vla_type_sizes (sym, &block);
3949 /* Emit a DECL_EXPR for this variable, which will cause the
3950 gimplifier to allocate storage, and all that good stuff. */
3951 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3952 gfc_add_expr_to_block (&block, tmp);
3957 gfc_add_expr_to_block (&block, fnbody);
3958 return gfc_finish_block (&block);
3961 type = TREE_TYPE (type);
3963 gcc_assert (!sym->attr.use_assoc);
3964 gcc_assert (!TREE_STATIC (decl));
3965 gcc_assert (!sym->module);
3967 if (sym->ts.type == BT_CHARACTER
3968 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3969 gfc_conv_string_length (sym->ts.cl, &block);
3971 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3973 /* Don't actually allocate space for Cray Pointees. */
3974 if (sym->attr.cray_pointee)
3976 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3977 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3978 gfc_add_expr_to_block (&block, fnbody);
3979 return gfc_finish_block (&block);
3982 /* The size is the number of elements in the array, so multiply by the
3983 size of an element to get the total size. */
3984 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3985 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
3986 fold_convert (gfc_array_index_type, tmp));
3988 /* Allocate memory to hold the data. */
3989 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3990 gfc_add_modify_expr (&block, decl, tmp);
3992 /* Set offset of the array. */
3993 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3994 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3997 /* Automatic arrays should not have initializers. */
3998 gcc_assert (!sym->value);
4000 gfc_add_expr_to_block (&block, fnbody);
4002 /* Free the temporary. */
4003 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4004 gfc_add_expr_to_block (&block, tmp);
4006 return gfc_finish_block (&block);
4010 /* Generate entry and exit code for g77 calling convention arrays. */
4013 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4023 gfc_get_backend_locus (&loc);
4024 gfc_set_backend_locus (&sym->declared_at);
4026 /* Descriptor type. */
4027 parm = sym->backend_decl;
4028 type = TREE_TYPE (parm);
4029 gcc_assert (GFC_ARRAY_TYPE_P (type));
4031 gfc_start_block (&block);
4033 if (sym->ts.type == BT_CHARACTER
4034 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4035 gfc_conv_string_length (sym->ts.cl, &block);
4037 /* Evaluate the bounds of the array. */
4038 gfc_trans_array_bounds (type, sym, &offset, &block);
4040 /* Set the offset. */
4041 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4042 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4044 /* Set the pointer itself if we aren't using the parameter directly. */
4045 if (TREE_CODE (parm) != PARM_DECL)
4047 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4048 gfc_add_modify_expr (&block, parm, tmp);
4050 stmt = gfc_finish_block (&block);
4052 gfc_set_backend_locus (&loc);
4054 gfc_start_block (&block);
4056 /* Add the initialization code to the start of the function. */
4058 if (sym->attr.optional || sym->attr.not_always_present)
4060 tmp = gfc_conv_expr_present (sym);
4061 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4064 gfc_add_expr_to_block (&block, stmt);
4065 gfc_add_expr_to_block (&block, body);
4067 return gfc_finish_block (&block);
4071 /* Modify the descriptor of an array parameter so that it has the
4072 correct lower bound. Also move the upper bound accordingly.
4073 If the array is not packed, it will be copied into a temporary.
4074 For each dimension we set the new lower and upper bounds. Then we copy the
4075 stride and calculate the offset for this dimension. We also work out
4076 what the stride of a packed array would be, and see it the two match.
4077 If the array need repacking, we set the stride to the values we just
4078 calculated, recalculate the offset and copy the array data.
4079 Code is also added to copy the data back at the end of the function.
4083 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4090 stmtblock_t cleanup;
4098 tree stride, stride2;
4108 /* Do nothing for pointer and allocatable arrays. */
4109 if (sym->attr.pointer || sym->attr.allocatable)
4112 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4113 return gfc_trans_g77_array (sym, body);
4115 gfc_get_backend_locus (&loc);
4116 gfc_set_backend_locus (&sym->declared_at);
4118 /* Descriptor type. */
4119 type = TREE_TYPE (tmpdesc);
4120 gcc_assert (GFC_ARRAY_TYPE_P (type));
4121 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4122 dumdesc = build_fold_indirect_ref (dumdesc);
4123 gfc_start_block (&block);
4125 if (sym->ts.type == BT_CHARACTER
4126 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4127 gfc_conv_string_length (sym->ts.cl, &block);
4129 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4131 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4132 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4134 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4136 /* For non-constant shape arrays we only check if the first dimension
4137 is contiguous. Repacking higher dimensions wouldn't gain us
4138 anything as we still don't know the array stride. */
4139 partial = gfc_create_var (boolean_type_node, "partial");
4140 TREE_USED (partial) = 1;
4141 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4142 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4143 gfc_add_modify_expr (&block, partial, tmp);
4147 partial = NULL_TREE;
4150 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4151 here, however I think it does the right thing. */
4154 /* Set the first stride. */
4155 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4156 stride = gfc_evaluate_now (stride, &block);
4158 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4159 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4160 gfc_index_one_node, stride);
4161 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4162 gfc_add_modify_expr (&block, stride, tmp);
4164 /* Allow the user to disable array repacking. */
4165 stmt_unpacked = NULL_TREE;
4169 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4170 /* A library call to repack the array if necessary. */
4171 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4172 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4174 stride = gfc_index_one_node;
4177 /* This is for the case where the array data is used directly without
4178 calling the repack function. */
4179 if (no_repack || partial != NULL_TREE)
4180 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4182 stmt_packed = NULL_TREE;
4184 /* Assign the data pointer. */
4185 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4187 /* Don't repack unknown shape arrays when the first stride is 1. */
4188 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4189 stmt_packed, stmt_unpacked);
4192 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4193 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4195 offset = gfc_index_zero_node;
4196 size = gfc_index_one_node;
4198 /* Evaluate the bounds of the array. */
4199 for (n = 0; n < sym->as->rank; n++)
4201 if (checkparm || !sym->as->upper[n])
4203 /* Get the bounds of the actual parameter. */
4204 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4205 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4209 dubound = NULL_TREE;
4210 dlbound = NULL_TREE;
4213 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4214 if (!INTEGER_CST_P (lbound))
4216 gfc_init_se (&se, NULL);
4217 gfc_conv_expr_type (&se, sym->as->lower[n],
4218 gfc_array_index_type);
4219 gfc_add_block_to_block (&block, &se.pre);
4220 gfc_add_modify_expr (&block, lbound, se.expr);
4223 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4224 /* Set the desired upper bound. */
4225 if (sym->as->upper[n])
4227 /* We know what we want the upper bound to be. */
4228 if (!INTEGER_CST_P (ubound))
4230 gfc_init_se (&se, NULL);
4231 gfc_conv_expr_type (&se, sym->as->upper[n],
4232 gfc_array_index_type);
4233 gfc_add_block_to_block (&block, &se.pre);
4234 gfc_add_modify_expr (&block, ubound, se.expr);
4237 /* Check the sizes match. */
4240 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4243 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4245 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4247 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4248 asprintf (&msg, "%s for dimension %d of array '%s'",
4249 gfc_msg_bounds, n+1, sym->name);
4250 gfc_trans_runtime_check (tmp, &block, &loc, msg);
4256 /* For assumed shape arrays move the upper bound by the same amount
4257 as the lower bound. */
4258 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4259 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4260 gfc_add_modify_expr (&block, ubound, tmp);
4262 /* The offset of this dimension. offset = offset - lbound * stride. */
4263 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4264 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4266 /* The size of this dimension, and the stride of the next. */
4267 if (n + 1 < sym->as->rank)
4269 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4271 if (no_repack || partial != NULL_TREE)
4274 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4277 /* Figure out the stride if not a known constant. */
4278 if (!INTEGER_CST_P (stride))
4281 stmt_packed = NULL_TREE;
4284 /* Calculate stride = size * (ubound + 1 - lbound). */
4285 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4286 gfc_index_one_node, lbound);
4287 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4289 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4294 /* Assign the stride. */
4295 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4296 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4297 stmt_unpacked, stmt_packed);
4299 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4300 gfc_add_modify_expr (&block, stride, tmp);
4305 stride = GFC_TYPE_ARRAY_SIZE (type);
4307 if (stride && !INTEGER_CST_P (stride))
4309 /* Calculate size = stride * (ubound + 1 - lbound). */
4310 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4311 gfc_index_one_node, lbound);
4312 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4314 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4315 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4316 gfc_add_modify_expr (&block, stride, tmp);
4321 /* Set the offset. */
4322 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4323 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4325 gfc_trans_vla_type_sizes (sym, &block);
4327 stmt = gfc_finish_block (&block);
4329 gfc_start_block (&block);
4331 /* Only do the entry/initialization code if the arg is present. */
4332 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4333 optional_arg = (sym->attr.optional
4334 || (sym->ns->proc_name->attr.entry_master
4335 && sym->attr.dummy));
4338 tmp = gfc_conv_expr_present (sym);
4339 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4341 gfc_add_expr_to_block (&block, stmt);
4343 /* Add the main function body. */
4344 gfc_add_expr_to_block (&block, body);
4349 gfc_start_block (&cleanup);
4351 if (sym->attr.intent != INTENT_IN)
4353 /* Copy the data back. */
4354 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4355 gfc_add_expr_to_block (&cleanup, tmp);
4358 /* Free the temporary. */
4359 tmp = gfc_call_free (tmpdesc);
4360 gfc_add_expr_to_block (&cleanup, tmp);
4362 stmt = gfc_finish_block (&cleanup);
4364 /* Only do the cleanup if the array was repacked. */
4365 tmp = build_fold_indirect_ref (dumdesc);
4366 tmp = gfc_conv_descriptor_data_get (tmp);
4367 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4368 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4372 tmp = gfc_conv_expr_present (sym);
4373 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4375 gfc_add_expr_to_block (&block, stmt);
4377 /* We don't need to free any memory allocated by internal_pack as it will
4378 be freed at the end of the function by pop_context. */
4379 return gfc_finish_block (&block);
4383 /* Calculate the overall offset, including subreferences. */
4385 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4386 bool subref, gfc_expr *expr)
4396 /* If offset is NULL and this is not a subreferenced array, there is
4398 if (offset == NULL_TREE)
4401 offset = gfc_index_zero_node;
4406 tmp = gfc_conv_array_data (desc);
4407 tmp = build_fold_indirect_ref (tmp);
4408 tmp = gfc_build_array_ref (tmp, offset, NULL);
4410 /* Offset the data pointer for pointer assignments from arrays with
4411 subreferences; eg. my_integer => my_type(:)%integer_component. */
4414 /* Go past the array reference. */
4415 for (ref = expr->ref; ref; ref = ref->next)
4416 if (ref->type == REF_ARRAY &&
4417 ref->u.ar.type != AR_ELEMENT)
4423 /* Calculate the offset for each subsequent subreference. */
4424 for (; ref; ref = ref->next)
4429 field = ref->u.c.component->backend_decl;
4430 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4431 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
4435 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4436 gfc_init_se (&start, NULL);
4437 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4438 gfc_add_block_to_block (block, &start.pre);
4439 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4443 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4444 && ref->u.ar.type == AR_ELEMENT);
4446 /* TODO - Add bounds checking. */
4447 stride = gfc_index_one_node;
4448 index = gfc_index_zero_node;
4449 for (n = 0; n < ref->u.ar.dimen; n++)
4454 /* Update the index. */
4455 gfc_init_se (&start, NULL);
4456 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4457 itmp = gfc_evaluate_now (start.expr, block);
4458 gfc_init_se (&start, NULL);
4459 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4460 jtmp = gfc_evaluate_now (start.expr, block);
4461 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4462 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4463 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4464 index = gfc_evaluate_now (index, block);
4466 /* Update the stride. */
4467 gfc_init_se (&start, NULL);
4468 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4469 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4470 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4471 gfc_index_one_node, itmp);
4472 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4473 stride = gfc_evaluate_now (stride, block);
4476 /* Apply the index to obtain the array element. */
4477 tmp = gfc_build_array_ref (tmp, index, NULL);
4487 /* Set the target data pointer. */
4488 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4489 gfc_conv_descriptor_data_set (block, parm, offset);
4493 /* Convert an array for passing as an actual argument. Expressions and
4494 vector subscripts are evaluated and stored in a temporary, which is then
4495 passed. For whole arrays the descriptor is passed. For array sections
4496 a modified copy of the descriptor is passed, but using the original data.
4498 This function is also used for array pointer assignments, and there
4501 - se->want_pointer && !se->direct_byref
4502 EXPR is an actual argument. On exit, se->expr contains a
4503 pointer to the array descriptor.
4505 - !se->want_pointer && !se->direct_byref
4506 EXPR is an actual argument to an intrinsic function or the
4507 left-hand side of a pointer assignment. On exit, se->expr
4508 contains the descriptor for EXPR.
4510 - !se->want_pointer && se->direct_byref
4511 EXPR is the right-hand side of a pointer assignment and
4512 se->expr is the descriptor for the previously-evaluated
4513 left-hand side. The function creates an assignment from
4514 EXPR to se->expr. */
4517 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4530 bool subref_array_target = false;
4532 gcc_assert (ss != gfc_ss_terminator);
4534 /* Special case things we know we can pass easily. */
4535 switch (expr->expr_type)
4538 /* If we have a linear array section, we can pass it directly.
4539 Otherwise we need to copy it into a temporary. */
4541 /* Find the SS for the array section. */
4543 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4544 secss = secss->next;
4546 gcc_assert (secss != gfc_ss_terminator);
4547 info = &secss->data.info;
4549 /* Get the descriptor for the array. */
4550 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4551 desc = info->descriptor;
4553 subref_array_target = se->direct_byref && is_subref_array (expr);
4554 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4555 && !subref_array_target;
4559 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4561 /* Create a new descriptor if the array doesn't have one. */
4564 else if (info->ref->u.ar.type == AR_FULL)
4566 else if (se->direct_byref)
4569 full = gfc_full_array_ref_p (info->ref);
4573 if (se->direct_byref)
4575 /* Copy the descriptor for pointer assignments. */
4576 gfc_add_modify_expr (&se->pre, se->expr, desc);
4578 /* Add any offsets from subreferences. */
4579 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4580 subref_array_target, expr);
4582 else if (se->want_pointer)
4584 /* We pass full arrays directly. This means that pointers and
4585 allocatable arrays should also work. */
4586 se->expr = build_fold_addr_expr (desc);
4593 if (expr->ts.type == BT_CHARACTER)
4594 se->string_length = gfc_get_expr_charlen (expr);
4601 /* A transformational function return value will be a temporary
4602 array descriptor. We still need to go through the scalarizer
4603 to create the descriptor. Elemental functions ar handled as
4604 arbitrary expressions, i.e. copy to a temporary. */
4606 /* Look for the SS for this function. */
4607 while (secss != gfc_ss_terminator
4608 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4609 secss = secss->next;
4611 if (se->direct_byref)
4613 gcc_assert (secss != gfc_ss_terminator);
4615 /* For pointer assignments pass the descriptor directly. */
4617 se->expr = build_fold_addr_expr (se->expr);
4618 gfc_conv_expr (se, expr);
4622 if (secss == gfc_ss_terminator)
4624 /* Elemental function. */
4630 /* Transformational function. */
4631 info = &secss->data.info;
4637 /* Constant array constructors don't need a temporary. */
4638 if (ss->type == GFC_SS_CONSTRUCTOR
4639 && expr->ts.type != BT_CHARACTER
4640 && gfc_constant_array_constructor_p (expr->value.constructor))
4643 info = &ss->data.info;
4655 /* Something complicated. Copy it into a temporary. */
4663 gfc_init_loopinfo (&loop);
4665 /* Associate the SS with the loop. */
4666 gfc_add_ss_to_loop (&loop, ss);
4668 /* Tell the scalarizer not to bother creating loop variables, etc. */
4670 loop.array_parameter = 1;
4672 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4673 gcc_assert (!se->direct_byref);
4675 /* Setup the scalarizing loops and bounds. */
4676 gfc_conv_ss_startstride (&loop);
4680 /* Tell the scalarizer to make a temporary. */
4681 loop.temp_ss = gfc_get_ss ();
4682 loop.temp_ss->type = GFC_SS_TEMP;
4683 loop.temp_ss->next = gfc_ss_terminator;
4685 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4686 gfc_conv_string_length (expr->ts.cl, &se->pre);
4688 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4690 if (expr->ts.type == BT_CHARACTER)
4691 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4693 loop.temp_ss->string_length = NULL;
4695 se->string_length = loop.temp_ss->string_length;
4696 loop.temp_ss->data.temp.dimen = loop.dimen;
4697 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4700 gfc_conv_loop_setup (&loop);
4704 /* Copy into a temporary and pass that. We don't need to copy the data
4705 back because expressions and vector subscripts must be INTENT_IN. */
4706 /* TODO: Optimize passing function return values. */
4710 /* Start the copying loops. */
4711 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4712 gfc_mark_ss_chain_used (ss, 1);
4713 gfc_start_scalarized_body (&loop, &block);
4715 /* Copy each data element. */
4716 gfc_init_se (&lse, NULL);
4717 gfc_copy_loopinfo_to_se (&lse, &loop);
4718 gfc_init_se (&rse, NULL);
4719 gfc_copy_loopinfo_to_se (&rse, &loop);
4721 lse.ss = loop.temp_ss;
4724 gfc_conv_scalarized_array_ref (&lse, NULL);
4725 if (expr->ts.type == BT_CHARACTER)
4727 gfc_conv_expr (&rse, expr);
4728 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4729 rse.expr = build_fold_indirect_ref (rse.expr);
4732 gfc_conv_expr_val (&rse, expr);
4734 gfc_add_block_to_block (&block, &rse.pre);
4735 gfc_add_block_to_block (&block, &lse.pre);
4737 lse.string_length = rse.string_length;
4738 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4739 expr->expr_type == EXPR_VARIABLE);
4740 gfc_add_expr_to_block (&block, tmp);
4742 /* Finish the copying loops. */
4743 gfc_trans_scalarizing_loops (&loop, &block);
4745 desc = loop.temp_ss->data.info.descriptor;
4747 gcc_assert (is_gimple_lvalue (desc));
4749 else if (expr->expr_type == EXPR_FUNCTION)
4751 desc = info->descriptor;
4752 se->string_length = ss->string_length;
4756 /* We pass sections without copying to a temporary. Make a new
4757 descriptor and point it at the section we want. The loop variable
4758 limits will be the limits of the section.
4759 A function may decide to repack the array to speed up access, but
4760 we're not bothered about that here. */
4769 /* Set the string_length for a character array. */
4770 if (expr->ts.type == BT_CHARACTER)
4771 se->string_length = gfc_get_expr_charlen (expr);
4773 desc = info->descriptor;
4774 gcc_assert (secss && secss != gfc_ss_terminator);
4775 if (se->direct_byref)
4777 /* For pointer assignments we fill in the destination. */
4779 parmtype = TREE_TYPE (parm);
4783 /* Otherwise make a new one. */
4784 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4785 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4786 loop.from, loop.to, 0);
4787 parm = gfc_create_var (parmtype, "parm");
4790 offset = gfc_index_zero_node;
4793 /* The following can be somewhat confusing. We have two
4794 descriptors, a new one and the original array.
4795 {parm, parmtype, dim} refer to the new one.
4796 {desc, type, n, secss, loop} refer to the original, which maybe
4797 a descriptorless array.
4798 The bounds of the scalarization are the bounds of the section.
4799 We don't have to worry about numeric overflows when calculating
4800 the offsets because all elements are within the array data. */
4802 /* Set the dtype. */
4803 tmp = gfc_conv_descriptor_dtype (parm);
4804 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4806 /* Set offset for assignments to pointer only to zero if it is not
4808 if (se->direct_byref
4809 && info->ref && info->ref->u.ar.type != AR_FULL)
4810 base = gfc_index_zero_node;
4811 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4812 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4816 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4817 for (n = 0; n < ndim; n++)
4819 stride = gfc_conv_array_stride (desc, n);
4821 /* Work out the offset. */
4823 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4825 gcc_assert (info->subscript[n]
4826 && info->subscript[n]->type == GFC_SS_SCALAR);
4827 start = info->subscript[n]->data.scalar.expr;
4831 /* Check we haven't somehow got out of sync. */
4832 gcc_assert (info->dim[dim] == n);
4834 /* Evaluate and remember the start of the section. */
4835 start = info->start[dim];
4836 stride = gfc_evaluate_now (stride, &loop.pre);
4839 tmp = gfc_conv_array_lbound (desc, n);
4840 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4842 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4843 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4846 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4848 /* For elemental dimensions, we only need the offset. */
4852 /* Vector subscripts need copying and are handled elsewhere. */
4854 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4856 /* Set the new lower bound. */
4857 from = loop.from[dim];
4860 /* If we have an array section or are assigning make sure that
4861 the lower bound is 1. References to the full
4862 array should otherwise keep the original bounds. */
4864 || info->ref->u.ar.type != AR_FULL)
4865 && !integer_onep (from))
4867 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4868 gfc_index_one_node, from);
4869 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4870 from = gfc_index_one_node;
4872 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4873 gfc_add_modify_expr (&loop.pre, tmp, from);
4875 /* Set the new upper bound. */
4876 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4877 gfc_add_modify_expr (&loop.pre, tmp, to);
4879 /* Multiply the stride by the section stride to get the
4881 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4882 stride, info->stride[dim]);
4884 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
4886 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4889 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4891 tmp = gfc_conv_array_lbound (desc, n);
4892 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4893 tmp, loop.from[dim]);
4894 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
4895 tmp, gfc_conv_array_stride (desc, n));
4896 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
4900 /* Store the new stride. */
4901 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4902 gfc_add_modify_expr (&loop.pre, tmp, stride);
4907 if (se->data_not_needed)
4908 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4910 /* Point the data pointer at the first element in the section. */
4911 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
4912 subref_array_target, expr);
4914 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4915 && !se->data_not_needed)
4917 /* Set the offset. */
4918 tmp = gfc_conv_descriptor_offset (parm);
4919 gfc_add_modify_expr (&loop.pre, tmp, base);
4923 /* Only the callee knows what the correct offset it, so just set
4925 tmp = gfc_conv_descriptor_offset (parm);
4926 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4931 if (!se->direct_byref)
4933 /* Get a pointer to the new descriptor. */
4934 if (se->want_pointer)
4935 se->expr = build_fold_addr_expr (desc);
4940 gfc_add_block_to_block (&se->pre, &loop.pre);
4941 gfc_add_block_to_block (&se->post, &loop.post);
4943 /* Cleanup the scalarizer. */
4944 gfc_cleanup_loop (&loop);
4948 /* Convert an array for passing as an actual parameter. */
4949 /* TODO: Optimize passing g77 arrays. */
4952 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4956 tree tmp = NULL_TREE;
4958 tree parent = DECL_CONTEXT (current_function_decl);
4959 bool full_array_var, this_array_result;
4963 full_array_var = (expr->expr_type == EXPR_VARIABLE
4964 && expr->ref->u.ar.type == AR_FULL);
4965 sym = full_array_var ? expr->symtree->n.sym : NULL;
4967 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
4969 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
4970 expr->ts.cl->backend_decl = tmp;
4971 se->string_length = gfc_evaluate_now (tmp, &se->pre);
4974 /* Is this the result of the enclosing procedure? */
4975 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4976 if (this_array_result
4977 && (sym->backend_decl != current_function_decl)
4978 && (sym->backend_decl != parent))
4979 this_array_result = false;
4981 /* Passing address of the array if it is not pointer or assumed-shape. */
4982 if (full_array_var && g77 && !this_array_result)
4984 tmp = gfc_get_symbol_decl (sym);
4986 if (sym->ts.type == BT_CHARACTER)
4987 se->string_length = sym->ts.cl->backend_decl;
4988 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4989 && !sym->attr.allocatable)
4991 /* Some variables are declared directly, others are declared as
4992 pointers and allocated on the heap. */
4993 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4996 se->expr = build_fold_addr_expr (tmp);
4999 if (sym->attr.allocatable)
5001 if (sym->attr.dummy || sym->attr.result)
5003 gfc_conv_expr_descriptor (se, expr, ss);
5004 se->expr = gfc_conv_array_data (se->expr);
5007 se->expr = gfc_conv_array_data (tmp);
5012 if (this_array_result)
5014 /* Result of the enclosing function. */
5015 gfc_conv_expr_descriptor (se, expr, ss);
5016 se->expr = build_fold_addr_expr (se->expr);
5018 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5019 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5020 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5026 /* Every other type of array. */
5027 se->want_pointer = 1;
5028 gfc_conv_expr_descriptor (se, expr, ss);
5032 /* Deallocate the allocatable components of structures that are
5034 if (expr->ts.type == BT_DERIVED
5035 && expr->ts.derived->attr.alloc_comp
5036 && expr->expr_type != EXPR_VARIABLE)
5038 tmp = build_fold_indirect_ref (se->expr);
5039 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5040 gfc_add_expr_to_block (&se->post, tmp);
5046 /* Repack the array. */
5047 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5048 ptr = gfc_evaluate_now (ptr, &se->pre);
5051 gfc_start_block (&block);
5053 /* Copy the data back. */
5054 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5055 gfc_add_expr_to_block (&block, tmp);
5057 /* Free the temporary. */
5058 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5059 gfc_add_expr_to_block (&block, tmp);
5061 stmt = gfc_finish_block (&block);
5063 gfc_init_block (&block);
5064 /* Only if it was repacked. This code needs to be executed before the
5065 loop cleanup code. */
5066 tmp = build_fold_indirect_ref (desc);
5067 tmp = gfc_conv_array_data (tmp);
5068 tmp = build2 (NE_EXPR, boolean_type_node,
5069 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5070 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5072 gfc_add_expr_to_block (&block, tmp);
5073 gfc_add_block_to_block (&block, &se->post);
5075 gfc_init_block (&se->post);
5076 gfc_add_block_to_block (&se->post, &block);
5081 /* Generate code to deallocate an array, if it is allocated. */
5084 gfc_trans_dealloc_allocated (tree descriptor)
5090 gfc_start_block (&block);
5092 var = gfc_conv_descriptor_data_get (descriptor);
5095 /* Call array_deallocate with an int * present in the second argument.
5096 Although it is ignored here, it's presence ensures that arrays that
5097 are already deallocated are ignored. */
5098 tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
5099 gfc_add_expr_to_block (&block, tmp);
5101 /* Zero the data pointer. */
5102 tmp = build2 (MODIFY_EXPR, void_type_node,
5103 var, build_int_cst (TREE_TYPE (var), 0));
5104 gfc_add_expr_to_block (&block, tmp);
5106 return gfc_finish_block (&block);
5110 /* This helper function calculates the size in words of a full array. */
5113 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5118 idx = gfc_rank_cst[rank - 1];
5119 nelems = gfc_conv_descriptor_ubound (decl, idx);
5120 tmp = gfc_conv_descriptor_lbound (decl, idx);
5121 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5122 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
5123 tmp, gfc_index_one_node);
5124 tmp = gfc_evaluate_now (tmp, block);
5126 nelems = gfc_conv_descriptor_stride (decl, idx);
5127 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5128 return gfc_evaluate_now (tmp, block);
5132 /* Allocate dest to the same size as src, and copy src -> dest. */
5135 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5144 /* If the source is null, set the destination to null. */
5145 gfc_init_block (&block);
5146 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5147 null_data = gfc_finish_block (&block);
5149 gfc_init_block (&block);
5151 nelems = get_full_array_size (&block, src, rank);
5152 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5153 fold_convert (gfc_array_index_type,
5154 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5156 /* Allocate memory to the destination. */
5157 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5159 gfc_conv_descriptor_data_set (&block, dest, tmp);
5161 /* We know the temporary and the value will be the same length,
5162 so can use memcpy. */
5163 tmp = built_in_decls[BUILT_IN_MEMCPY];
5164 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5165 gfc_conv_descriptor_data_get (src), size);
5166 gfc_add_expr_to_block (&block, tmp);
5167 tmp = gfc_finish_block (&block);
5169 /* Null the destination if the source is null; otherwise do
5170 the allocate and copy. */
5171 null_cond = gfc_conv_descriptor_data_get (src);
5172 null_cond = convert (pvoid_type_node, null_cond);
5173 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5175 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5179 /* Recursively traverse an object of derived type, generating code to
5180 deallocate, nullify or copy allocatable components. This is the work horse
5181 function for the functions named in this enum. */
5183 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5186 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5187 tree dest, int rank, int purpose)
5191 stmtblock_t fnblock;
5192 stmtblock_t loopbody;
5202 tree null_cond = NULL_TREE;
5204 gfc_init_block (&fnblock);
5206 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5207 decl = build_fold_indirect_ref (decl);
5209 /* If this an array of derived types with allocatable components
5210 build a loop and recursively call this function. */
5211 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5212 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5214 tmp = gfc_conv_array_data (decl);
5215 var = build_fold_indirect_ref (tmp);
5217 /* Get the number of elements - 1 and set the counter. */
5218 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5220 /* Use the descriptor for an allocatable array. Since this
5221 is a full array reference, we only need the descriptor
5222 information from dimension = rank. */
5223 tmp = get_full_array_size (&fnblock, decl, rank);
5224 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
5225 tmp, gfc_index_one_node);
5227 null_cond = gfc_conv_descriptor_data_get (decl);
5228 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5229 build_int_cst (TREE_TYPE (null_cond), 0));
5233 /* Otherwise use the TYPE_DOMAIN information. */
5234 tmp = array_type_nelts (TREE_TYPE (decl));
5235 tmp = fold_convert (gfc_array_index_type, tmp);
5238 /* Remember that this is, in fact, the no. of elements - 1. */
5239 nelems = gfc_evaluate_now (tmp, &fnblock);
5240 index = gfc_create_var (gfc_array_index_type, "S");
5242 /* Build the body of the loop. */
5243 gfc_init_block (&loopbody);
5245 vref = gfc_build_array_ref (var, index, NULL);
5247 if (purpose == COPY_ALLOC_COMP)
5249 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5250 gfc_add_expr_to_block (&fnblock, tmp);
5252 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5253 dref = gfc_build_array_ref (tmp, index, NULL);
5254 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5257 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5259 gfc_add_expr_to_block (&loopbody, tmp);
5261 /* Build the loop and return. */
5262 gfc_init_loopinfo (&loop);
5264 loop.from[0] = gfc_index_zero_node;
5265 loop.loopvar[0] = index;
5266 loop.to[0] = nelems;
5267 gfc_trans_scalarizing_loops (&loop, &loopbody);
5268 gfc_add_block_to_block (&fnblock, &loop.pre);
5270 tmp = gfc_finish_block (&fnblock);
5271 if (null_cond != NULL_TREE)
5272 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5277 /* Otherwise, act on the components or recursively call self to
5278 act on a chain of components. */
5279 for (c = der_type->components; c; c = c->next)
5281 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5282 && c->ts.derived->attr.alloc_comp;
5283 cdecl = c->backend_decl;
5284 ctype = TREE_TYPE (cdecl);
5288 case DEALLOCATE_ALLOC_COMP:
5289 /* Do not deallocate the components of ultimate pointer
5291 if (cmp_has_alloc_comps && !c->pointer)
5293 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5294 rank = c->as ? c->as->rank : 0;
5295 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5297 gfc_add_expr_to_block (&fnblock, tmp);
5302 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5303 tmp = gfc_trans_dealloc_allocated (comp);
5304 gfc_add_expr_to_block (&fnblock, tmp);
5308 case NULLIFY_ALLOC_COMP:
5311 else if (c->allocatable)
5313 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5314 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5316 else if (cmp_has_alloc_comps)
5318 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5319 rank = c->as ? c->as->rank : 0;
5320 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5322 gfc_add_expr_to_block (&fnblock, tmp);
5326 case COPY_ALLOC_COMP:
5330 /* We need source and destination components. */
5331 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5332 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5333 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5335 if (c->allocatable && !cmp_has_alloc_comps)
5337 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5338 gfc_add_expr_to_block (&fnblock, tmp);
5341 if (cmp_has_alloc_comps)
5343 rank = c->as ? c->as->rank : 0;
5344 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5345 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5346 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5348 gfc_add_expr_to_block (&fnblock, tmp);
5358 return gfc_finish_block (&fnblock);
5361 /* Recursively traverse an object of derived type, generating code to
5362 nullify allocatable components. */
5365 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5367 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5368 NULLIFY_ALLOC_COMP);
5372 /* Recursively traverse an object of derived type, generating code to
5373 deallocate allocatable components. */
5376 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5378 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5379 DEALLOCATE_ALLOC_COMP);
5383 /* Recursively traverse an object of derived type, generating code to
5384 copy its allocatable components. */
5387 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5389 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5393 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5394 Do likewise, recursively if necessary, with the allocatable components of
5398 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5403 stmtblock_t fnblock;
5406 bool sym_has_alloc_comp;
5408 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5409 && sym->ts.derived->attr.alloc_comp;
5411 /* Make sure the frontend gets these right. */
5412 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5413 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5414 "allocatable attribute or derived type without allocatable "
5417 gfc_init_block (&fnblock);
5419 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5420 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5422 if (sym->ts.type == BT_CHARACTER
5423 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5425 gfc_conv_string_length (sym->ts.cl, &fnblock);
5426 gfc_trans_vla_type_sizes (sym, &fnblock);
5429 /* Dummy and use associated variables don't need anything special. */
5430 if (sym->attr.dummy || sym->attr.use_assoc)
5432 gfc_add_expr_to_block (&fnblock, body);
5434 return gfc_finish_block (&fnblock);
5437 gfc_get_backend_locus (&loc);
5438 gfc_set_backend_locus (&sym->declared_at);
5439 descriptor = sym->backend_decl;
5441 /* Although static, derived types with default initializers and
5442 allocatable components must not be nulled wholesale; instead they
5443 are treated component by component. */
5444 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5446 /* SAVEd variables are not freed on exit. */
5447 gfc_trans_static_array_pointer (sym);
5451 /* Get the descriptor type. */
5452 type = TREE_TYPE (sym->backend_decl);
5454 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5456 if (!sym->attr.save)
5458 rank = sym->as ? sym->as->rank : 0;
5459 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5460 gfc_add_expr_to_block (&fnblock, tmp);
5463 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5465 /* If the backend_decl is not a descriptor, we must have a pointer
5467 descriptor = build_fold_indirect_ref (sym->backend_decl);
5468 type = TREE_TYPE (descriptor);
5471 /* NULLIFY the data pointer. */
5472 if (GFC_DESCRIPTOR_TYPE_P (type))
5473 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5475 gfc_add_expr_to_block (&fnblock, body);
5477 gfc_set_backend_locus (&loc);
5479 /* Allocatable arrays need to be freed when they go out of scope.
5480 The allocatable components of pointers must not be touched. */
5481 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5482 && !sym->attr.pointer && !sym->attr.save)
5485 rank = sym->as ? sym->as->rank : 0;
5486 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5487 gfc_add_expr_to_block (&fnblock, tmp);
5490 if (sym->attr.allocatable)
5492 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5493 gfc_add_expr_to_block (&fnblock, tmp);
5496 return gfc_finish_block (&fnblock);
5499 /************ Expression Walking Functions ******************/
5501 /* Walk a variable reference.
5503 Possible extension - multiple component subscripts.
5504 x(:,:) = foo%a(:)%b(:)
5506 forall (i=..., j=...)
5507 x(i,j) = foo%a(j)%b(i)
5509 This adds a fair amount of complexity because you need to deal with more
5510 than one ref. Maybe handle in a similar manner to vector subscripts.
5511 Maybe not worth the effort. */
5515 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5523 for (ref = expr->ref; ref; ref = ref->next)
5524 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5527 for (; ref; ref = ref->next)
5529 if (ref->type == REF_SUBSTRING)
5531 newss = gfc_get_ss ();
5532 newss->type = GFC_SS_SCALAR;
5533 newss->expr = ref->u.ss.start;
5537 newss = gfc_get_ss ();
5538 newss->type = GFC_SS_SCALAR;
5539 newss->expr = ref->u.ss.end;
5544 /* We're only interested in array sections from now on. */
5545 if (ref->type != REF_ARRAY)
5552 for (n = 0; n < ar->dimen; n++)
5554 newss = gfc_get_ss ();
5555 newss->type = GFC_SS_SCALAR;
5556 newss->expr = ar->start[n];
5563 newss = gfc_get_ss ();
5564 newss->type = GFC_SS_SECTION;
5567 newss->data.info.dimen = ar->as->rank;
5568 newss->data.info.ref = ref;
5570 /* Make sure array is the same as array(:,:), this way
5571 we don't need to special case all the time. */
5572 ar->dimen = ar->as->rank;
5573 for (n = 0; n < ar->dimen; n++)
5575 newss->data.info.dim[n] = n;
5576 ar->dimen_type[n] = DIMEN_RANGE;
5578 gcc_assert (ar->start[n] == NULL);
5579 gcc_assert (ar->end[n] == NULL);
5580 gcc_assert (ar->stride[n] == NULL);
5586 newss = gfc_get_ss ();
5587 newss->type = GFC_SS_SECTION;
5590 newss->data.info.dimen = 0;
5591 newss->data.info.ref = ref;
5595 /* We add SS chains for all the subscripts in the section. */
5596 for (n = 0; n < ar->dimen; n++)
5600 switch (ar->dimen_type[n])
5603 /* Add SS for elemental (scalar) subscripts. */
5604 gcc_assert (ar->start[n]);
5605 indexss = gfc_get_ss ();
5606 indexss->type = GFC_SS_SCALAR;
5607 indexss->expr = ar->start[n];
5608 indexss->next = gfc_ss_terminator;
5609 indexss->loop_chain = gfc_ss_terminator;
5610 newss->data.info.subscript[n] = indexss;
5614 /* We don't add anything for sections, just remember this
5615 dimension for later. */
5616 newss->data.info.dim[newss->data.info.dimen] = n;
5617 newss->data.info.dimen++;
5621 /* Create a GFC_SS_VECTOR index in which we can store
5622 the vector's descriptor. */
5623 indexss = gfc_get_ss ();
5624 indexss->type = GFC_SS_VECTOR;
5625 indexss->expr = ar->start[n];
5626 indexss->next = gfc_ss_terminator;
5627 indexss->loop_chain = gfc_ss_terminator;
5628 newss->data.info.subscript[n] = indexss;
5629 newss->data.info.dim[newss->data.info.dimen] = n;
5630 newss->data.info.dimen++;
5634 /* We should know what sort of section it is by now. */
5638 /* We should have at least one non-elemental dimension. */
5639 gcc_assert (newss->data.info.dimen > 0);
5644 /* We should know what sort of section it is by now. */
5653 /* Walk an expression operator. If only one operand of a binary expression is
5654 scalar, we must also add the scalar term to the SS chain. */
5657 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5663 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5664 if (expr->value.op.op2 == NULL)
5667 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5669 /* All operands are scalar. Pass back and let the caller deal with it. */
5673 /* All operands require scalarization. */
5674 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5677 /* One of the operands needs scalarization, the other is scalar.
5678 Create a gfc_ss for the scalar expression. */
5679 newss = gfc_get_ss ();
5680 newss->type = GFC_SS_SCALAR;
5683 /* First operand is scalar. We build the chain in reverse order, so
5684 add the scarar SS after the second operand. */
5686 while (head && head->next != ss)
5688 /* Check we haven't somehow broken the chain. */
5692 newss->expr = expr->value.op.op1;
5694 else /* head2 == head */
5696 gcc_assert (head2 == head);
5697 /* Second operand is scalar. */
5698 newss->next = head2;
5700 newss->expr = expr->value.op.op2;
5707 /* Reverse a SS chain. */
5710 gfc_reverse_ss (gfc_ss * ss)
5715 gcc_assert (ss != NULL);
5717 head = gfc_ss_terminator;
5718 while (ss != gfc_ss_terminator)
5721 /* Check we didn't somehow break the chain. */
5722 gcc_assert (next != NULL);
5732 /* Walk the arguments of an elemental function. */
5735 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5743 head = gfc_ss_terminator;
5746 for (; arg; arg = arg->next)
5751 newss = gfc_walk_subexpr (head, arg->expr);
5754 /* Scalar argument. */
5755 newss = gfc_get_ss ();
5757 newss->expr = arg->expr;
5767 while (tail->next != gfc_ss_terminator)
5774 /* If all the arguments are scalar we don't need the argument SS. */
5775 gfc_free_ss_chain (head);
5780 /* Add it onto the existing chain. */
5786 /* Walk a function call. Scalar functions are passed back, and taken out of
5787 scalarization loops. For elemental functions we walk their arguments.
5788 The result of functions returning arrays is stored in a temporary outside
5789 the loop, so that the function is only called once. Hence we do not need
5790 to walk their arguments. */
5793 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5796 gfc_intrinsic_sym *isym;
5799 isym = expr->value.function.isym;
5801 /* Handle intrinsic functions separately. */
5803 return gfc_walk_intrinsic_function (ss, expr, isym);
5805 sym = expr->value.function.esym;
5807 sym = expr->symtree->n.sym;
5809 /* A function that returns arrays. */
5810 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5812 newss = gfc_get_ss ();
5813 newss->type = GFC_SS_FUNCTION;
5816 newss->data.info.dimen = expr->rank;
5820 /* Walk the parameters of an elemental function. For now we always pass
5822 if (sym->attr.elemental)
5823 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5826 /* Scalar functions are OK as these are evaluated outside the scalarization
5827 loop. Pass back and let the caller deal with it. */
5832 /* An array temporary is constructed for array constructors. */
5835 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5840 newss = gfc_get_ss ();
5841 newss->type = GFC_SS_CONSTRUCTOR;
5844 newss->data.info.dimen = expr->rank;
5845 for (n = 0; n < expr->rank; n++)
5846 newss->data.info.dim[n] = n;
5852 /* Walk an expression. Add walked expressions to the head of the SS chain.
5853 A wholly scalar expression will not be added. */
5856 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5860 switch (expr->expr_type)
5863 head = gfc_walk_variable_expr (ss, expr);
5867 head = gfc_walk_op_expr (ss, expr);
5871 head = gfc_walk_function_expr (ss, expr);
5876 case EXPR_STRUCTURE:
5877 /* Pass back and let the caller deal with it. */
5881 head = gfc_walk_array_constructor (ss, expr);
5884 case EXPR_SUBSTRING:
5885 /* Pass back and let the caller deal with it. */
5889 internal_error ("bad expression type during walk (%d)",
5896 /* Entry point for expression walking.
5897 A return value equal to the passed chain means this is
5898 a scalar expression. It is up to the caller to take whatever action is
5899 necessary to translate these. */
5902 gfc_walk_expr (gfc_expr * expr)
5906 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5907 return gfc_reverse_ss (res);