1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set_tuples. */
167 gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
168 tree desc, tree value,
173 type = TREE_TYPE (desc);
174 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
176 field = TYPE_FIELDS (type);
177 gcc_assert (DATA_FIELD == 0);
179 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
180 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc)
192 type = TREE_TYPE (desc);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
195 field = TYPE_FIELDS (type);
196 gcc_assert (DATA_FIELD == 0);
198 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
199 return build_fold_addr_expr (t);
203 gfc_conv_descriptor_offset (tree desc)
208 type = TREE_TYPE (desc);
209 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
211 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
212 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
214 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
218 gfc_conv_descriptor_dtype (tree desc)
223 type = TREE_TYPE (desc);
224 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
226 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
227 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
229 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
233 gfc_conv_descriptor_dimension (tree desc, tree dim)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
243 gcc_assert (field != NULL_TREE
244 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
247 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
248 tmp = gfc_build_array_ref (tmp, dim);
253 gfc_conv_descriptor_stride (tree desc, tree dim)
258 tmp = gfc_conv_descriptor_dimension (desc, dim);
259 field = TYPE_FIELDS (TREE_TYPE (tmp));
260 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
261 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
263 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
268 gfc_conv_descriptor_lbound (tree desc, tree dim)
273 tmp = gfc_conv_descriptor_dimension (desc, dim);
274 field = TYPE_FIELDS (TREE_TYPE (tmp));
275 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
276 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
278 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
283 gfc_conv_descriptor_ubound (tree desc, tree dim)
288 tmp = gfc_conv_descriptor_dimension (desc, dim);
289 field = TYPE_FIELDS (TREE_TYPE (tmp));
290 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
291 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
293 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
298 /* Build a null array descriptor constructor. */
301 gfc_build_null_descriptor (tree type)
306 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
307 gcc_assert (DATA_FIELD == 0);
308 field = TYPE_FIELDS (type);
310 /* Set a NULL data pointer. */
311 tmp = build_constructor_single (type, field, null_pointer_node);
312 TREE_CONSTANT (tmp) = 1;
313 TREE_INVARIANT (tmp) = 1;
314 /* All other fields are ignored. */
320 /* Cleanup those #defines. */
325 #undef DIMENSION_FIELD
326 #undef STRIDE_SUBFIELD
327 #undef LBOUND_SUBFIELD
328 #undef UBOUND_SUBFIELD
331 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
332 flags & 1 = Main loop body.
333 flags & 2 = temp copy loop. */
336 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
338 for (; ss != gfc_ss_terminator; ss = ss->next)
339 ss->useflags = flags;
342 static void gfc_free_ss (gfc_ss *);
345 /* Free a gfc_ss chain. */
348 gfc_free_ss_chain (gfc_ss * ss)
352 while (ss != gfc_ss_terminator)
354 gcc_assert (ss != NULL);
365 gfc_free_ss (gfc_ss * ss)
372 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
374 if (ss->data.info.subscript[n])
375 gfc_free_ss_chain (ss->data.info.subscript[n]);
387 /* Free all the SS associated with a loop. */
390 gfc_cleanup_loop (gfc_loopinfo * loop)
396 while (ss != gfc_ss_terminator)
398 gcc_assert (ss != NULL);
399 next = ss->loop_chain;
406 /* Associate a SS chain with a loop. */
409 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
413 if (head == gfc_ss_terminator)
417 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
419 if (ss->next == gfc_ss_terminator)
420 ss->loop_chain = loop->ss;
422 ss->loop_chain = ss->next;
424 gcc_assert (ss == gfc_ss_terminator);
429 /* Generate an initializer for a static pointer or allocatable array. */
432 gfc_trans_static_array_pointer (gfc_symbol * sym)
436 gcc_assert (TREE_STATIC (sym->backend_decl));
437 /* Just zero the data member. */
438 type = TREE_TYPE (sym->backend_decl);
439 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
443 /* If the bounds of SE's loop have not yet been set, see if they can be
444 determined from array spec AS, which is the array spec of a called
445 function. MAPPING maps the callee's dummy arguments to the values
446 that the caller is passing. Add any initialization and finalization
450 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
451 gfc_se * se, gfc_array_spec * as)
459 if (as && as->type == AS_EXPLICIT)
460 for (dim = 0; dim < se->loop->dimen; dim++)
462 n = se->loop->order[dim];
463 if (se->loop->to[n] == NULL_TREE)
465 /* Evaluate the lower bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* ...and the upper bound. */
473 gfc_init_se (&tmpse, NULL);
474 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
475 gfc_add_block_to_block (&se->pre, &tmpse.pre);
476 gfc_add_block_to_block (&se->post, &tmpse.post);
479 /* Set the upper bound of the loop to UPPER - LOWER. */
480 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
481 tmp = gfc_evaluate_now (tmp, &se->pre);
482 se->loop->to[n] = tmp;
488 /* Generate code to allocate an array temporary, or create a variable to
489 hold the data. If size is NULL, zero the descriptor so that the
490 callee will allocate the array. If DEALLOC is true, also generate code to
491 free the array afterwards.
493 Initialization code is added to PRE and finalization code to POST.
494 DYNAMIC is true if the caller may want to extend the array later
495 using realloc. This prevents us from putting the array on the stack. */
498 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
499 gfc_ss_info * info, tree size, tree nelem,
500 bool dynamic, bool dealloc)
506 desc = info->descriptor;
507 info->offset = gfc_index_zero_node;
508 if (size == NULL_TREE || integer_zerop (size))
510 /* A callee allocated array. */
511 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
516 /* Allocate the temporary. */
517 onstack = !dynamic && gfc_can_put_var_on_stack (size);
521 /* Make a temporary variable to hold the data. */
522 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
524 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
526 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
528 tmp = gfc_create_var (tmp, "A");
529 tmp = build_fold_addr_expr (tmp);
530 gfc_conv_descriptor_data_set (pre, desc, tmp);
534 /* Allocate memory to hold the data. */
535 tmp = gfc_call_malloc (pre, NULL, size);
536 tmp = gfc_evaluate_now (tmp, pre);
537 gfc_conv_descriptor_data_set (pre, desc, tmp);
540 info->data = gfc_conv_descriptor_data_get (desc);
542 /* The offset is zero because we create temporaries with a zero
544 tmp = gfc_conv_descriptor_offset (desc);
545 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
547 if (dealloc && !onstack)
549 /* Free the temporary. */
550 tmp = gfc_conv_descriptor_data_get (desc);
551 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
552 gfc_add_expr_to_block (post, tmp);
557 /* Generate code to create and initialize the descriptor for a temporary
558 array. This is used for both temporaries needed by the scalarizer, and
559 functions returning arrays. Adjusts the loop variables to be
560 zero-based, and calculates the loop bounds for callee allocated arrays.
561 Allocate the array unless it's callee allocated (we have a callee
562 allocated array if 'callee_alloc' is true, or if loop->to[n] is
563 NULL_TREE for any n). Also fills in the descriptor, data and offset
564 fields of info if known. Returns the size of the array, or NULL for a
565 callee allocated array.
567 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
571 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
572 gfc_loopinfo * loop, gfc_ss_info * info,
573 tree eltype, bool dynamic, bool dealloc,
586 gcc_assert (info->dimen > 0);
587 /* Set the lower bound to zero. */
588 for (dim = 0; dim < info->dimen; dim++)
590 n = loop->order[dim];
591 if (n < loop->temp_dim)
592 gcc_assert (integer_zerop (loop->from[n]));
595 /* Callee allocated arrays may not have a known bound yet. */
597 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
598 loop->to[n], loop->from[n]);
599 loop->from[n] = gfc_index_zero_node;
602 info->delta[dim] = gfc_index_zero_node;
603 info->start[dim] = gfc_index_zero_node;
604 info->end[dim] = gfc_index_zero_node;
605 info->stride[dim] = gfc_index_one_node;
606 info->dim[dim] = dim;
609 /* Initialize the descriptor. */
611 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
612 desc = gfc_create_var (type, "atmp");
613 GFC_DECL_PACKED_ARRAY (desc) = 1;
615 info->descriptor = desc;
616 size = gfc_index_one_node;
618 /* Fill in the array dtype. */
619 tmp = gfc_conv_descriptor_dtype (desc);
620 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
623 Fill in the bounds and stride. This is a packed array, so:
626 for (n = 0; n < rank; n++)
629 delta = ubound[n] + 1 - lbound[n];
632 size = size * sizeof(element);
637 for (n = 0; n < info->dimen; n++)
639 if (loop->to[n] == NULL_TREE)
641 /* For a callee allocated array express the loop bounds in terms
642 of the descriptor fields. */
643 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
644 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
645 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
651 /* Store the stride and bound components in the descriptor. */
652 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
653 gfc_add_modify_expr (pre, tmp, size);
655 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
656 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
658 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
659 gfc_add_modify_expr (pre, tmp, loop->to[n]);
661 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
662 loop->to[n], gfc_index_one_node);
664 /* Check whether the size for this dimension is negative. */
665 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
666 gfc_index_zero_node);
667 cond = gfc_evaluate_now (cond, pre);
672 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
674 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
675 size = gfc_evaluate_now (size, pre);
678 /* Get the size of the array. */
680 if (size && !callee_alloc)
682 /* If or_expr is true, then the extent in at least one
683 dimension is zero and the size is set to zero. */
684 size = fold_build3 (COND_EXPR, gfc_array_index_type,
685 or_expr, gfc_index_zero_node, size);
688 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
689 fold_convert (gfc_array_index_type,
690 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
698 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
701 if (info->dimen > loop->temp_dim)
702 loop->temp_dim = info->dimen;
708 /* Generate code to transpose array EXPR by creating a new descriptor
709 in which the dimension specifications have been reversed. */
712 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
714 tree dest, src, dest_index, src_index;
716 gfc_ss_info *dest_info, *src_info;
717 gfc_ss *dest_ss, *src_ss;
723 src_ss = gfc_walk_expr (expr);
726 src_info = &src_ss->data.info;
727 dest_info = &dest_ss->data.info;
728 gcc_assert (dest_info->dimen == 2);
729 gcc_assert (src_info->dimen == 2);
731 /* Get a descriptor for EXPR. */
732 gfc_init_se (&src_se, NULL);
733 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
734 gfc_add_block_to_block (&se->pre, &src_se.pre);
735 gfc_add_block_to_block (&se->post, &src_se.post);
738 /* Allocate a new descriptor for the return value. */
739 dest = gfc_create_var (TREE_TYPE (src), "atmp");
740 dest_info->descriptor = dest;
743 /* Copy across the dtype field. */
744 gfc_add_modify_expr (&se->pre,
745 gfc_conv_descriptor_dtype (dest),
746 gfc_conv_descriptor_dtype (src));
748 /* Copy the dimension information, renumbering dimension 1 to 0 and
750 for (n = 0; n < 2; n++)
752 dest_info->delta[n] = gfc_index_zero_node;
753 dest_info->start[n] = gfc_index_zero_node;
754 dest_info->end[n] = gfc_index_zero_node;
755 dest_info->stride[n] = gfc_index_one_node;
756 dest_info->dim[n] = n;
758 dest_index = gfc_rank_cst[n];
759 src_index = gfc_rank_cst[1 - n];
761 gfc_add_modify_expr (&se->pre,
762 gfc_conv_descriptor_stride (dest, dest_index),
763 gfc_conv_descriptor_stride (src, src_index));
765 gfc_add_modify_expr (&se->pre,
766 gfc_conv_descriptor_lbound (dest, dest_index),
767 gfc_conv_descriptor_lbound (src, src_index));
769 gfc_add_modify_expr (&se->pre,
770 gfc_conv_descriptor_ubound (dest, dest_index),
771 gfc_conv_descriptor_ubound (src, src_index));
775 gcc_assert (integer_zerop (loop->from[n]));
776 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
777 gfc_conv_descriptor_ubound (dest, dest_index),
778 gfc_conv_descriptor_lbound (dest, dest_index));
782 /* Copy the data pointer. */
783 dest_info->data = gfc_conv_descriptor_data_get (src);
784 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
786 /* Copy the offset. This is not changed by transposition: the top-left
787 element is still at the same offset as before. */
788 dest_info->offset = gfc_conv_descriptor_offset (src);
789 gfc_add_modify_expr (&se->pre,
790 gfc_conv_descriptor_offset (dest),
793 if (dest_info->dimen > loop->temp_dim)
794 loop->temp_dim = dest_info->dimen;
798 /* Return the number of iterations in a loop that starts at START,
799 ends at END, and has step STEP. */
802 gfc_get_iteration_count (tree start, tree end, tree step)
807 type = TREE_TYPE (step);
808 tmp = fold_build2 (MINUS_EXPR, type, end, start);
809 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
810 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
811 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
812 return fold_convert (gfc_array_index_type, tmp);
816 /* Extend the data in array DESC by EXTRA elements. */
819 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
826 if (integer_zerop (extra))
829 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
831 /* Add EXTRA to the upper bound. */
832 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
833 gfc_add_modify_expr (pblock, ubound, tmp);
835 /* Get the value of the current data pointer. */
836 arg0 = gfc_conv_descriptor_data_get (desc);
838 /* Calculate the new array size. */
839 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
840 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
841 arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
842 fold_convert (gfc_array_index_type, size));
844 /* Pick the realloc function. */
845 if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8)
846 tmp = gfor_fndecl_internal_realloc;
850 /* Set the new data pointer. */
851 tmp = build_call_expr (tmp, 2, arg0, arg1);
852 gfc_conv_descriptor_data_set (pblock, desc, tmp);
856 /* Return true if the bounds of iterator I can only be determined
860 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
862 return (i->start->expr_type != EXPR_CONSTANT
863 || i->end->expr_type != EXPR_CONSTANT
864 || i->step->expr_type != EXPR_CONSTANT);
868 /* Split the size of constructor element EXPR into the sum of two terms,
869 one of which can be determined at compile time and one of which must
870 be calculated at run time. Set *SIZE to the former and return true
871 if the latter might be nonzero. */
874 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
876 if (expr->expr_type == EXPR_ARRAY)
877 return gfc_get_array_constructor_size (size, expr->value.constructor);
878 else if (expr->rank > 0)
880 /* Calculate everything at run time. */
881 mpz_set_ui (*size, 0);
886 /* A single element. */
887 mpz_set_ui (*size, 1);
893 /* Like gfc_get_array_constructor_element_size, but applied to the whole
894 of array constructor C. */
897 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
904 mpz_set_ui (*size, 0);
909 for (; c; c = c->next)
912 if (i && gfc_iterator_has_dynamic_bounds (i))
916 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
919 /* Multiply the static part of the element size by the
920 number of iterations. */
921 mpz_sub (val, i->end->value.integer, i->start->value.integer);
922 mpz_fdiv_q (val, val, i->step->value.integer);
923 mpz_add_ui (val, val, 1);
924 if (mpz_sgn (val) > 0)
925 mpz_mul (len, len, val);
929 mpz_add (*size, *size, len);
938 /* Make sure offset is a variable. */
941 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
944 /* We should have already created the offset variable. We cannot
945 create it here because we may be in an inner scope. */
946 gcc_assert (*offsetvar != NULL_TREE);
947 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
948 *poffset = *offsetvar;
949 TREE_USED (*offsetvar) = 1;
953 /* Assign an element of an array constructor. */
956 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
957 tree offset, gfc_se * se, gfc_expr * expr)
961 gfc_conv_expr (se, expr);
963 /* Store the value. */
964 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
965 tmp = gfc_build_array_ref (tmp, offset);
966 if (expr->ts.type == BT_CHARACTER)
968 gfc_conv_string_parameter (se);
969 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
971 /* The temporary is an array of pointers. */
972 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
973 gfc_add_modify_expr (&se->pre, tmp, se->expr);
977 /* The temporary is an array of string values. */
978 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
979 /* We know the temporary and the value will be the same length,
980 so can use memcpy. */
981 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
982 tmp, se->expr, se->string_length);
983 gfc_add_expr_to_block (&se->pre, tmp);
988 /* TODO: Should the frontend already have done this conversion? */
989 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
990 gfc_add_modify_expr (&se->pre, tmp, se->expr);
993 gfc_add_block_to_block (pblock, &se->pre);
994 gfc_add_block_to_block (pblock, &se->post);
998 /* Add the contents of an array to the constructor. DYNAMIC is as for
999 gfc_trans_array_constructor_value. */
1002 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1003 tree type ATTRIBUTE_UNUSED,
1004 tree desc, gfc_expr * expr,
1005 tree * poffset, tree * offsetvar,
1016 /* We need this to be a variable so we can increment it. */
1017 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1019 gfc_init_se (&se, NULL);
1021 /* Walk the array expression. */
1022 ss = gfc_walk_expr (expr);
1023 gcc_assert (ss != gfc_ss_terminator);
1025 /* Initialize the scalarizer. */
1026 gfc_init_loopinfo (&loop);
1027 gfc_add_ss_to_loop (&loop, ss);
1029 /* Initialize the loop. */
1030 gfc_conv_ss_startstride (&loop);
1031 gfc_conv_loop_setup (&loop);
1033 /* Make sure the constructed array has room for the new data. */
1036 /* Set SIZE to the total number of elements in the subarray. */
1037 size = gfc_index_one_node;
1038 for (n = 0; n < loop.dimen; n++)
1040 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1041 gfc_index_one_node);
1042 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1045 /* Grow the constructed array by SIZE elements. */
1046 gfc_grow_array (&loop.pre, desc, size);
1049 /* Make the loop body. */
1050 gfc_mark_ss_chain_used (ss, 1);
1051 gfc_start_scalarized_body (&loop, &body);
1052 gfc_copy_loopinfo_to_se (&se, &loop);
1055 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1056 gcc_assert (se.ss == gfc_ss_terminator);
1058 /* Increment the offset. */
1059 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1060 gfc_add_modify_expr (&body, *poffset, tmp);
1062 /* Finish the loop. */
1063 gfc_trans_scalarizing_loops (&loop, &body);
1064 gfc_add_block_to_block (&loop.pre, &loop.post);
1065 tmp = gfc_finish_block (&loop.pre);
1066 gfc_add_expr_to_block (pblock, tmp);
1068 gfc_cleanup_loop (&loop);
1072 /* Assign the values to the elements of an array constructor. DYNAMIC
1073 is true if descriptor DESC only contains enough data for the static
1074 size calculated by gfc_get_array_constructor_size. When true, memory
1075 for the dynamic parts must be allocated using realloc. */
1078 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1079 tree desc, gfc_constructor * c,
1080 tree * poffset, tree * offsetvar,
1089 for (; c; c = c->next)
1091 /* If this is an iterator or an array, the offset must be a variable. */
1092 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1093 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1095 gfc_start_block (&body);
1097 if (c->expr->expr_type == EXPR_ARRAY)
1099 /* Array constructors can be nested. */
1100 gfc_trans_array_constructor_value (&body, type, desc,
1101 c->expr->value.constructor,
1102 poffset, offsetvar, dynamic);
1104 else if (c->expr->rank > 0)
1106 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1107 poffset, offsetvar, dynamic);
1111 /* This code really upsets the gimplifier so don't bother for now. */
1118 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1125 /* Scalar values. */
1126 gfc_init_se (&se, NULL);
1127 gfc_trans_array_ctor_element (&body, desc, *poffset,
1130 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1131 *poffset, gfc_index_one_node);
1135 /* Collect multiple scalar constants into a constructor. */
1143 /* Count the number of consecutive scalar constants. */
1144 while (p && !(p->iterator
1145 || p->expr->expr_type != EXPR_CONSTANT))
1147 gfc_init_se (&se, NULL);
1148 gfc_conv_constant (&se, p->expr);
1149 if (p->expr->ts.type == BT_CHARACTER
1150 && POINTER_TYPE_P (type))
1152 /* For constant character array constructors we build
1153 an array of pointers. */
1154 se.expr = gfc_build_addr_expr (pchar_type_node,
1158 list = tree_cons (NULL_TREE, se.expr, list);
1163 bound = build_int_cst (NULL_TREE, n - 1);
1164 /* Create an array type to hold them. */
1165 tmptype = build_range_type (gfc_array_index_type,
1166 gfc_index_zero_node, bound);
1167 tmptype = build_array_type (type, tmptype);
1169 init = build_constructor_from_list (tmptype, nreverse (list));
1170 TREE_CONSTANT (init) = 1;
1171 TREE_INVARIANT (init) = 1;
1172 TREE_STATIC (init) = 1;
1173 /* Create a static variable to hold the data. */
1174 tmp = gfc_create_var (tmptype, "data");
1175 TREE_STATIC (tmp) = 1;
1176 TREE_CONSTANT (tmp) = 1;
1177 TREE_INVARIANT (tmp) = 1;
1178 TREE_READONLY (tmp) = 1;
1179 DECL_INITIAL (tmp) = init;
1182 /* Use BUILTIN_MEMCPY to assign the values. */
1183 tmp = gfc_conv_descriptor_data_get (desc);
1184 tmp = build_fold_indirect_ref (tmp);
1185 tmp = gfc_build_array_ref (tmp, *poffset);
1186 tmp = build_fold_addr_expr (tmp);
1187 init = build_fold_addr_expr (init);
1189 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1190 bound = build_int_cst (NULL_TREE, n * size);
1191 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1193 gfc_add_expr_to_block (&body, tmp);
1195 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1197 build_int_cst (gfc_array_index_type, n));
1199 if (!INTEGER_CST_P (*poffset))
1201 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1202 *poffset = *offsetvar;
1206 /* The frontend should already have done any expansions possible
1210 /* Pass the code as is. */
1211 tmp = gfc_finish_block (&body);
1212 gfc_add_expr_to_block (pblock, tmp);
1216 /* Build the implied do-loop. */
1226 loopbody = gfc_finish_block (&body);
1228 gfc_init_se (&se, NULL);
1229 gfc_conv_expr (&se, c->iterator->var);
1230 gfc_add_block_to_block (pblock, &se.pre);
1233 /* Make a temporary, store the current value in that
1234 and return it, once the loop is done. */
1235 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1236 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1238 /* Initialize the loop. */
1239 gfc_init_se (&se, NULL);
1240 gfc_conv_expr_val (&se, c->iterator->start);
1241 gfc_add_block_to_block (pblock, &se.pre);
1242 gfc_add_modify_expr (pblock, loopvar, se.expr);
1244 gfc_init_se (&se, NULL);
1245 gfc_conv_expr_val (&se, c->iterator->end);
1246 gfc_add_block_to_block (pblock, &se.pre);
1247 end = gfc_evaluate_now (se.expr, pblock);
1249 gfc_init_se (&se, NULL);
1250 gfc_conv_expr_val (&se, c->iterator->step);
1251 gfc_add_block_to_block (pblock, &se.pre);
1252 step = gfc_evaluate_now (se.expr, pblock);
1254 /* If this array expands dynamically, and the number of iterations
1255 is not constant, we won't have allocated space for the static
1256 part of C->EXPR's size. Do that now. */
1257 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1259 /* Get the number of iterations. */
1260 tmp = gfc_get_iteration_count (loopvar, end, step);
1262 /* Get the static part of C->EXPR's size. */
1263 gfc_get_array_constructor_element_size (&size, c->expr);
1264 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1266 /* Grow the array by TMP * TMP2 elements. */
1267 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1268 gfc_grow_array (pblock, desc, tmp);
1271 /* Generate the loop body. */
1272 exit_label = gfc_build_label_decl (NULL_TREE);
1273 gfc_start_block (&body);
1275 /* Generate the exit condition. Depending on the sign of
1276 the step variable we have to generate the correct
1278 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1279 build_int_cst (TREE_TYPE (step), 0));
1280 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1281 build2 (GT_EXPR, boolean_type_node,
1283 build2 (LT_EXPR, boolean_type_node,
1285 tmp = build1_v (GOTO_EXPR, exit_label);
1286 TREE_USED (exit_label) = 1;
1287 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1288 gfc_add_expr_to_block (&body, tmp);
1290 /* The main loop body. */
1291 gfc_add_expr_to_block (&body, loopbody);
1293 /* Increase loop variable by step. */
1294 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1295 gfc_add_modify_expr (&body, loopvar, tmp);
1297 /* Finish the loop. */
1298 tmp = gfc_finish_block (&body);
1299 tmp = build1_v (LOOP_EXPR, tmp);
1300 gfc_add_expr_to_block (pblock, tmp);
1302 /* Add the exit label. */
1303 tmp = build1_v (LABEL_EXPR, exit_label);
1304 gfc_add_expr_to_block (pblock, tmp);
1306 /* Restore the original value of the loop counter. */
1307 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1314 /* Figure out the string length of a variable reference expression.
1315 Used by get_array_ctor_strlen. */
1318 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1324 /* Don't bother if we already know the length is a constant. */
1325 if (*len && INTEGER_CST_P (*len))
1328 ts = &expr->symtree->n.sym->ts;
1329 for (ref = expr->ref; ref; ref = ref->next)
1334 /* Array references don't change the string length. */
1338 /* Use the length of the component. */
1339 ts = &ref->u.c.component->ts;
1343 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1344 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1346 mpz_init_set_ui (char_len, 1);
1347 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1348 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1349 *len = gfc_conv_mpz_to_tree (char_len,
1350 gfc_default_character_kind);
1351 *len = convert (gfc_charlen_type_node, *len);
1352 mpz_clear (char_len);
1356 /* TODO: Substrings are tricky because we can't evaluate the
1357 expression more than once. For now we just give up, and hope
1358 we can figure it out elsewhere. */
1363 *len = ts->cl->backend_decl;
1367 /* A catch-all to obtain the string length for anything that is not a
1368 constant, array or variable. */
1370 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1375 /* Don't bother if we already know the length is a constant. */
1376 if (*len && INTEGER_CST_P (*len))
1379 if (!e->ref && e->ts.cl->length
1380 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1383 gfc_conv_const_charlen (e->ts.cl);
1384 *len = e->ts.cl->backend_decl;
1388 /* Otherwise, be brutal even if inefficient. */
1389 ss = gfc_walk_expr (e);
1390 gfc_init_se (&se, NULL);
1392 /* No function call, in case of side effects. */
1393 se.no_function_call = 1;
1394 if (ss == gfc_ss_terminator)
1395 gfc_conv_expr (&se, e);
1397 gfc_conv_expr_descriptor (&se, e, ss);
1399 /* Fix the value. */
1400 *len = gfc_evaluate_now (se.string_length, &se.pre);
1402 gfc_add_block_to_block (block, &se.pre);
1403 gfc_add_block_to_block (block, &se.post);
1405 e->ts.cl->backend_decl = *len;
1410 /* Figure out the string length of a character array constructor.
1411 Returns TRUE if all elements are character constants. */
1414 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1419 for (; c; c = c->next)
1421 switch (c->expr->expr_type)
1424 if (!(*len && INTEGER_CST_P (*len)))
1425 *len = build_int_cstu (gfc_charlen_type_node,
1426 c->expr->value.character.length);
1430 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1436 get_array_ctor_var_strlen (c->expr, len);
1441 get_array_ctor_all_strlen (block, c->expr, len);
1449 /* Check whether the array constructor C consists entirely of constant
1450 elements, and if so returns the number of those elements, otherwise
1451 return zero. Note, an empty or NULL array constructor returns zero. */
1453 unsigned HOST_WIDE_INT
1454 gfc_constant_array_constructor_p (gfc_constructor * c)
1456 unsigned HOST_WIDE_INT nelem = 0;
1461 || c->expr->rank > 0
1462 || c->expr->expr_type != EXPR_CONSTANT)
1471 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1472 and the tree type of it's elements, TYPE, return a static constant
1473 variable that is compile-time initialized. */
1476 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1478 tree tmptype, list, init, tmp;
1479 HOST_WIDE_INT nelem;
1485 /* First traverse the constructor list, converting the constants
1486 to tree to build an initializer. */
1489 c = expr->value.constructor;
1492 gfc_init_se (&se, NULL);
1493 gfc_conv_constant (&se, c->expr);
1494 if (c->expr->ts.type == BT_CHARACTER
1495 && POINTER_TYPE_P (type))
1496 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1497 list = tree_cons (NULL_TREE, se.expr, list);
1502 /* Next determine the tree type for the array. We use the gfortran
1503 front-end's gfc_get_nodesc_array_type in order to create a suitable
1504 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1506 memset (&as, 0, sizeof (gfc_array_spec));
1508 as.rank = expr->rank;
1509 as.type = AS_EXPLICIT;
1512 as.lower[0] = gfc_int_expr (0);
1513 as.upper[0] = gfc_int_expr (nelem - 1);
1516 for (i = 0; i < expr->rank; i++)
1518 int tmp = (int) mpz_get_si (expr->shape[i]);
1519 as.lower[i] = gfc_int_expr (0);
1520 as.upper[i] = gfc_int_expr (tmp - 1);
1523 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1525 init = build_constructor_from_list (tmptype, nreverse (list));
1527 TREE_CONSTANT (init) = 1;
1528 TREE_INVARIANT (init) = 1;
1529 TREE_STATIC (init) = 1;
1531 tmp = gfc_create_var (tmptype, "A");
1532 TREE_STATIC (tmp) = 1;
1533 TREE_CONSTANT (tmp) = 1;
1534 TREE_INVARIANT (tmp) = 1;
1535 TREE_READONLY (tmp) = 1;
1536 DECL_INITIAL (tmp) = init;
1542 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1543 This mostly initializes the scalarizer state info structure with the
1544 appropriate values to directly use the array created by the function
1545 gfc_build_constant_array_constructor. */
1548 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1549 gfc_ss * ss, tree type)
1555 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1557 info = &ss->data.info;
1559 info->descriptor = tmp;
1560 info->data = build_fold_addr_expr (tmp);
1561 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1564 for (i = 0; i < info->dimen; i++)
1566 info->delta[i] = gfc_index_zero_node;
1567 info->start[i] = gfc_index_zero_node;
1568 info->end[i] = gfc_index_zero_node;
1569 info->stride[i] = gfc_index_one_node;
1573 if (info->dimen > loop->temp_dim)
1574 loop->temp_dim = info->dimen;
1577 /* Helper routine of gfc_trans_array_constructor to determine if the
1578 bounds of the loop specified by LOOP are constant and simple enough
1579 to use with gfc_trans_constant_array_constructor. Returns the
1580 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1583 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1585 tree size = gfc_index_one_node;
1589 for (i = 0; i < loop->dimen; i++)
1591 /* If the bounds aren't constant, return NULL_TREE. */
1592 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1594 if (!integer_zerop (loop->from[i]))
1596 /* Only allow nonzero "from" in one-dimensional arrays. */
1597 if (loop->dimen != 1)
1599 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1600 loop->to[i], loop->from[i]);
1604 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1605 tmp, gfc_index_one_node);
1606 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1613 /* Array constructors are handled by constructing a temporary, then using that
1614 within the scalarization loop. This is not optimal, but seems by far the
1618 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1627 ss->data.info.dimen = loop->dimen;
1629 c = ss->expr->value.constructor;
1630 if (ss->expr->ts.type == BT_CHARACTER)
1632 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1633 if (!ss->string_length)
1634 gfc_todo_error ("complex character array constructors");
1636 /* It is surprising but still possible to wind up with expressions that
1637 lack a character length.
1638 TODO Find the offending part of the front end and cure this properly.
1639 Concatenation involving arrays is the main culprit. */
1640 if (!ss->expr->ts.cl)
1642 ss->expr->ts.cl = gfc_get_charlen ();
1643 ss->expr->ts.cl->next = gfc_current_ns->cl_list;
1644 gfc_current_ns->cl_list = ss->expr->ts.cl->next;
1647 ss->expr->ts.cl->backend_decl = ss->string_length;
1649 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1651 type = build_pointer_type (type);
1654 type = gfc_typenode_for_spec (&ss->expr->ts);
1656 /* See if the constructor determines the loop bounds. */
1659 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1661 /* We have a multidimensional parameter. */
1663 for (n = 0; n < ss->expr->rank; n++)
1665 loop->from[n] = gfc_index_zero_node;
1666 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1667 gfc_index_integer_kind);
1668 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1669 loop->to[n], gfc_index_one_node);
1673 if (loop->to[0] == NULL_TREE)
1677 /* We should have a 1-dimensional, zero-based loop. */
1678 gcc_assert (loop->dimen == 1);
1679 gcc_assert (integer_zerop (loop->from[0]));
1681 /* Split the constructor size into a static part and a dynamic part.
1682 Allocate the static size up-front and record whether the dynamic
1683 size might be nonzero. */
1685 dynamic = gfc_get_array_constructor_size (&size, c);
1686 mpz_sub_ui (size, size, 1);
1687 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1691 /* Special case constant array constructors. */
1694 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1697 tree size = constant_array_constructor_loop_size (loop);
1698 if (size && compare_tree_int (size, nelem) == 0)
1700 gfc_trans_constant_array_constructor (loop, ss, type);
1706 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1707 type, dynamic, true, false);
1709 desc = ss->data.info.descriptor;
1710 offset = gfc_index_zero_node;
1711 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1712 TREE_NO_WARNING (offsetvar) = 1;
1713 TREE_USED (offsetvar) = 0;
1714 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1715 &offset, &offsetvar, dynamic);
1717 /* If the array grows dynamically, the upper bound of the loop variable
1718 is determined by the array's final upper bound. */
1720 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1722 if (TREE_USED (offsetvar))
1723 pushdecl (offsetvar);
1725 gcc_assert (INTEGER_CST_P (offset));
1727 /* Disable bound checking for now because it's probably broken. */
1728 if (flag_bounds_check)
1736 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1737 called after evaluating all of INFO's vector dimensions. Go through
1738 each such vector dimension and see if we can now fill in any missing
1742 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1751 for (n = 0; n < loop->dimen; n++)
1754 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1755 && loop->to[n] == NULL)
1757 /* Loop variable N indexes vector dimension DIM, and we don't
1758 yet know the upper bound of loop variable N. Set it to the
1759 difference between the vector's upper and lower bounds. */
1760 gcc_assert (loop->from[n] == gfc_index_zero_node);
1761 gcc_assert (info->subscript[dim]
1762 && info->subscript[dim]->type == GFC_SS_VECTOR);
1764 gfc_init_se (&se, NULL);
1765 desc = info->subscript[dim]->data.info.descriptor;
1766 zero = gfc_rank_cst[0];
1767 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1768 gfc_conv_descriptor_ubound (desc, zero),
1769 gfc_conv_descriptor_lbound (desc, zero));
1770 tmp = gfc_evaluate_now (tmp, &loop->pre);
1777 /* Add the pre and post chains for all the scalar expressions in a SS chain
1778 to loop. This is called after the loop parameters have been calculated,
1779 but before the actual scalarizing loops. */
1782 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1787 /* TODO: This can generate bad code if there are ordering dependencies.
1788 eg. a callee allocated function and an unknown size constructor. */
1789 gcc_assert (ss != NULL);
1791 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1798 /* Scalar expression. Evaluate this now. This includes elemental
1799 dimension indices, but not array section bounds. */
1800 gfc_init_se (&se, NULL);
1801 gfc_conv_expr (&se, ss->expr);
1802 gfc_add_block_to_block (&loop->pre, &se.pre);
1804 if (ss->expr->ts.type != BT_CHARACTER)
1806 /* Move the evaluation of scalar expressions outside the
1807 scalarization loop. */
1809 se.expr = convert(gfc_array_index_type, se.expr);
1810 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1811 gfc_add_block_to_block (&loop->pre, &se.post);
1814 gfc_add_block_to_block (&loop->post, &se.post);
1816 ss->data.scalar.expr = se.expr;
1817 ss->string_length = se.string_length;
1820 case GFC_SS_REFERENCE:
1821 /* Scalar reference. Evaluate this now. */
1822 gfc_init_se (&se, NULL);
1823 gfc_conv_expr_reference (&se, ss->expr);
1824 gfc_add_block_to_block (&loop->pre, &se.pre);
1825 gfc_add_block_to_block (&loop->post, &se.post);
1827 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1828 ss->string_length = se.string_length;
1831 case GFC_SS_SECTION:
1832 /* Add the expressions for scalar and vector subscripts. */
1833 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1834 if (ss->data.info.subscript[n])
1835 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1837 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1841 /* Get the vector's descriptor and store it in SS. */
1842 gfc_init_se (&se, NULL);
1843 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1844 gfc_add_block_to_block (&loop->pre, &se.pre);
1845 gfc_add_block_to_block (&loop->post, &se.post);
1846 ss->data.info.descriptor = se.expr;
1849 case GFC_SS_INTRINSIC:
1850 gfc_add_intrinsic_ss_code (loop, ss);
1853 case GFC_SS_FUNCTION:
1854 /* Array function return value. We call the function and save its
1855 result in a temporary for use inside the loop. */
1856 gfc_init_se (&se, NULL);
1859 gfc_conv_expr (&se, ss->expr);
1860 gfc_add_block_to_block (&loop->pre, &se.pre);
1861 gfc_add_block_to_block (&loop->post, &se.post);
1862 ss->string_length = se.string_length;
1865 case GFC_SS_CONSTRUCTOR:
1866 gfc_trans_array_constructor (loop, ss);
1870 case GFC_SS_COMPONENT:
1871 /* Do nothing. These are handled elsewhere. */
1881 /* Translate expressions for the descriptor and data pointer of a SS. */
1885 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1890 /* Get the descriptor for the array to be scalarized. */
1891 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1892 gfc_init_se (&se, NULL);
1893 se.descriptor_only = 1;
1894 gfc_conv_expr_lhs (&se, ss->expr);
1895 gfc_add_block_to_block (block, &se.pre);
1896 ss->data.info.descriptor = se.expr;
1897 ss->string_length = se.string_length;
1901 /* Also the data pointer. */
1902 tmp = gfc_conv_array_data (se.expr);
1903 /* If this is a variable or address of a variable we use it directly.
1904 Otherwise we must evaluate it now to avoid breaking dependency
1905 analysis by pulling the expressions for elemental array indices
1908 || (TREE_CODE (tmp) == ADDR_EXPR
1909 && DECL_P (TREE_OPERAND (tmp, 0)))))
1910 tmp = gfc_evaluate_now (tmp, block);
1911 ss->data.info.data = tmp;
1913 tmp = gfc_conv_array_offset (se.expr);
1914 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1919 /* Initialize a gfc_loopinfo structure. */
1922 gfc_init_loopinfo (gfc_loopinfo * loop)
1926 memset (loop, 0, sizeof (gfc_loopinfo));
1927 gfc_init_block (&loop->pre);
1928 gfc_init_block (&loop->post);
1930 /* Initially scalarize in order. */
1931 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1934 loop->ss = gfc_ss_terminator;
1938 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1942 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1948 /* Return an expression for the data pointer of an array. */
1951 gfc_conv_array_data (tree descriptor)
1955 type = TREE_TYPE (descriptor);
1956 if (GFC_ARRAY_TYPE_P (type))
1958 if (TREE_CODE (type) == POINTER_TYPE)
1962 /* Descriptorless arrays. */
1963 return build_fold_addr_expr (descriptor);
1967 return gfc_conv_descriptor_data_get (descriptor);
1971 /* Return an expression for the base offset of an array. */
1974 gfc_conv_array_offset (tree descriptor)
1978 type = TREE_TYPE (descriptor);
1979 if (GFC_ARRAY_TYPE_P (type))
1980 return GFC_TYPE_ARRAY_OFFSET (type);
1982 return gfc_conv_descriptor_offset (descriptor);
1986 /* Get an expression for the array stride. */
1989 gfc_conv_array_stride (tree descriptor, int dim)
1994 type = TREE_TYPE (descriptor);
1996 /* For descriptorless arrays use the array size. */
1997 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1998 if (tmp != NULL_TREE)
2001 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2006 /* Like gfc_conv_array_stride, but for the lower bound. */
2009 gfc_conv_array_lbound (tree descriptor, int dim)
2014 type = TREE_TYPE (descriptor);
2016 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2017 if (tmp != NULL_TREE)
2020 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2025 /* Like gfc_conv_array_stride, but for the upper bound. */
2028 gfc_conv_array_ubound (tree descriptor, int dim)
2033 type = TREE_TYPE (descriptor);
2035 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2036 if (tmp != NULL_TREE)
2039 /* This should only ever happen when passing an assumed shape array
2040 as an actual parameter. The value will never be used. */
2041 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2042 return gfc_index_zero_node;
2044 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2049 /* Generate code to perform an array index bound check. */
2052 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2053 locus * where, bool check_upper)
2058 const char * name = NULL;
2060 if (!flag_bounds_check)
2063 index = gfc_evaluate_now (index, &se->pre);
2065 /* We find a name for the error message. */
2067 name = se->ss->expr->symtree->name;
2069 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2070 && se->loop->ss->expr->symtree)
2071 name = se->loop->ss->expr->symtree->name;
2073 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2074 && se->loop->ss->loop_chain->expr
2075 && se->loop->ss->loop_chain->expr->symtree)
2076 name = se->loop->ss->loop_chain->expr->symtree->name;
2078 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2079 && se->loop->ss->loop_chain->expr->symtree)
2080 name = se->loop->ss->loop_chain->expr->symtree->name;
2082 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2084 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2085 && se->loop->ss->expr->value.function.name)
2086 name = se->loop->ss->expr->value.function.name;
2088 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2089 || se->loop->ss->type == GFC_SS_SCALAR)
2090 name = "unnamed constant";
2093 /* Check lower bound. */
2094 tmp = gfc_conv_array_lbound (descriptor, n);
2095 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2097 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2098 gfc_msg_fault, name, n+1);
2100 asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
2101 "smaller than %%ld", gfc_msg_fault, n+1);
2102 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2103 fold_convert (long_integer_type_node, index),
2104 fold_convert (long_integer_type_node, tmp));
2107 /* Check upper bound. */
2110 tmp = gfc_conv_array_ubound (descriptor, n);
2111 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2113 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2114 " exceeded", gfc_msg_fault, name, n+1);
2116 asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
2117 "larger than %%ld", gfc_msg_fault, n+1);
2118 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2119 fold_convert (long_integer_type_node, index),
2120 fold_convert (long_integer_type_node, tmp));
2128 /* Return the offset for an index. Performs bound checking for elemental
2129 dimensions. Single element references are processed separately. */
2132 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2133 gfc_array_ref * ar, tree stride)
2139 /* Get the index into the array for this dimension. */
2142 gcc_assert (ar->type != AR_ELEMENT);
2143 switch (ar->dimen_type[dim])
2146 gcc_assert (i == -1);
2147 /* Elemental dimension. */
2148 gcc_assert (info->subscript[dim]
2149 && info->subscript[dim]->type == GFC_SS_SCALAR);
2150 /* We've already translated this value outside the loop. */
2151 index = info->subscript[dim]->data.scalar.expr;
2153 index = gfc_trans_array_bound_check (se, info->descriptor,
2154 index, dim, &ar->where,
2155 (ar->as->type != AS_ASSUMED_SIZE
2156 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2160 gcc_assert (info && se->loop);
2161 gcc_assert (info->subscript[dim]
2162 && info->subscript[dim]->type == GFC_SS_VECTOR);
2163 desc = info->subscript[dim]->data.info.descriptor;
2165 /* Get a zero-based index into the vector. */
2166 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2167 se->loop->loopvar[i], se->loop->from[i]);
2169 /* Multiply the index by the stride. */
2170 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2171 index, gfc_conv_array_stride (desc, 0));
2173 /* Read the vector to get an index into info->descriptor. */
2174 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2175 index = gfc_build_array_ref (data, index);
2176 index = gfc_evaluate_now (index, &se->pre);
2178 /* Do any bounds checking on the final info->descriptor index. */
2179 index = gfc_trans_array_bound_check (se, info->descriptor,
2180 index, dim, &ar->where,
2181 (ar->as->type != AS_ASSUMED_SIZE
2182 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2186 /* Scalarized dimension. */
2187 gcc_assert (info && se->loop);
2189 /* Multiply the loop variable by the stride and delta. */
2190 index = se->loop->loopvar[i];
2191 if (!integer_onep (info->stride[i]))
2192 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2194 if (!integer_zerop (info->delta[i]))
2195 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2205 /* Temporary array or derived type component. */
2206 gcc_assert (se->loop);
2207 index = se->loop->loopvar[se->loop->order[i]];
2208 if (!integer_zerop (info->delta[i]))
2209 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2210 index, info->delta[i]);
2213 /* Multiply by the stride. */
2214 if (!integer_onep (stride))
2215 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2221 /* Build a scalarized reference to an array. */
2224 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2231 info = &se->ss->data.info;
2233 n = se->loop->order[0];
2237 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2239 /* Add the offset for this dimension to the stored offset for all other
2241 if (!integer_zerop (info->offset))
2242 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2244 tmp = build_fold_indirect_ref (info->data);
2245 se->expr = gfc_build_array_ref (tmp, index);
2249 /* Translate access of temporary array. */
2252 gfc_conv_tmp_array_ref (gfc_se * se)
2254 se->string_length = se->ss->string_length;
2255 gfc_conv_scalarized_array_ref (se, NULL);
2259 /* Build an array reference. se->expr already holds the array descriptor.
2260 This should be either a variable, indirect variable reference or component
2261 reference. For arrays which do not have a descriptor, se->expr will be
2263 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2266 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2275 /* Handle scalarized references separately. */
2276 if (ar->type != AR_ELEMENT)
2278 gfc_conv_scalarized_array_ref (se, ar);
2279 gfc_advance_se_ss_chain (se);
2283 index = gfc_index_zero_node;
2285 /* Calculate the offsets from all the dimensions. */
2286 for (n = 0; n < ar->dimen; n++)
2288 /* Calculate the index for this dimension. */
2289 gfc_init_se (&indexse, se);
2290 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2291 gfc_add_block_to_block (&se->pre, &indexse.pre);
2293 if (flag_bounds_check)
2295 /* Check array bounds. */
2299 /* Evaluate the indexse.expr only once. */
2300 indexse.expr = save_expr (indexse.expr);
2303 tmp = gfc_conv_array_lbound (se->expr, n);
2304 cond = fold_build2 (LT_EXPR, boolean_type_node,
2306 asprintf (&msg, "%s for array '%s', "
2307 "lower bound of dimension %d exceeded, %%ld is smaller "
2308 "than %%ld", gfc_msg_fault, sym->name, n+1);
2309 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2310 fold_convert (long_integer_type_node,
2312 fold_convert (long_integer_type_node, tmp));
2315 /* Upper bound, but not for the last dimension of assumed-size
2317 if (n < ar->dimen - 1
2318 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2320 tmp = gfc_conv_array_ubound (se->expr, n);
2321 cond = fold_build2 (GT_EXPR, boolean_type_node,
2323 asprintf (&msg, "%s for array '%s', "
2324 "upper bound of dimension %d exceeded, %%ld is "
2325 "greater than %%ld", gfc_msg_fault, sym->name, n+1);
2326 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2327 fold_convert (long_integer_type_node,
2329 fold_convert (long_integer_type_node, tmp));
2334 /* Multiply the index by the stride. */
2335 stride = gfc_conv_array_stride (se->expr, n);
2336 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2339 /* And add it to the total. */
2340 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2343 tmp = gfc_conv_array_offset (se->expr);
2344 if (!integer_zerop (tmp))
2345 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2347 /* Access the calculated element. */
2348 tmp = gfc_conv_array_data (se->expr);
2349 tmp = build_fold_indirect_ref (tmp);
2350 se->expr = gfc_build_array_ref (tmp, index);
2354 /* Generate the code to be executed immediately before entering a
2355 scalarization loop. */
2358 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2359 stmtblock_t * pblock)
2368 /* This code will be executed before entering the scalarization loop
2369 for this dimension. */
2370 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2372 if ((ss->useflags & flag) == 0)
2375 if (ss->type != GFC_SS_SECTION
2376 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2377 && ss->type != GFC_SS_COMPONENT)
2380 info = &ss->data.info;
2382 if (dim >= info->dimen)
2385 if (dim == info->dimen - 1)
2387 /* For the outermost loop calculate the offset due to any
2388 elemental dimensions. It will have been initialized with the
2389 base offset of the array. */
2392 for (i = 0; i < info->ref->u.ar.dimen; i++)
2394 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2397 gfc_init_se (&se, NULL);
2399 se.expr = info->descriptor;
2400 stride = gfc_conv_array_stride (info->descriptor, i);
2401 index = gfc_conv_array_index_offset (&se, info, i, -1,
2404 gfc_add_block_to_block (pblock, &se.pre);
2406 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2407 info->offset, index);
2408 info->offset = gfc_evaluate_now (info->offset, pblock);
2412 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2415 stride = gfc_conv_array_stride (info->descriptor, 0);
2417 /* Calculate the stride of the innermost loop. Hopefully this will
2418 allow the backend optimizers to do their stuff more effectively.
2420 info->stride0 = gfc_evaluate_now (stride, pblock);
2424 /* Add the offset for the previous loop dimension. */
2429 ar = &info->ref->u.ar;
2430 i = loop->order[dim + 1];
2438 gfc_init_se (&se, NULL);
2440 se.expr = info->descriptor;
2441 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2442 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2444 gfc_add_block_to_block (pblock, &se.pre);
2445 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2446 info->offset, index);
2447 info->offset = gfc_evaluate_now (info->offset, pblock);
2450 /* Remember this offset for the second loop. */
2451 if (dim == loop->temp_dim - 1)
2452 info->saved_offset = info->offset;
2457 /* Start a scalarized expression. Creates a scope and declares loop
2461 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2467 gcc_assert (!loop->array_parameter);
2469 for (dim = loop->dimen - 1; dim >= 0; dim--)
2471 n = loop->order[dim];
2473 gfc_start_block (&loop->code[n]);
2475 /* Create the loop variable. */
2476 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2478 if (dim < loop->temp_dim)
2482 /* Calculate values that will be constant within this loop. */
2483 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2485 gfc_start_block (pbody);
2489 /* Generates the actual loop code for a scalarization loop. */
2492 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2493 stmtblock_t * pbody)
2501 loopbody = gfc_finish_block (pbody);
2503 /* Initialize the loopvar. */
2504 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2506 exit_label = gfc_build_label_decl (NULL_TREE);
2508 /* Generate the loop body. */
2509 gfc_init_block (&block);
2511 /* The exit condition. */
2512 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2513 tmp = build1_v (GOTO_EXPR, exit_label);
2514 TREE_USED (exit_label) = 1;
2515 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2516 gfc_add_expr_to_block (&block, tmp);
2518 /* The main body. */
2519 gfc_add_expr_to_block (&block, loopbody);
2521 /* Increment the loopvar. */
2522 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2523 loop->loopvar[n], gfc_index_one_node);
2524 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2526 /* Build the loop. */
2527 tmp = gfc_finish_block (&block);
2528 tmp = build1_v (LOOP_EXPR, tmp);
2529 gfc_add_expr_to_block (&loop->code[n], tmp);
2531 /* Add the exit label. */
2532 tmp = build1_v (LABEL_EXPR, exit_label);
2533 gfc_add_expr_to_block (&loop->code[n], tmp);
2537 /* Finishes and generates the loops for a scalarized expression. */
2540 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2545 stmtblock_t *pblock;
2549 /* Generate the loops. */
2550 for (dim = 0; dim < loop->dimen; dim++)
2552 n = loop->order[dim];
2553 gfc_trans_scalarized_loop_end (loop, n, pblock);
2554 loop->loopvar[n] = NULL_TREE;
2555 pblock = &loop->code[n];
2558 tmp = gfc_finish_block (pblock);
2559 gfc_add_expr_to_block (&loop->pre, tmp);
2561 /* Clear all the used flags. */
2562 for (ss = loop->ss; ss; ss = ss->loop_chain)
2567 /* Finish the main body of a scalarized expression, and start the secondary
2571 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2575 stmtblock_t *pblock;
2579 /* We finish as many loops as are used by the temporary. */
2580 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2582 n = loop->order[dim];
2583 gfc_trans_scalarized_loop_end (loop, n, pblock);
2584 loop->loopvar[n] = NULL_TREE;
2585 pblock = &loop->code[n];
2588 /* We don't want to finish the outermost loop entirely. */
2589 n = loop->order[loop->temp_dim - 1];
2590 gfc_trans_scalarized_loop_end (loop, n, pblock);
2592 /* Restore the initial offsets. */
2593 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2595 if ((ss->useflags & 2) == 0)
2598 if (ss->type != GFC_SS_SECTION
2599 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2600 && ss->type != GFC_SS_COMPONENT)
2603 ss->data.info.offset = ss->data.info.saved_offset;
2606 /* Restart all the inner loops we just finished. */
2607 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2609 n = loop->order[dim];
2611 gfc_start_block (&loop->code[n]);
2613 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2615 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2618 /* Start a block for the secondary copying code. */
2619 gfc_start_block (body);
2623 /* Calculate the upper bound of an array section. */
2626 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2635 gcc_assert (ss->type == GFC_SS_SECTION);
2637 info = &ss->data.info;
2640 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2641 /* We'll calculate the upper bound once we have access to the
2642 vector's descriptor. */
2645 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2646 desc = info->descriptor;
2647 end = info->ref->u.ar.end[dim];
2651 /* The upper bound was specified. */
2652 gfc_init_se (&se, NULL);
2653 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2654 gfc_add_block_to_block (pblock, &se.pre);
2659 /* No upper bound was specified, so use the bound of the array. */
2660 bound = gfc_conv_array_ubound (desc, dim);
2667 /* Calculate the lower bound of an array section. */
2670 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2680 gcc_assert (ss->type == GFC_SS_SECTION);
2682 info = &ss->data.info;
2685 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2687 /* We use a zero-based index to access the vector. */
2688 info->start[n] = gfc_index_zero_node;
2689 info->end[n] = gfc_index_zero_node;
2690 info->stride[n] = gfc_index_one_node;
2694 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2695 desc = info->descriptor;
2696 start = info->ref->u.ar.start[dim];
2697 end = info->ref->u.ar.end[dim];
2698 stride = info->ref->u.ar.stride[dim];
2700 /* Calculate the start of the range. For vector subscripts this will
2701 be the range of the vector. */
2704 /* Specified section start. */
2705 gfc_init_se (&se, NULL);
2706 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2707 gfc_add_block_to_block (&loop->pre, &se.pre);
2708 info->start[n] = se.expr;
2712 /* No lower bound specified so use the bound of the array. */
2713 info->start[n] = gfc_conv_array_lbound (desc, dim);
2715 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2717 /* Similarly calculate the end. Although this is not used in the
2718 scalarizer, it is needed when checking bounds and where the end
2719 is an expression with side-effects. */
2722 /* Specified section start. */
2723 gfc_init_se (&se, NULL);
2724 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2725 gfc_add_block_to_block (&loop->pre, &se.pre);
2726 info->end[n] = se.expr;
2730 /* No upper bound specified so use the bound of the array. */
2731 info->end[n] = gfc_conv_array_ubound (desc, dim);
2733 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2735 /* Calculate the stride. */
2737 info->stride[n] = gfc_index_one_node;
2740 gfc_init_se (&se, NULL);
2741 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2742 gfc_add_block_to_block (&loop->pre, &se.pre);
2743 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2748 /* Calculates the range start and stride for a SS chain. Also gets the
2749 descriptor and data pointer. The range of vector subscripts is the size
2750 of the vector. Array bounds are also checked. */
2753 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2761 /* Determine the rank of the loop. */
2763 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2767 case GFC_SS_SECTION:
2768 case GFC_SS_CONSTRUCTOR:
2769 case GFC_SS_FUNCTION:
2770 case GFC_SS_COMPONENT:
2771 loop->dimen = ss->data.info.dimen;
2774 /* As usual, lbound and ubound are exceptions!. */
2775 case GFC_SS_INTRINSIC:
2776 switch (ss->expr->value.function.isym->id)
2778 case GFC_ISYM_LBOUND:
2779 case GFC_ISYM_UBOUND:
2780 loop->dimen = ss->data.info.dimen;
2791 if (loop->dimen == 0)
2792 gfc_todo_error ("Unable to determine rank of expression");
2795 /* Loop over all the SS in the chain. */
2796 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2798 if (ss->expr && ss->expr->shape && !ss->shape)
2799 ss->shape = ss->expr->shape;
2803 case GFC_SS_SECTION:
2804 /* Get the descriptor for the array. */
2805 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2807 for (n = 0; n < ss->data.info.dimen; n++)
2808 gfc_conv_section_startstride (loop, ss, n);
2811 case GFC_SS_INTRINSIC:
2812 switch (ss->expr->value.function.isym->id)
2814 /* Fall through to supply start and stride. */
2815 case GFC_ISYM_LBOUND:
2816 case GFC_ISYM_UBOUND:
2822 case GFC_SS_CONSTRUCTOR:
2823 case GFC_SS_FUNCTION:
2824 for (n = 0; n < ss->data.info.dimen; n++)
2826 ss->data.info.start[n] = gfc_index_zero_node;
2827 ss->data.info.end[n] = gfc_index_zero_node;
2828 ss->data.info.stride[n] = gfc_index_one_node;
2837 /* The rest is just runtime bound checking. */
2838 if (flag_bounds_check)
2841 tree lbound, ubound;
2843 tree size[GFC_MAX_DIMENSIONS];
2844 tree stride_pos, stride_neg, non_zerosized, tmp2;
2849 gfc_start_block (&block);
2851 for (n = 0; n < loop->dimen; n++)
2852 size[n] = NULL_TREE;
2854 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2856 if (ss->type != GFC_SS_SECTION)
2859 /* TODO: range checking for mapped dimensions. */
2860 info = &ss->data.info;
2862 /* This code only checks ranges. Elemental and vector
2863 dimensions are checked later. */
2864 for (n = 0; n < loop->dimen; n++)
2869 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2872 if (n == info->ref->u.ar.dimen - 1
2873 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2874 || info->ref->u.ar.as->cp_was_assumed))
2875 check_upper = false;
2879 /* Zero stride is not allowed. */
2880 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2881 gfc_index_zero_node);
2882 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2883 "of array '%s'", info->dim[n]+1,
2884 ss->expr->symtree->name);
2885 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg);
2888 desc = ss->data.info.descriptor;
2890 /* This is the run-time equivalent of resolve.c's
2891 check_dimension(). The logical is more readable there
2892 than it is here, with all the trees. */
2893 lbound = gfc_conv_array_lbound (desc, dim);
2896 ubound = gfc_conv_array_ubound (desc, dim);
2900 /* non_zerosized is true when the selected range is not
2902 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2903 info->stride[n], gfc_index_zero_node);
2904 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2906 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2909 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2910 info->stride[n], gfc_index_zero_node);
2911 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2913 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2915 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2916 stride_pos, stride_neg);
2918 /* Check the start of the range against the lower and upper
2919 bounds of the array, if the range is not empty. */
2920 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2922 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2923 non_zerosized, tmp);
2924 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2925 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
2926 info->dim[n]+1, ss->expr->symtree->name);
2927 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2928 fold_convert (long_integer_type_node,
2930 fold_convert (long_integer_type_node,
2936 tmp = fold_build2 (GT_EXPR, boolean_type_node,
2937 info->start[n], ubound);
2938 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2939 non_zerosized, tmp);
2940 asprintf (&msg, "%s, upper bound of dimension %d of array "
2941 "'%s' exceeded, %%ld is greater than %%ld",
2942 gfc_msg_fault, info->dim[n]+1,
2943 ss->expr->symtree->name);
2944 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2945 fold_convert (long_integer_type_node, info->start[n]),
2946 fold_convert (long_integer_type_node, ubound));
2950 /* Compute the last element of the range, which is not
2951 necessarily "end" (think 0:5:3, which doesn't contain 5)
2952 and check it against both lower and upper bounds. */
2953 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2955 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2957 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2960 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2961 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2962 non_zerosized, tmp);
2963 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2964 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
2965 info->dim[n]+1, ss->expr->symtree->name);
2966 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2967 fold_convert (long_integer_type_node,
2969 fold_convert (long_integer_type_node,
2975 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2976 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2977 non_zerosized, tmp);
2978 asprintf (&msg, "%s, upper bound of dimension %d of array "
2979 "'%s' exceeded, %%ld is greater than %%ld",
2980 gfc_msg_fault, info->dim[n]+1,
2981 ss->expr->symtree->name);
2982 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2983 fold_convert (long_integer_type_node, tmp2),
2984 fold_convert (long_integer_type_node, ubound));
2988 /* Check the section sizes match. */
2989 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2991 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2993 /* We remember the size of the first section, and check all the
2994 others against this. */
2998 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2999 asprintf (&msg, "%s, size mismatch for dimension %d "
3000 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3001 info->dim[n]+1, ss->expr->symtree->name);
3002 gfc_trans_runtime_check (tmp3, &block, &ss->expr->where, msg,
3003 fold_convert (long_integer_type_node, tmp),
3004 fold_convert (long_integer_type_node, size[n]));
3008 size[n] = gfc_evaluate_now (tmp, &block);
3012 tmp = gfc_finish_block (&block);
3013 gfc_add_expr_to_block (&loop->pre, tmp);
3018 /* Return true if the two SS could be aliased, i.e. both point to the same data
3020 /* TODO: resolve aliases based on frontend expressions. */
3023 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3030 lsym = lss->expr->symtree->n.sym;
3031 rsym = rss->expr->symtree->n.sym;
3032 if (gfc_symbols_could_alias (lsym, rsym))
3035 if (rsym->ts.type != BT_DERIVED
3036 && lsym->ts.type != BT_DERIVED)
3039 /* For derived types we must check all the component types. We can ignore
3040 array references as these will have the same base type as the previous
3042 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3044 if (lref->type != REF_COMPONENT)
3047 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3050 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3053 if (rref->type != REF_COMPONENT)
3056 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3061 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3063 if (rref->type != REF_COMPONENT)
3066 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3074 /* Resolve array data dependencies. Creates a temporary if required. */
3075 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3079 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3089 loop->temp_ss = NULL;
3090 aref = dest->data.info.ref;
3093 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3095 if (ss->type != GFC_SS_SECTION)
3098 if (gfc_could_be_alias (dest, ss)
3099 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3105 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3107 lref = dest->expr->ref;
3108 rref = ss->expr->ref;
3110 nDepend = gfc_dep_resolver (lref, rref);
3114 /* TODO : loop shifting. */
3117 /* Mark the dimensions for LOOP SHIFTING */
3118 for (n = 0; n < loop->dimen; n++)
3120 int dim = dest->data.info.dim[n];
3122 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3124 else if (! gfc_is_same_range (&lref->u.ar,
3125 &rref->u.ar, dim, 0))
3129 /* Put all the dimensions with dependencies in the
3132 for (n = 0; n < loop->dimen; n++)
3134 gcc_assert (loop->order[n] == n);
3136 loop->order[dim++] = n;
3139 for (n = 0; n < loop->dimen; n++)
3142 loop->order[dim++] = n;
3145 gcc_assert (dim == loop->dimen);
3154 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3155 if (GFC_ARRAY_TYPE_P (base_type)
3156 || GFC_DESCRIPTOR_TYPE_P (base_type))
3157 base_type = gfc_get_element_type (base_type);
3158 loop->temp_ss = gfc_get_ss ();
3159 loop->temp_ss->type = GFC_SS_TEMP;
3160 loop->temp_ss->data.temp.type = base_type;
3161 loop->temp_ss->string_length = dest->string_length;
3162 loop->temp_ss->data.temp.dimen = loop->dimen;
3163 loop->temp_ss->next = gfc_ss_terminator;
3164 gfc_add_ss_to_loop (loop, loop->temp_ss);
3167 loop->temp_ss = NULL;
3171 /* Initialize the scalarization loop. Creates the loop variables. Determines
3172 the range of the loop variables. Creates a temporary if required.
3173 Calculates how to transform from loop variables to array indices for each
3174 expression. Also generates code for scalar expressions which have been
3175 moved outside the loop. */
3178 gfc_conv_loop_setup (gfc_loopinfo * loop)
3183 gfc_ss_info *specinfo;
3187 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3188 bool dynamic[GFC_MAX_DIMENSIONS];
3194 for (n = 0; n < loop->dimen; n++)
3198 /* We use one SS term, and use that to determine the bounds of the
3199 loop for this dimension. We try to pick the simplest term. */
3200 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3204 /* The frontend has worked out the size for us. */
3209 if (ss->type == GFC_SS_CONSTRUCTOR)
3211 /* An unknown size constructor will always be rank one.
3212 Higher rank constructors will either have known shape,
3213 or still be wrapped in a call to reshape. */
3214 gcc_assert (loop->dimen == 1);
3216 /* Always prefer to use the constructor bounds if the size
3217 can be determined at compile time. Prefer not to otherwise,
3218 since the general case involves realloc, and it's better to
3219 avoid that overhead if possible. */
3220 c = ss->expr->value.constructor;
3221 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3222 if (!dynamic[n] || !loopspec[n])
3227 /* TODO: Pick the best bound if we have a choice between a
3228 function and something else. */
3229 if (ss->type == GFC_SS_FUNCTION)
3235 if (ss->type != GFC_SS_SECTION)
3239 specinfo = &loopspec[n]->data.info;
3242 info = &ss->data.info;
3246 /* Criteria for choosing a loop specifier (most important first):
3247 doesn't need realloc
3253 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3255 else if (integer_onep (info->stride[n])
3256 && !integer_onep (specinfo->stride[n]))
3258 else if (INTEGER_CST_P (info->stride[n])
3259 && !INTEGER_CST_P (specinfo->stride[n]))
3261 else if (INTEGER_CST_P (info->start[n])
3262 && !INTEGER_CST_P (specinfo->start[n]))
3264 /* We don't work out the upper bound.
3265 else if (INTEGER_CST_P (info->finish[n])
3266 && ! INTEGER_CST_P (specinfo->finish[n]))
3267 loopspec[n] = ss; */
3271 gfc_todo_error ("Unable to find scalarization loop specifier");
3273 info = &loopspec[n]->data.info;
3275 /* Set the extents of this range. */
3276 cshape = loopspec[n]->shape;
3277 if (cshape && INTEGER_CST_P (info->start[n])
3278 && INTEGER_CST_P (info->stride[n]))
3280 loop->from[n] = info->start[n];
3281 mpz_set (i, cshape[n]);
3282 mpz_sub_ui (i, i, 1);
3283 /* To = from + (size - 1) * stride. */
3284 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3285 if (!integer_onep (info->stride[n]))
3286 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3287 tmp, info->stride[n]);
3288 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3289 loop->from[n], tmp);
3293 loop->from[n] = info->start[n];
3294 switch (loopspec[n]->type)
3296 case GFC_SS_CONSTRUCTOR:
3297 /* The upper bound is calculated when we expand the
3299 gcc_assert (loop->to[n] == NULL_TREE);
3302 case GFC_SS_SECTION:
3303 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3307 case GFC_SS_FUNCTION:
3308 /* The loop bound will be set when we generate the call. */
3309 gcc_assert (loop->to[n] == NULL_TREE);
3317 /* Transform everything so we have a simple incrementing variable. */
3318 if (integer_onep (info->stride[n]))
3319 info->delta[n] = gfc_index_zero_node;
3322 /* Set the delta for this section. */
3323 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3324 /* Number of iterations is (end - start + step) / step.
3325 with start = 0, this simplifies to
3327 for (i = 0; i<=last; i++){...}; */
3328 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3329 loop->to[n], loop->from[n]);
3330 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3331 tmp, info->stride[n]);
3332 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3333 /* Make the loop variable start at 0. */
3334 loop->from[n] = gfc_index_zero_node;
3338 /* Add all the scalar code that can be taken out of the loops.
3339 This may include calculating the loop bounds, so do it before
3340 allocating the temporary. */
3341 gfc_add_loop_ss_code (loop, loop->ss, false);
3343 /* If we want a temporary then create it. */
3344 if (loop->temp_ss != NULL)
3346 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3347 tmp = loop->temp_ss->data.temp.type;
3348 len = loop->temp_ss->string_length;
3349 n = loop->temp_ss->data.temp.dimen;
3350 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3351 loop->temp_ss->type = GFC_SS_SECTION;
3352 loop->temp_ss->data.info.dimen = n;
3353 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3354 &loop->temp_ss->data.info, tmp, false, true,
3358 for (n = 0; n < loop->temp_dim; n++)
3359 loopspec[loop->order[n]] = NULL;
3363 /* For array parameters we don't have loop variables, so don't calculate the
3365 if (loop->array_parameter)
3368 /* Calculate the translation from loop variables to array indices. */
3369 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3371 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3374 info = &ss->data.info;
3376 for (n = 0; n < info->dimen; n++)
3380 /* If we are specifying the range the delta is already set. */
3381 if (loopspec[n] != ss)
3383 /* Calculate the offset relative to the loop variable.
3384 First multiply by the stride. */
3385 tmp = loop->from[n];
3386 if (!integer_onep (info->stride[n]))
3387 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3388 tmp, info->stride[n]);
3390 /* Then subtract this from our starting value. */
3391 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3392 info->start[n], tmp);
3394 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3401 /* Fills in an array descriptor, and returns the size of the array. The size
3402 will be a simple_val, ie a variable or a constant. Also calculates the
3403 offset of the base. Returns the size of the array.
3407 for (n = 0; n < rank; n++)
3409 a.lbound[n] = specified_lower_bound;
3410 offset = offset + a.lbond[n] * stride;
3412 a.ubound[n] = specified_upper_bound;
3413 a.stride[n] = stride;
3414 size = ubound + size; //size = ubound + 1 - lbound
3415 stride = stride * size;
3422 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3423 gfc_expr ** lower, gfc_expr ** upper,
3424 stmtblock_t * pblock)
3436 stmtblock_t thenblock;
3437 stmtblock_t elseblock;
3442 type = TREE_TYPE (descriptor);
3444 stride = gfc_index_one_node;
3445 offset = gfc_index_zero_node;
3447 /* Set the dtype. */
3448 tmp = gfc_conv_descriptor_dtype (descriptor);
3449 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3451 or_expr = NULL_TREE;
3453 for (n = 0; n < rank; n++)
3455 /* We have 3 possibilities for determining the size of the array:
3456 lower == NULL => lbound = 1, ubound = upper[n]
3457 upper[n] = NULL => lbound = 1, ubound = lower[n]
3458 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3461 /* Set lower bound. */
3462 gfc_init_se (&se, NULL);
3464 se.expr = gfc_index_one_node;
3467 gcc_assert (lower[n]);
3470 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3471 gfc_add_block_to_block (pblock, &se.pre);
3475 se.expr = gfc_index_one_node;
3479 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3480 gfc_add_modify_expr (pblock, tmp, se.expr);
3482 /* Work out the offset for this component. */
3483 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3484 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3486 /* Start the calculation for the size of this dimension. */
3487 size = build2 (MINUS_EXPR, gfc_array_index_type,
3488 gfc_index_one_node, se.expr);
3490 /* Set upper bound. */
3491 gfc_init_se (&se, NULL);
3492 gcc_assert (ubound);
3493 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3494 gfc_add_block_to_block (pblock, &se.pre);
3496 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3497 gfc_add_modify_expr (pblock, tmp, se.expr);
3499 /* Store the stride. */
3500 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3501 gfc_add_modify_expr (pblock, tmp, stride);
3503 /* Calculate the size of this dimension. */
3504 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3506 /* Check whether the size for this dimension is negative. */
3507 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3508 gfc_index_zero_node);
3512 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3514 /* Multiply the stride by the number of elements in this dimension. */
3515 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3516 stride = gfc_evaluate_now (stride, pblock);
3519 /* The stride is the number of elements in the array, so multiply by the
3520 size of an element to get the total size. */
3521 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3522 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3523 fold_convert (gfc_array_index_type, tmp));
3525 if (poffset != NULL)
3527 offset = gfc_evaluate_now (offset, pblock);
3531 if (integer_zerop (or_expr))
3533 if (integer_onep (or_expr))
3534 return gfc_index_zero_node;
3536 var = gfc_create_var (TREE_TYPE (size), "size");
3537 gfc_start_block (&thenblock);
3538 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3539 thencase = gfc_finish_block (&thenblock);
3541 gfc_start_block (&elseblock);
3542 gfc_add_modify_expr (&elseblock, var, size);
3543 elsecase = gfc_finish_block (&elseblock);
3545 tmp = gfc_evaluate_now (or_expr, pblock);
3546 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3547 gfc_add_expr_to_block (pblock, tmp);
3553 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3554 the work for an ALLOCATE statement. */
3558 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3567 gfc_ref *ref, *prev_ref = NULL;
3568 bool allocatable_array;
3572 /* Find the last reference in the chain. */
3573 while (ref && ref->next != NULL)
3575 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3580 if (ref == NULL || ref->type != REF_ARRAY)
3584 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3586 allocatable_array = prev_ref->u.c.component->allocatable;
3588 /* Figure out the size of the array. */
3589 switch (ref->u.ar.type)
3593 upper = ref->u.ar.start;
3597 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3599 lower = ref->u.ar.as->lower;
3600 upper = ref->u.ar.as->upper;
3604 lower = ref->u.ar.start;
3605 upper = ref->u.ar.end;
3613 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3614 lower, upper, &se->pre);
3616 /* Allocate memory to store the data. */
3617 pointer = gfc_conv_descriptor_data_get (se->expr);
3618 STRIP_NOPS (pointer);
3620 if (TYPE_PRECISION (gfc_array_index_type) == 32 ||
3621 TYPE_PRECISION (gfc_array_index_type) == 64)
3623 if (allocatable_array)
3624 allocate = gfor_fndecl_allocate_array;
3626 allocate = gfor_fndecl_allocate;
3631 /* The allocate_array variants take the old pointer as first argument. */
3632 if (allocatable_array)
3633 tmp = build_call_expr (allocate, 3, pointer, size, pstat);
3635 tmp = build_call_expr (allocate, 2, size, pstat);
3636 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3637 gfc_add_expr_to_block (&se->pre, tmp);
3639 tmp = gfc_conv_descriptor_offset (se->expr);
3640 gfc_add_modify_expr (&se->pre, tmp, offset);
3642 if (expr->ts.type == BT_DERIVED
3643 && expr->ts.derived->attr.alloc_comp)
3645 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3646 ref->u.ar.as->rank);
3647 gfc_add_expr_to_block (&se->pre, tmp);
3654 /* Deallocate an array variable. Also used when an allocated variable goes
3659 gfc_array_deallocate (tree descriptor, tree pstat)
3665 gfc_start_block (&block);
3666 /* Get a pointer to the data. */
3667 var = gfc_conv_descriptor_data_get (descriptor);
3670 /* Parameter is the address of the data component. */
3671 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
3672 gfc_add_expr_to_block (&block, tmp);
3674 /* Zero the data pointer. */
3675 tmp = build2 (MODIFY_EXPR, void_type_node,
3676 var, build_int_cst (TREE_TYPE (var), 0));
3677 gfc_add_expr_to_block (&block, tmp);
3679 return gfc_finish_block (&block);
3683 /* Create an array constructor from an initialization expression.
3684 We assume the frontend already did any expansions and conversions. */
3687 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3694 unsigned HOST_WIDE_INT lo;
3696 VEC(constructor_elt,gc) *v = NULL;
3698 switch (expr->expr_type)
3701 case EXPR_STRUCTURE:
3702 /* A single scalar or derived type value. Create an array with all
3703 elements equal to that value. */
3704 gfc_init_se (&se, NULL);
3706 if (expr->expr_type == EXPR_CONSTANT)
3707 gfc_conv_constant (&se, expr);
3709 gfc_conv_structure (&se, expr, 1);
3711 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3712 gcc_assert (tmp && INTEGER_CST_P (tmp));
3713 hi = TREE_INT_CST_HIGH (tmp);
3714 lo = TREE_INT_CST_LOW (tmp);
3718 /* This will probably eat buckets of memory for large arrays. */
3719 while (hi != 0 || lo != 0)
3721 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3729 /* Create a vector of all the elements. */
3730 for (c = expr->value.constructor; c; c = c->next)
3734 /* Problems occur when we get something like
3735 integer :: a(lots) = (/(i, i=1,lots)/) */
3736 /* TODO: Unexpanded array initializers. */
3738 ("Possible frontend bug: array constructor not expanded");
3740 if (mpz_cmp_si (c->n.offset, 0) != 0)
3741 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3745 if (mpz_cmp_si (c->repeat, 0) != 0)
3749 mpz_set (maxval, c->repeat);
3750 mpz_add (maxval, c->n.offset, maxval);
3751 mpz_sub_ui (maxval, maxval, 1);
3752 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3753 if (mpz_cmp_si (c->n.offset, 0) != 0)
3755 mpz_add_ui (maxval, c->n.offset, 1);
3756 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3759 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3761 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3767 gfc_init_se (&se, NULL);
3768 switch (c->expr->expr_type)
3771 gfc_conv_constant (&se, c->expr);
3772 if (range == NULL_TREE)
3773 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3776 if (index != NULL_TREE)
3777 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3778 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3782 case EXPR_STRUCTURE:
3783 gfc_conv_structure (&se, c->expr, 1);
3784 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3794 return gfc_build_null_descriptor (type);
3800 /* Create a constructor from the list of elements. */
3801 tmp = build_constructor (type, v);
3802 TREE_CONSTANT (tmp) = 1;
3803 TREE_INVARIANT (tmp) = 1;
3808 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3809 returns the size (in elements) of the array. */
3812 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3813 stmtblock_t * pblock)
3828 size = gfc_index_one_node;
3829 offset = gfc_index_zero_node;
3830 for (dim = 0; dim < as->rank; dim++)
3832 /* Evaluate non-constant array bound expressions. */
3833 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3834 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3836 gfc_init_se (&se, NULL);
3837 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3838 gfc_add_block_to_block (pblock, &se.pre);
3839 gfc_add_modify_expr (pblock, lbound, se.expr);
3841 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3842 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3844 gfc_init_se (&se, NULL);
3845 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3846 gfc_add_block_to_block (pblock, &se.pre);
3847 gfc_add_modify_expr (pblock, ubound, se.expr);
3849 /* The offset of this dimension. offset = offset - lbound * stride. */
3850 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3851 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3853 /* The size of this dimension, and the stride of the next. */
3854 if (dim + 1 < as->rank)
3855 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3857 stride = GFC_TYPE_ARRAY_SIZE (type);
3859 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3861 /* Calculate stride = size * (ubound + 1 - lbound). */
3862 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3863 gfc_index_one_node, lbound);
3864 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3865 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3867 gfc_add_modify_expr (pblock, stride, tmp);
3869 stride = gfc_evaluate_now (tmp, pblock);
3871 /* Make sure that negative size arrays are translated
3872 to being zero size. */
3873 tmp = build2 (GE_EXPR, boolean_type_node,
3874 stride, gfc_index_zero_node);
3875 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3876 stride, gfc_index_zero_node);
3877 gfc_add_modify_expr (pblock, stride, tmp);
3883 gfc_trans_vla_type_sizes (sym, pblock);
3890 /* Generate code to initialize/allocate an array variable. */
3893 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3902 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3904 /* Do nothing for USEd variables. */
3905 if (sym->attr.use_assoc)
3908 type = TREE_TYPE (decl);
3909 gcc_assert (GFC_ARRAY_TYPE_P (type));
3910 onstack = TREE_CODE (type) != POINTER_TYPE;
3912 gfc_start_block (&block);
3914 /* Evaluate character string length. */
3915 if (sym->ts.type == BT_CHARACTER
3916 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3918 gfc_trans_init_string_length (sym->ts.cl, &block);
3920 gfc_trans_vla_type_sizes (sym, &block);
3922 /* Emit a DECL_EXPR for this variable, which will cause the
3923 gimplifier to allocate storage, and all that good stuff. */
3924 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3925 gfc_add_expr_to_block (&block, tmp);
3930 gfc_add_expr_to_block (&block, fnbody);
3931 return gfc_finish_block (&block);
3934 type = TREE_TYPE (type);
3936 gcc_assert (!sym->attr.use_assoc);
3937 gcc_assert (!TREE_STATIC (decl));
3938 gcc_assert (!sym->module);
3940 if (sym->ts.type == BT_CHARACTER
3941 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3942 gfc_trans_init_string_length (sym->ts.cl, &block);
3944 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3946 /* Don't actually allocate space for Cray Pointees. */
3947 if (sym->attr.cray_pointee)
3949 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3950 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3951 gfc_add_expr_to_block (&block, fnbody);
3952 return gfc_finish_block (&block);
3955 /* The size is the number of elements in the array, so multiply by the
3956 size of an element to get the total size. */
3957 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3958 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
3959 fold_convert (gfc_array_index_type, tmp));
3961 /* Allocate memory to hold the data. */
3962 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3963 gfc_add_modify_expr (&block, decl, tmp);
3965 /* Set offset of the array. */
3966 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3967 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3970 /* Automatic arrays should not have initializers. */
3971 gcc_assert (!sym->value);
3973 gfc_add_expr_to_block (&block, fnbody);
3975 /* Free the temporary. */
3976 tmp = gfc_call_free (convert (pvoid_type_node, decl));
3977 gfc_add_expr_to_block (&block, tmp);
3979 return gfc_finish_block (&block);
3983 /* Generate entry and exit code for g77 calling convention arrays. */
3986 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3996 gfc_get_backend_locus (&loc);
3997 gfc_set_backend_locus (&sym->declared_at);
3999 /* Descriptor type. */
4000 parm = sym->backend_decl;
4001 type = TREE_TYPE (parm);
4002 gcc_assert (GFC_ARRAY_TYPE_P (type));
4004 gfc_start_block (&block);
4006 if (sym->ts.type == BT_CHARACTER
4007 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4008 gfc_trans_init_string_length (sym->ts.cl, &block);
4010 /* Evaluate the bounds of the array. */
4011 gfc_trans_array_bounds (type, sym, &offset, &block);
4013 /* Set the offset. */
4014 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4015 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4017 /* Set the pointer itself if we aren't using the parameter directly. */
4018 if (TREE_CODE (parm) != PARM_DECL)
4020 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4021 gfc_add_modify_expr (&block, parm, tmp);
4023 stmt = gfc_finish_block (&block);
4025 gfc_set_backend_locus (&loc);
4027 gfc_start_block (&block);
4029 /* Add the initialization code to the start of the function. */
4031 if (sym->attr.optional || sym->attr.not_always_present)
4033 tmp = gfc_conv_expr_present (sym);
4034 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4037 gfc_add_expr_to_block (&block, stmt);
4038 gfc_add_expr_to_block (&block, body);
4040 return gfc_finish_block (&block);
4044 /* Modify the descriptor of an array parameter so that it has the
4045 correct lower bound. Also move the upper bound accordingly.
4046 If the array is not packed, it will be copied into a temporary.
4047 For each dimension we set the new lower and upper bounds. Then we copy the
4048 stride and calculate the offset for this dimension. We also work out
4049 what the stride of a packed array would be, and see it the two match.
4050 If the array need repacking, we set the stride to the values we just
4051 calculated, recalculate the offset and copy the array data.
4052 Code is also added to copy the data back at the end of the function.
4056 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4063 stmtblock_t cleanup;
4071 tree stride, stride2;
4081 /* Do nothing for pointer and allocatable arrays. */
4082 if (sym->attr.pointer || sym->attr.allocatable)
4085 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4086 return gfc_trans_g77_array (sym, body);
4088 gfc_get_backend_locus (&loc);
4089 gfc_set_backend_locus (&sym->declared_at);
4091 /* Descriptor type. */
4092 type = TREE_TYPE (tmpdesc);
4093 gcc_assert (GFC_ARRAY_TYPE_P (type));
4094 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4095 dumdesc = build_fold_indirect_ref (dumdesc);
4096 gfc_start_block (&block);
4098 if (sym->ts.type == BT_CHARACTER
4099 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4100 gfc_trans_init_string_length (sym->ts.cl, &block);
4102 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4104 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4105 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4107 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4109 /* For non-constant shape arrays we only check if the first dimension
4110 is contiguous. Repacking higher dimensions wouldn't gain us
4111 anything as we still don't know the array stride. */
4112 partial = gfc_create_var (boolean_type_node, "partial");
4113 TREE_USED (partial) = 1;
4114 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4115 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4116 gfc_add_modify_expr (&block, partial, tmp);
4120 partial = NULL_TREE;
4123 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4124 here, however I think it does the right thing. */
4127 /* Set the first stride. */
4128 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4129 stride = gfc_evaluate_now (stride, &block);
4131 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4132 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4133 gfc_index_one_node, stride);
4134 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4135 gfc_add_modify_expr (&block, stride, tmp);
4137 /* Allow the user to disable array repacking. */
4138 stmt_unpacked = NULL_TREE;
4142 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4143 /* A library call to repack the array if necessary. */
4144 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4145 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4147 stride = gfc_index_one_node;
4150 /* This is for the case where the array data is used directly without
4151 calling the repack function. */
4152 if (no_repack || partial != NULL_TREE)
4153 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4155 stmt_packed = NULL_TREE;
4157 /* Assign the data pointer. */
4158 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4160 /* Don't repack unknown shape arrays when the first stride is 1. */
4161 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4162 stmt_packed, stmt_unpacked);
4165 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4166 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4168 offset = gfc_index_zero_node;
4169 size = gfc_index_one_node;
4171 /* Evaluate the bounds of the array. */
4172 for (n = 0; n < sym->as->rank; n++)
4174 if (checkparm || !sym->as->upper[n])
4176 /* Get the bounds of the actual parameter. */
4177 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4178 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4182 dubound = NULL_TREE;
4183 dlbound = NULL_TREE;
4186 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4187 if (!INTEGER_CST_P (lbound))
4189 gfc_init_se (&se, NULL);
4190 gfc_conv_expr_type (&se, sym->as->lower[n],
4191 gfc_array_index_type);
4192 gfc_add_block_to_block (&block, &se.pre);
4193 gfc_add_modify_expr (&block, lbound, se.expr);
4196 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4197 /* Set the desired upper bound. */
4198 if (sym->as->upper[n])
4200 /* We know what we want the upper bound to be. */
4201 if (!INTEGER_CST_P (ubound))
4203 gfc_init_se (&se, NULL);
4204 gfc_conv_expr_type (&se, sym->as->upper[n],
4205 gfc_array_index_type);
4206 gfc_add_block_to_block (&block, &se.pre);
4207 gfc_add_modify_expr (&block, ubound, se.expr);
4210 /* Check the sizes match. */
4213 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4216 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4218 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4220 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4221 asprintf (&msg, "%s for dimension %d of array '%s'",
4222 gfc_msg_bounds, n+1, sym->name);
4223 gfc_trans_runtime_check (tmp, &block, &loc, msg);
4229 /* For assumed shape arrays move the upper bound by the same amount
4230 as the lower bound. */
4231 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4232 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4233 gfc_add_modify_expr (&block, ubound, tmp);
4235 /* The offset of this dimension. offset = offset - lbound * stride. */
4236 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4237 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4239 /* The size of this dimension, and the stride of the next. */
4240 if (n + 1 < sym->as->rank)
4242 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4244 if (no_repack || partial != NULL_TREE)
4247 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4250 /* Figure out the stride if not a known constant. */
4251 if (!INTEGER_CST_P (stride))
4254 stmt_packed = NULL_TREE;
4257 /* Calculate stride = size * (ubound + 1 - lbound). */
4258 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4259 gfc_index_one_node, lbound);
4260 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4262 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4267 /* Assign the stride. */
4268 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4269 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4270 stmt_unpacked, stmt_packed);
4272 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4273 gfc_add_modify_expr (&block, stride, tmp);
4278 stride = GFC_TYPE_ARRAY_SIZE (type);
4280 if (stride && !INTEGER_CST_P (stride))
4282 /* Calculate size = stride * (ubound + 1 - lbound). */
4283 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4284 gfc_index_one_node, lbound);
4285 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4287 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4288 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4289 gfc_add_modify_expr (&block, stride, tmp);
4294 /* Set the offset. */
4295 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4296 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4298 gfc_trans_vla_type_sizes (sym, &block);
4300 stmt = gfc_finish_block (&block);
4302 gfc_start_block (&block);
4304 /* Only do the entry/initialization code if the arg is present. */
4305 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4306 optional_arg = (sym->attr.optional
4307 || (sym->ns->proc_name->attr.entry_master
4308 && sym->attr.dummy));
4311 tmp = gfc_conv_expr_present (sym);
4312 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4314 gfc_add_expr_to_block (&block, stmt);
4316 /* Add the main function body. */
4317 gfc_add_expr_to_block (&block, body);
4322 gfc_start_block (&cleanup);
4324 if (sym->attr.intent != INTENT_IN)
4326 /* Copy the data back. */
4327 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4328 gfc_add_expr_to_block (&cleanup, tmp);
4331 /* Free the temporary. */
4332 tmp = gfc_call_free (tmpdesc);
4333 gfc_add_expr_to_block (&cleanup, tmp);
4335 stmt = gfc_finish_block (&cleanup);
4337 /* Only do the cleanup if the array was repacked. */
4338 tmp = build_fold_indirect_ref (dumdesc);
4339 tmp = gfc_conv_descriptor_data_get (tmp);
4340 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4341 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4345 tmp = gfc_conv_expr_present (sym);
4346 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4348 gfc_add_expr_to_block (&block, stmt);
4350 /* We don't need to free any memory allocated by internal_pack as it will
4351 be freed at the end of the function by pop_context. */
4352 return gfc_finish_block (&block);
4356 /* Convert an array for passing as an actual argument. Expressions and
4357 vector subscripts are evaluated and stored in a temporary, which is then
4358 passed. For whole arrays the descriptor is passed. For array sections
4359 a modified copy of the descriptor is passed, but using the original data.
4361 This function is also used for array pointer assignments, and there
4364 - se->want_pointer && !se->direct_byref
4365 EXPR is an actual argument. On exit, se->expr contains a
4366 pointer to the array descriptor.
4368 - !se->want_pointer && !se->direct_byref
4369 EXPR is an actual argument to an intrinsic function or the
4370 left-hand side of a pointer assignment. On exit, se->expr
4371 contains the descriptor for EXPR.
4373 - !se->want_pointer && se->direct_byref
4374 EXPR is the right-hand side of a pointer assignment and
4375 se->expr is the descriptor for the previously-evaluated
4376 left-hand side. The function creates an assignment from
4377 EXPR to se->expr. */
4380 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4394 gcc_assert (ss != gfc_ss_terminator);
4396 /* Special case things we know we can pass easily. */
4397 switch (expr->expr_type)
4400 /* If we have a linear array section, we can pass it directly.
4401 Otherwise we need to copy it into a temporary. */
4403 /* Find the SS for the array section. */
4405 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4406 secss = secss->next;
4408 gcc_assert (secss != gfc_ss_terminator);
4409 info = &secss->data.info;
4411 /* Get the descriptor for the array. */
4412 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4413 desc = info->descriptor;
4415 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4418 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4420 /* Create a new descriptor if the array doesn't have one. */
4423 else if (info->ref->u.ar.type == AR_FULL)
4425 else if (se->direct_byref)
4428 full = gfc_full_array_ref_p (info->ref);
4432 if (se->direct_byref)
4434 /* Copy the descriptor for pointer assignments. */
4435 gfc_add_modify_expr (&se->pre, se->expr, desc);
4437 else if (se->want_pointer)
4439 /* We pass full arrays directly. This means that pointers and
4440 allocatable arrays should also work. */
4441 se->expr = build_fold_addr_expr (desc);
4448 if (expr->ts.type == BT_CHARACTER)
4449 se->string_length = gfc_get_expr_charlen (expr);
4456 /* A transformational function return value will be a temporary
4457 array descriptor. We still need to go through the scalarizer
4458 to create the descriptor. Elemental functions ar handled as
4459 arbitrary expressions, i.e. copy to a temporary. */
4461 /* Look for the SS for this function. */
4462 while (secss != gfc_ss_terminator
4463 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4464 secss = secss->next;
4466 if (se->direct_byref)
4468 gcc_assert (secss != gfc_ss_terminator);
4470 /* For pointer assignments pass the descriptor directly. */
4472 se->expr = build_fold_addr_expr (se->expr);
4473 gfc_conv_expr (se, expr);
4477 if (secss == gfc_ss_terminator)
4479 /* Elemental function. */
4485 /* Transformational function. */
4486 info = &secss->data.info;
4492 /* Constant array constructors don't need a temporary. */
4493 if (ss->type == GFC_SS_CONSTRUCTOR
4494 && expr->ts.type != BT_CHARACTER
4495 && gfc_constant_array_constructor_p (expr->value.constructor))
4498 info = &ss->data.info;
4510 /* Something complicated. Copy it into a temporary. */
4518 gfc_init_loopinfo (&loop);
4520 /* Associate the SS with the loop. */
4521 gfc_add_ss_to_loop (&loop, ss);
4523 /* Tell the scalarizer not to bother creating loop variables, etc. */
4525 loop.array_parameter = 1;
4527 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4528 gcc_assert (!se->direct_byref);
4530 /* Setup the scalarizing loops and bounds. */
4531 gfc_conv_ss_startstride (&loop);
4535 /* Tell the scalarizer to make a temporary. */
4536 loop.temp_ss = gfc_get_ss ();
4537 loop.temp_ss->type = GFC_SS_TEMP;
4538 loop.temp_ss->next = gfc_ss_terminator;
4539 if (expr->ts.type == BT_CHARACTER)
4541 if (expr->ts.cl == NULL)
4543 /* This had better be a substring reference! */
4544 gfc_ref *char_ref = expr->ref;
4545 for (; char_ref; char_ref = char_ref->next)
4546 if (char_ref->type == REF_SUBSTRING)
4549 expr->ts.cl = gfc_get_charlen ();
4550 expr->ts.cl->next = char_ref->u.ss.length->next;
4551 char_ref->u.ss.length->next = expr->ts.cl;
4553 mpz_init_set_ui (char_len, 1);
4554 mpz_add (char_len, char_len,
4555 char_ref->u.ss.end->value.integer);
4556 mpz_sub (char_len, char_len,
4557 char_ref->u.ss.start->value.integer);
4558 expr->ts.cl->backend_decl
4559 = gfc_conv_mpz_to_tree (char_len,
4560 gfc_default_character_kind);
4561 /* Cast is necessary for *-charlen refs. */
4562 expr->ts.cl->backend_decl
4563 = convert (gfc_charlen_type_node,
4564 expr->ts.cl->backend_decl);
4565 mpz_clear (char_len);
4568 gcc_assert (char_ref != NULL);
4569 loop.temp_ss->data.temp.type
4570 = gfc_typenode_for_spec (&expr->ts);
4571 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4573 else if (expr->ts.cl->length
4574 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4576 expr->ts.cl->backend_decl
4577 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4578 expr->ts.cl->length->ts.kind);
4579 loop.temp_ss->data.temp.type
4580 = gfc_typenode_for_spec (&expr->ts);
4581 loop.temp_ss->string_length
4582 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4586 loop.temp_ss->data.temp.type
4587 = gfc_typenode_for_spec (&expr->ts);
4588 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4590 se->string_length = loop.temp_ss->string_length;
4594 loop.temp_ss->data.temp.type
4595 = gfc_typenode_for_spec (&expr->ts);
4596 loop.temp_ss->string_length = NULL;
4598 loop.temp_ss->data.temp.dimen = loop.dimen;
4599 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4602 gfc_conv_loop_setup (&loop);
4606 /* Copy into a temporary and pass that. We don't need to copy the data
4607 back because expressions and vector subscripts must be INTENT_IN. */
4608 /* TODO: Optimize passing function return values. */
4612 /* Start the copying loops. */
4613 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4614 gfc_mark_ss_chain_used (ss, 1);
4615 gfc_start_scalarized_body (&loop, &block);
4617 /* Copy each data element. */
4618 gfc_init_se (&lse, NULL);
4619 gfc_copy_loopinfo_to_se (&lse, &loop);
4620 gfc_init_se (&rse, NULL);
4621 gfc_copy_loopinfo_to_se (&rse, &loop);
4623 lse.ss = loop.temp_ss;
4626 gfc_conv_scalarized_array_ref (&lse, NULL);
4627 if (expr->ts.type == BT_CHARACTER)
4629 gfc_conv_expr (&rse, expr);
4630 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4631 rse.expr = build_fold_indirect_ref (rse.expr);
4634 gfc_conv_expr_val (&rse, expr);
4636 gfc_add_block_to_block (&block, &rse.pre);
4637 gfc_add_block_to_block (&block, &lse.pre);
4639 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4641 /* Finish the copying loops. */
4642 gfc_trans_scalarizing_loops (&loop, &block);
4644 desc = loop.temp_ss->data.info.descriptor;
4646 gcc_assert (is_gimple_lvalue (desc));
4648 else if (expr->expr_type == EXPR_FUNCTION)
4650 desc = info->descriptor;
4651 se->string_length = ss->string_length;
4655 /* We pass sections without copying to a temporary. Make a new
4656 descriptor and point it at the section we want. The loop variable
4657 limits will be the limits of the section.
4658 A function may decide to repack the array to speed up access, but
4659 we're not bothered about that here. */
4668 /* Set the string_length for a character array. */
4669 if (expr->ts.type == BT_CHARACTER)
4670 se->string_length = gfc_get_expr_charlen (expr);
4672 desc = info->descriptor;
4673 gcc_assert (secss && secss != gfc_ss_terminator);
4674 if (se->direct_byref)
4676 /* For pointer assignments we fill in the destination. */
4678 parmtype = TREE_TYPE (parm);
4682 /* Otherwise make a new one. */
4683 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4684 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4685 loop.from, loop.to, 0);
4686 parm = gfc_create_var (parmtype, "parm");
4689 offset = gfc_index_zero_node;
4692 /* The following can be somewhat confusing. We have two
4693 descriptors, a new one and the original array.
4694 {parm, parmtype, dim} refer to the new one.
4695 {desc, type, n, secss, loop} refer to the original, which maybe
4696 a descriptorless array.
4697 The bounds of the scalarization are the bounds of the section.
4698 We don't have to worry about numeric overflows when calculating
4699 the offsets because all elements are within the array data. */
4701 /* Set the dtype. */
4702 tmp = gfc_conv_descriptor_dtype (parm);
4703 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4705 if (se->direct_byref)
4706 base = gfc_index_zero_node;
4707 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4708 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4712 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4713 for (n = 0; n < ndim; n++)
4715 stride = gfc_conv_array_stride (desc, n);
4717 /* Work out the offset. */
4719 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4721 gcc_assert (info->subscript[n]
4722 && info->subscript[n]->type == GFC_SS_SCALAR);
4723 start = info->subscript[n]->data.scalar.expr;
4727 /* Check we haven't somehow got out of sync. */
4728 gcc_assert (info->dim[dim] == n);
4730 /* Evaluate and remember the start of the section. */
4731 start = info->start[dim];
4732 stride = gfc_evaluate_now (stride, &loop.pre);
4735 tmp = gfc_conv_array_lbound (desc, n);
4736 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4738 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4739 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4742 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4744 /* For elemental dimensions, we only need the offset. */
4748 /* Vector subscripts need copying and are handled elsewhere. */
4750 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4752 /* Set the new lower bound. */
4753 from = loop.from[dim];
4756 /* If we have an array section or are assigning to a pointer,
4757 make sure that the lower bound is 1. References to the full
4758 array should otherwise keep the original bounds. */
4760 || info->ref->u.ar.type != AR_FULL
4761 || se->direct_byref)
4762 && !integer_onep (from))
4764 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4765 gfc_index_one_node, from);
4766 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4767 from = gfc_index_one_node;
4769 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4770 gfc_add_modify_expr (&loop.pre, tmp, from);
4772 /* Set the new upper bound. */
4773 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4774 gfc_add_modify_expr (&loop.pre, tmp, to);
4776 /* Multiply the stride by the section stride to get the
4778 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4779 stride, info->stride[dim]);
4781 if (se->direct_byref)
4783 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4786 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4788 tmp = gfc_conv_array_lbound (desc, n);
4789 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4790 tmp, loop.from[dim]);
4791 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
4792 tmp, gfc_conv_array_stride (desc, n));
4793 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
4797 /* Store the new stride. */
4798 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4799 gfc_add_modify_expr (&loop.pre, tmp, stride);
4804 if (se->data_not_needed)
4805 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4808 /* Point the data pointer at the first element in the section. */
4809 tmp = gfc_conv_array_data (desc);
4810 tmp = build_fold_indirect_ref (tmp);
4811 tmp = gfc_build_array_ref (tmp, offset);
4812 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4813 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4816 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4817 && !se->data_not_needed)
4819 /* Set the offset. */
4820 tmp = gfc_conv_descriptor_offset (parm);
4821 gfc_add_modify_expr (&loop.pre, tmp, base);
4825 /* Only the callee knows what the correct offset it, so just set
4827 tmp = gfc_conv_descriptor_offset (parm);
4828 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4833 if (!se->direct_byref)
4835 /* Get a pointer to the new descriptor. */
4836 if (se->want_pointer)
4837 se->expr = build_fold_addr_expr (desc);
4842 gfc_add_block_to_block (&se->pre, &loop.pre);
4843 gfc_add_block_to_block (&se->post, &loop.post);
4845 /* Cleanup the scalarizer. */
4846 gfc_cleanup_loop (&loop);
4850 /* Convert an array for passing as an actual parameter. */
4851 /* TODO: Optimize passing g77 arrays. */
4854 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4858 tree tmp = NULL_TREE;
4860 tree parent = DECL_CONTEXT (current_function_decl);
4861 bool full_array_var, this_array_result;
4865 full_array_var = (expr->expr_type == EXPR_VARIABLE
4866 && expr->ref->u.ar.type == AR_FULL);
4867 sym = full_array_var ? expr->symtree->n.sym : NULL;
4869 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
4871 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
4872 expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
4873 se->string_length = expr->ts.cl->backend_decl;
4876 /* Is this the result of the enclosing procedure? */
4877 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4878 if (this_array_result
4879 && (sym->backend_decl != current_function_decl)
4880 && (sym->backend_decl != parent))
4881 this_array_result = false;
4883 /* Passing address of the array if it is not pointer or assumed-shape. */
4884 if (full_array_var && g77 && !this_array_result)
4886 tmp = gfc_get_symbol_decl (sym);
4888 if (sym->ts.type == BT_CHARACTER)
4889 se->string_length = sym->ts.cl->backend_decl;
4890 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4891 && !sym->attr.allocatable)
4893 /* Some variables are declared directly, others are declared as
4894 pointers and allocated on the heap. */
4895 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4898 se->expr = build_fold_addr_expr (tmp);
4901 if (sym->attr.allocatable)
4903 if (sym->attr.dummy)
4905 gfc_conv_expr_descriptor (se, expr, ss);
4906 se->expr = gfc_conv_array_data (se->expr);
4909 se->expr = gfc_conv_array_data (tmp);
4914 if (this_array_result)
4916 /* Result of the enclosing function. */
4917 gfc_conv_expr_descriptor (se, expr, ss);
4918 se->expr = build_fold_addr_expr (se->expr);
4920 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
4921 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4922 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
4928 /* Every other type of array. */
4929 se->want_pointer = 1;
4930 gfc_conv_expr_descriptor (se, expr, ss);
4934 /* Deallocate the allocatable components of structures that are
4936 if (expr->ts.type == BT_DERIVED
4937 && expr->ts.derived->attr.alloc_comp
4938 && expr->expr_type != EXPR_VARIABLE)
4940 tmp = build_fold_indirect_ref (se->expr);
4941 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4942 gfc_add_expr_to_block (&se->post, tmp);
4948 /* Repack the array. */
4949 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
4950 ptr = gfc_evaluate_now (ptr, &se->pre);
4953 gfc_start_block (&block);
4955 /* Copy the data back. */
4956 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
4957 gfc_add_expr_to_block (&block, tmp);
4959 /* Free the temporary. */
4960 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
4961 gfc_add_expr_to_block (&block, tmp);
4963 stmt = gfc_finish_block (&block);
4965 gfc_init_block (&block);
4966 /* Only if it was repacked. This code needs to be executed before the
4967 loop cleanup code. */
4968 tmp = build_fold_indirect_ref (desc);
4969 tmp = gfc_conv_array_data (tmp);
4970 tmp = build2 (NE_EXPR, boolean_type_node,
4971 fold_convert (TREE_TYPE (tmp), ptr), tmp);
4972 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4974 gfc_add_expr_to_block (&block, tmp);
4975 gfc_add_block_to_block (&block, &se->post);
4977 gfc_init_block (&se->post);
4978 gfc_add_block_to_block (&se->post, &block);
4983 /* Generate code to deallocate an array, if it is allocated. */
4986 gfc_trans_dealloc_allocated (tree descriptor)
4993 gfc_start_block (&block);
4995 var = gfc_conv_descriptor_data_get (descriptor);
4997 tmp = gfc_create_var (gfc_array_index_type, NULL);
4998 ptr = build_fold_addr_expr (tmp);
5000 /* Call array_deallocate with an int* present in the second argument.
5001 Although it is ignored here, it's presence ensures that arrays that
5002 are already deallocated are ignored. */
5003 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
5004 gfc_add_expr_to_block (&block, tmp);
5006 /* Zero the data pointer. */
5007 tmp = build2 (MODIFY_EXPR, void_type_node,
5008 var, build_int_cst (TREE_TYPE (var), 0));
5009 gfc_add_expr_to_block (&block, tmp);
5011 return gfc_finish_block (&block);
5015 /* This helper function calculates the size in words of a full array. */
5018 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5023 idx = gfc_rank_cst[rank - 1];
5024 nelems = gfc_conv_descriptor_ubound (decl, idx);
5025 tmp = gfc_conv_descriptor_lbound (decl, idx);
5026 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5027 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
5028 tmp, gfc_index_one_node);
5029 tmp = gfc_evaluate_now (tmp, block);
5031 nelems = gfc_conv_descriptor_stride (decl, idx);
5032 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5033 return gfc_evaluate_now (tmp, block);
5037 /* Allocate dest to the same size as src, and copy src -> dest. */
5040 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5049 /* If the source is null, set the destination to null. */
5050 gfc_init_block (&block);
5051 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5052 null_data = gfc_finish_block (&block);
5054 gfc_init_block (&block);
5056 nelems = get_full_array_size (&block, src, rank);
5057 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5058 fold_convert (gfc_array_index_type,
5059 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5061 /* Allocate memory to the destination. */
5062 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5064 gfc_conv_descriptor_data_set (&block, dest, tmp);
5066 /* We know the temporary and the value will be the same length,
5067 so can use memcpy. */
5068 tmp = built_in_decls[BUILT_IN_MEMCPY];
5069 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5070 gfc_conv_descriptor_data_get (src), size);
5071 gfc_add_expr_to_block (&block, tmp);
5072 tmp = gfc_finish_block (&block);
5074 /* Null the destination if the source is null; otherwise do
5075 the allocate and copy. */
5076 null_cond = gfc_conv_descriptor_data_get (src);
5077 null_cond = convert (pvoid_type_node, null_cond);
5078 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5080 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5084 /* Recursively traverse an object of derived type, generating code to
5085 deallocate, nullify or copy allocatable components. This is the work horse
5086 function for the functions named in this enum. */
5088 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5091 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5092 tree dest, int rank, int purpose)
5096 stmtblock_t fnblock;
5097 stmtblock_t loopbody;
5107 tree null_cond = NULL_TREE;
5109 gfc_init_block (&fnblock);
5111 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5112 decl = build_fold_indirect_ref (decl);
5114 /* If this an array of derived types with allocatable components
5115 build a loop and recursively call this function. */
5116 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5117 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5119 tmp = gfc_conv_array_data (decl);
5120 var = build_fold_indirect_ref (tmp);
5122 /* Get the number of elements - 1 and set the counter. */
5123 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5125 /* Use the descriptor for an allocatable array. Since this
5126 is a full array reference, we only need the descriptor
5127 information from dimension = rank. */
5128 tmp = get_full_array_size (&fnblock, decl, rank);
5129 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
5130 tmp, gfc_index_one_node);
5132 null_cond = gfc_conv_descriptor_data_get (decl);
5133 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5134 build_int_cst (TREE_TYPE (null_cond), 0));
5138 /* Otherwise use the TYPE_DOMAIN information. */
5139 tmp = array_type_nelts (TREE_TYPE (decl));
5140 tmp = fold_convert (gfc_array_index_type, tmp);
5143 /* Remember that this is, in fact, the no. of elements - 1. */
5144 nelems = gfc_evaluate_now (tmp, &fnblock);
5145 index = gfc_create_var (gfc_array_index_type, "S");
5147 /* Build the body of the loop. */
5148 gfc_init_block (&loopbody);
5150 vref = gfc_build_array_ref (var, index);
5152 if (purpose == COPY_ALLOC_COMP)
5154 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5155 gfc_add_expr_to_block (&fnblock, tmp);
5157 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5158 dref = gfc_build_array_ref (tmp, index);
5159 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5162 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5164 gfc_add_expr_to_block (&loopbody, tmp);
5166 /* Build the loop and return. */
5167 gfc_init_loopinfo (&loop);
5169 loop.from[0] = gfc_index_zero_node;
5170 loop.loopvar[0] = index;
5171 loop.to[0] = nelems;
5172 gfc_trans_scalarizing_loops (&loop, &loopbody);
5173 gfc_add_block_to_block (&fnblock, &loop.pre);
5175 tmp = gfc_finish_block (&fnblock);
5176 if (null_cond != NULL_TREE)
5177 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5182 /* Otherwise, act on the components or recursively call self to
5183 act on a chain of components. */
5184 for (c = der_type->components; c; c = c->next)
5186 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5187 && c->ts.derived->attr.alloc_comp;
5188 cdecl = c->backend_decl;
5189 ctype = TREE_TYPE (cdecl);
5193 case DEALLOCATE_ALLOC_COMP:
5194 /* Do not deallocate the components of ultimate pointer
5196 if (cmp_has_alloc_comps && !c->pointer)
5198 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5199 rank = c->as ? c->as->rank : 0;
5200 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5202 gfc_add_expr_to_block (&fnblock, tmp);
5207 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5208 tmp = gfc_trans_dealloc_allocated (comp);
5209 gfc_add_expr_to_block (&fnblock, tmp);
5213 case NULLIFY_ALLOC_COMP:
5216 else if (c->allocatable)
5218 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5219 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5221 else if (cmp_has_alloc_comps)
5223 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5224 rank = c->as ? c->as->rank : 0;
5225 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5227 gfc_add_expr_to_block (&fnblock, tmp);
5231 case COPY_ALLOC_COMP:
5235 /* We need source and destination components. */
5236 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5237 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5238 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5240 if (c->allocatable && !cmp_has_alloc_comps)
5242 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5243 gfc_add_expr_to_block (&fnblock, tmp);
5246 if (cmp_has_alloc_comps)
5248 rank = c->as ? c->as->rank : 0;
5249 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5250 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5251 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5253 gfc_add_expr_to_block (&fnblock, tmp);
5263 return gfc_finish_block (&fnblock);
5266 /* Recursively traverse an object of derived type, generating code to
5267 nullify allocatable components. */
5270 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5272 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5273 NULLIFY_ALLOC_COMP);
5277 /* Recursively traverse an object of derived type, generating code to
5278 deallocate allocatable components. */
5281 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5283 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5284 DEALLOCATE_ALLOC_COMP);
5288 /* Recursively traverse an object of derived type, generating code to
5289 copy its allocatable components. */
5292 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5294 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5298 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5299 Do likewise, recursively if necessary, with the allocatable components of
5303 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5308 stmtblock_t fnblock;
5311 bool sym_has_alloc_comp;
5313 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5314 && sym->ts.derived->attr.alloc_comp;
5316 /* Make sure the frontend gets these right. */
5317 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5318 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5319 "allocatable attribute or derived type without allocatable "
5322 gfc_init_block (&fnblock);
5324 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5325 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5327 if (sym->ts.type == BT_CHARACTER
5328 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5330 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5331 gfc_trans_vla_type_sizes (sym, &fnblock);
5334 /* Dummy and use associated variables don't need anything special. */
5335 if (sym->attr.dummy || sym->attr.use_assoc)
5337 gfc_add_expr_to_block (&fnblock, body);
5339 return gfc_finish_block (&fnblock);
5342 gfc_get_backend_locus (&loc);
5343 gfc_set_backend_locus (&sym->declared_at);
5344 descriptor = sym->backend_decl;
5346 /* Although static, derived types with default initializers and
5347 allocatable components must not be nulled wholesale; instead they
5348 are treated component by component. */
5349 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5351 /* SAVEd variables are not freed on exit. */
5352 gfc_trans_static_array_pointer (sym);
5356 /* Get the descriptor type. */
5357 type = TREE_TYPE (sym->backend_decl);
5359 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5361 if (!sym->attr.save)
5363 rank = sym->as ? sym->as->rank : 0;
5364 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5365 gfc_add_expr_to_block (&fnblock, tmp);
5368 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5370 /* If the backend_decl is not a descriptor, we must have a pointer
5372 descriptor = build_fold_indirect_ref (sym->backend_decl);
5373 type = TREE_TYPE (descriptor);
5376 /* NULLIFY the data pointer. */
5377 if (GFC_DESCRIPTOR_TYPE_P (type))
5378 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5380 gfc_add_expr_to_block (&fnblock, body);
5382 gfc_set_backend_locus (&loc);
5384 /* Allocatable arrays need to be freed when they go out of scope.
5385 The allocatable components of pointers must not be touched. */
5386 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5387 && !sym->attr.pointer && !sym->attr.save)
5390 rank = sym->as ? sym->as->rank : 0;
5391 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5392 gfc_add_expr_to_block (&fnblock, tmp);
5395 if (sym->attr.allocatable)
5397 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5398 gfc_add_expr_to_block (&fnblock, tmp);
5401 return gfc_finish_block (&fnblock);
5404 /************ Expression Walking Functions ******************/
5406 /* Walk a variable reference.
5408 Possible extension - multiple component subscripts.
5409 x(:,:) = foo%a(:)%b(:)
5411 forall (i=..., j=...)
5412 x(i,j) = foo%a(j)%b(i)
5414 This adds a fair amount of complexity because you need to deal with more
5415 than one ref. Maybe handle in a similar manner to vector subscripts.
5416 Maybe not worth the effort. */
5420 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5428 for (ref = expr->ref; ref; ref = ref->next)
5429 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5432 for (; ref; ref = ref->next)
5434 if (ref->type == REF_SUBSTRING)
5436 newss = gfc_get_ss ();
5437 newss->type = GFC_SS_SCALAR;
5438 newss->expr = ref->u.ss.start;
5442 newss = gfc_get_ss ();
5443 newss->type = GFC_SS_SCALAR;
5444 newss->expr = ref->u.ss.end;
5449 /* We're only interested in array sections from now on. */
5450 if (ref->type != REF_ARRAY)
5457 for (n = 0; n < ar->dimen; n++)
5459 newss = gfc_get_ss ();
5460 newss->type = GFC_SS_SCALAR;
5461 newss->expr = ar->start[n];
5468 newss = gfc_get_ss ();
5469 newss->type = GFC_SS_SECTION;
5472 newss->data.info.dimen = ar->as->rank;
5473 newss->data.info.ref = ref;
5475 /* Make sure array is the same as array(:,:), this way
5476 we don't need to special case all the time. */
5477 ar->dimen = ar->as->rank;
5478 for (n = 0; n < ar->dimen; n++)
5480 newss->data.info.dim[n] = n;
5481 ar->dimen_type[n] = DIMEN_RANGE;
5483 gcc_assert (ar->start[n] == NULL);
5484 gcc_assert (ar->end[n] == NULL);
5485 gcc_assert (ar->stride[n] == NULL);
5491 newss = gfc_get_ss ();
5492 newss->type = GFC_SS_SECTION;
5495 newss->data.info.dimen = 0;
5496 newss->data.info.ref = ref;
5500 /* We add SS chains for all the subscripts in the section. */
5501 for (n = 0; n < ar->dimen; n++)
5505 switch (ar->dimen_type[n])
5508 /* Add SS for elemental (scalar) subscripts. */
5509 gcc_assert (ar->start[n]);
5510 indexss = gfc_get_ss ();
5511 indexss->type = GFC_SS_SCALAR;
5512 indexss->expr = ar->start[n];
5513 indexss->next = gfc_ss_terminator;
5514 indexss->loop_chain = gfc_ss_terminator;
5515 newss->data.info.subscript[n] = indexss;
5519 /* We don't add anything for sections, just remember this
5520 dimension for later. */
5521 newss->data.info.dim[newss->data.info.dimen] = n;
5522 newss->data.info.dimen++;
5526 /* Create a GFC_SS_VECTOR index in which we can store
5527 the vector's descriptor. */
5528 indexss = gfc_get_ss ();
5529 indexss->type = GFC_SS_VECTOR;
5530 indexss->expr = ar->start[n];
5531 indexss->next = gfc_ss_terminator;
5532 indexss->loop_chain = gfc_ss_terminator;
5533 newss->data.info.subscript[n] = indexss;
5534 newss->data.info.dim[newss->data.info.dimen] = n;
5535 newss->data.info.dimen++;
5539 /* We should know what sort of section it is by now. */
5543 /* We should have at least one non-elemental dimension. */
5544 gcc_assert (newss->data.info.dimen > 0);
5549 /* We should know what sort of section it is by now. */
5558 /* Walk an expression operator. If only one operand of a binary expression is
5559 scalar, we must also add the scalar term to the SS chain. */
5562 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5568 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5569 if (expr->value.op.op2 == NULL)
5572 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5574 /* All operands are scalar. Pass back and let the caller deal with it. */
5578 /* All operands require scalarization. */
5579 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5582 /* One of the operands needs scalarization, the other is scalar.
5583 Create a gfc_ss for the scalar expression. */
5584 newss = gfc_get_ss ();
5585 newss->type = GFC_SS_SCALAR;
5588 /* First operand is scalar. We build the chain in reverse order, so
5589 add the scarar SS after the second operand. */
5591 while (head && head->next != ss)
5593 /* Check we haven't somehow broken the chain. */
5597 newss->expr = expr->value.op.op1;
5599 else /* head2 == head */
5601 gcc_assert (head2 == head);
5602 /* Second operand is scalar. */
5603 newss->next = head2;
5605 newss->expr = expr->value.op.op2;
5612 /* Reverse a SS chain. */
5615 gfc_reverse_ss (gfc_ss * ss)
5620 gcc_assert (ss != NULL);
5622 head = gfc_ss_terminator;
5623 while (ss != gfc_ss_terminator)
5626 /* Check we didn't somehow break the chain. */
5627 gcc_assert (next != NULL);
5637 /* Walk the arguments of an elemental function. */
5640 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5648 head = gfc_ss_terminator;
5651 for (; arg; arg = arg->next)
5656 newss = gfc_walk_subexpr (head, arg->expr);
5659 /* Scalar argument. */
5660 newss = gfc_get_ss ();
5662 newss->expr = arg->expr;
5672 while (tail->next != gfc_ss_terminator)
5679 /* If all the arguments are scalar we don't need the argument SS. */
5680 gfc_free_ss_chain (head);
5685 /* Add it onto the existing chain. */
5691 /* Walk a function call. Scalar functions are passed back, and taken out of
5692 scalarization loops. For elemental functions we walk their arguments.
5693 The result of functions returning arrays is stored in a temporary outside
5694 the loop, so that the function is only called once. Hence we do not need
5695 to walk their arguments. */
5698 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5701 gfc_intrinsic_sym *isym;
5704 isym = expr->value.function.isym;
5706 /* Handle intrinsic functions separately. */
5708 return gfc_walk_intrinsic_function (ss, expr, isym);
5710 sym = expr->value.function.esym;
5712 sym = expr->symtree->n.sym;
5714 /* A function that returns arrays. */
5715 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5717 newss = gfc_get_ss ();
5718 newss->type = GFC_SS_FUNCTION;
5721 newss->data.info.dimen = expr->rank;
5725 /* Walk the parameters of an elemental function. For now we always pass
5727 if (sym->attr.elemental)
5728 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5731 /* Scalar functions are OK as these are evaluated outside the scalarization
5732 loop. Pass back and let the caller deal with it. */
5737 /* An array temporary is constructed for array constructors. */
5740 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5745 newss = gfc_get_ss ();
5746 newss->type = GFC_SS_CONSTRUCTOR;
5749 newss->data.info.dimen = expr->rank;
5750 for (n = 0; n < expr->rank; n++)
5751 newss->data.info.dim[n] = n;
5757 /* Walk an expression. Add walked expressions to the head of the SS chain.
5758 A wholly scalar expression will not be added. */
5761 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5765 switch (expr->expr_type)
5768 head = gfc_walk_variable_expr (ss, expr);
5772 head = gfc_walk_op_expr (ss, expr);
5776 head = gfc_walk_function_expr (ss, expr);
5781 case EXPR_STRUCTURE:
5782 /* Pass back and let the caller deal with it. */
5786 head = gfc_walk_array_constructor (ss, expr);
5789 case EXPR_SUBSTRING:
5790 /* Pass back and let the caller deal with it. */
5794 internal_error ("bad expression type during walk (%d)",
5801 /* Entry point for expression walking.
5802 A return value equal to the passed chain means this is
5803 a scalar expression. It is up to the caller to take whatever action is
5804 necessary to translate these. */
5807 gfc_walk_expr (gfc_expr * expr)
5811 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5812 return gfc_reverse_ss (res);