1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set_tuples. */
167 gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
168 tree desc, tree value,
173 type = TREE_TYPE (desc);
174 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
176 field = TYPE_FIELDS (type);
177 gcc_assert (DATA_FIELD == 0);
179 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
180 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc)
192 type = TREE_TYPE (desc);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
195 field = TYPE_FIELDS (type);
196 gcc_assert (DATA_FIELD == 0);
198 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
199 return build_fold_addr_expr (t);
203 gfc_conv_descriptor_offset (tree desc)
208 type = TREE_TYPE (desc);
209 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
211 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
212 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
214 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
218 gfc_conv_descriptor_dtype (tree desc)
223 type = TREE_TYPE (desc);
224 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
226 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
227 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
229 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
233 gfc_conv_descriptor_dimension (tree desc, tree dim)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
243 gcc_assert (field != NULL_TREE
244 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
247 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
248 tmp = gfc_build_array_ref (tmp, dim);
253 gfc_conv_descriptor_stride (tree desc, tree dim)
258 tmp = gfc_conv_descriptor_dimension (desc, dim);
259 field = TYPE_FIELDS (TREE_TYPE (tmp));
260 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
261 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
263 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
268 gfc_conv_descriptor_lbound (tree desc, tree dim)
273 tmp = gfc_conv_descriptor_dimension (desc, dim);
274 field = TYPE_FIELDS (TREE_TYPE (tmp));
275 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
276 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
278 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
283 gfc_conv_descriptor_ubound (tree desc, tree dim)
288 tmp = gfc_conv_descriptor_dimension (desc, dim);
289 field = TYPE_FIELDS (TREE_TYPE (tmp));
290 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
291 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
293 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
298 /* Build a null array descriptor constructor. */
301 gfc_build_null_descriptor (tree type)
306 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
307 gcc_assert (DATA_FIELD == 0);
308 field = TYPE_FIELDS (type);
310 /* Set a NULL data pointer. */
311 tmp = build_constructor_single (type, field, null_pointer_node);
312 TREE_CONSTANT (tmp) = 1;
313 TREE_INVARIANT (tmp) = 1;
314 /* All other fields are ignored. */
320 /* Cleanup those #defines. */
325 #undef DIMENSION_FIELD
326 #undef STRIDE_SUBFIELD
327 #undef LBOUND_SUBFIELD
328 #undef UBOUND_SUBFIELD
331 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
332 flags & 1 = Main loop body.
333 flags & 2 = temp copy loop. */
336 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
338 for (; ss != gfc_ss_terminator; ss = ss->next)
339 ss->useflags = flags;
342 static void gfc_free_ss (gfc_ss *);
345 /* Free a gfc_ss chain. */
348 gfc_free_ss_chain (gfc_ss * ss)
352 while (ss != gfc_ss_terminator)
354 gcc_assert (ss != NULL);
365 gfc_free_ss (gfc_ss * ss)
372 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
374 if (ss->data.info.subscript[n])
375 gfc_free_ss_chain (ss->data.info.subscript[n]);
387 /* Free all the SS associated with a loop. */
390 gfc_cleanup_loop (gfc_loopinfo * loop)
396 while (ss != gfc_ss_terminator)
398 gcc_assert (ss != NULL);
399 next = ss->loop_chain;
406 /* Associate a SS chain with a loop. */
409 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
413 if (head == gfc_ss_terminator)
417 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
419 if (ss->next == gfc_ss_terminator)
420 ss->loop_chain = loop->ss;
422 ss->loop_chain = ss->next;
424 gcc_assert (ss == gfc_ss_terminator);
429 /* Generate an initializer for a static pointer or allocatable array. */
432 gfc_trans_static_array_pointer (gfc_symbol * sym)
436 gcc_assert (TREE_STATIC (sym->backend_decl));
437 /* Just zero the data member. */
438 type = TREE_TYPE (sym->backend_decl);
439 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
443 /* If the bounds of SE's loop have not yet been set, see if they can be
444 determined from array spec AS, which is the array spec of a called
445 function. MAPPING maps the callee's dummy arguments to the values
446 that the caller is passing. Add any initialization and finalization
450 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
451 gfc_se * se, gfc_array_spec * as)
459 if (as && as->type == AS_EXPLICIT)
460 for (dim = 0; dim < se->loop->dimen; dim++)
462 n = se->loop->order[dim];
463 if (se->loop->to[n] == NULL_TREE)
465 /* Evaluate the lower bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* ...and the upper bound. */
473 gfc_init_se (&tmpse, NULL);
474 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
475 gfc_add_block_to_block (&se->pre, &tmpse.pre);
476 gfc_add_block_to_block (&se->post, &tmpse.post);
479 /* Set the upper bound of the loop to UPPER - LOWER. */
480 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
481 tmp = gfc_evaluate_now (tmp, &se->pre);
482 se->loop->to[n] = tmp;
488 /* Generate code to allocate an array temporary, or create a variable to
489 hold the data. If size is NULL, zero the descriptor so that the
490 callee will allocate the array. If DEALLOC is true, also generate code to
491 free the array afterwards.
493 Initialization code is added to PRE and finalization code to POST.
494 DYNAMIC is true if the caller may want to extend the array later
495 using realloc. This prevents us from putting the array on the stack. */
498 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
499 gfc_ss_info * info, tree size, tree nelem,
500 bool dynamic, bool dealloc)
506 desc = info->descriptor;
507 info->offset = gfc_index_zero_node;
508 if (size == NULL_TREE || integer_zerop (size))
510 /* A callee allocated array. */
511 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
516 /* Allocate the temporary. */
517 onstack = !dynamic && gfc_can_put_var_on_stack (size);
521 /* Make a temporary variable to hold the data. */
522 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
524 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
526 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
528 tmp = gfc_create_var (tmp, "A");
529 tmp = build_fold_addr_expr (tmp);
530 gfc_conv_descriptor_data_set (pre, desc, tmp);
534 /* Allocate memory to hold the data. */
535 tmp = gfc_call_malloc (pre, NULL, size);
536 tmp = gfc_evaluate_now (tmp, pre);
537 gfc_conv_descriptor_data_set (pre, desc, tmp);
540 info->data = gfc_conv_descriptor_data_get (desc);
542 /* The offset is zero because we create temporaries with a zero
544 tmp = gfc_conv_descriptor_offset (desc);
545 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
547 if (dealloc && !onstack)
549 /* Free the temporary. */
550 tmp = gfc_conv_descriptor_data_get (desc);
551 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
552 gfc_add_expr_to_block (post, tmp);
557 /* Generate code to create and initialize the descriptor for a temporary
558 array. This is used for both temporaries needed by the scalarizer, and
559 functions returning arrays. Adjusts the loop variables to be
560 zero-based, and calculates the loop bounds for callee allocated arrays.
561 Allocate the array unless it's callee allocated (we have a callee
562 allocated array if 'callee_alloc' is true, or if loop->to[n] is
563 NULL_TREE for any n). Also fills in the descriptor, data and offset
564 fields of info if known. Returns the size of the array, or NULL for a
565 callee allocated array.
567 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
571 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
572 gfc_loopinfo * loop, gfc_ss_info * info,
573 tree eltype, bool dynamic, bool dealloc,
586 gcc_assert (info->dimen > 0);
587 /* Set the lower bound to zero. */
588 for (dim = 0; dim < info->dimen; dim++)
590 n = loop->order[dim];
591 if (n < loop->temp_dim)
592 gcc_assert (integer_zerop (loop->from[n]));
595 /* Callee allocated arrays may not have a known bound yet. */
597 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
598 loop->to[n], loop->from[n]);
599 loop->from[n] = gfc_index_zero_node;
602 info->delta[dim] = gfc_index_zero_node;
603 info->start[dim] = gfc_index_zero_node;
604 info->end[dim] = gfc_index_zero_node;
605 info->stride[dim] = gfc_index_one_node;
606 info->dim[dim] = dim;
609 /* Initialize the descriptor. */
611 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
612 desc = gfc_create_var (type, "atmp");
613 GFC_DECL_PACKED_ARRAY (desc) = 1;
615 info->descriptor = desc;
616 size = gfc_index_one_node;
618 /* Fill in the array dtype. */
619 tmp = gfc_conv_descriptor_dtype (desc);
620 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
623 Fill in the bounds and stride. This is a packed array, so:
626 for (n = 0; n < rank; n++)
629 delta = ubound[n] + 1 - lbound[n];
632 size = size * sizeof(element);
637 for (n = 0; n < info->dimen; n++)
639 if (loop->to[n] == NULL_TREE)
641 /* For a callee allocated array express the loop bounds in terms
642 of the descriptor fields. */
643 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
644 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
645 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
651 /* Store the stride and bound components in the descriptor. */
652 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
653 gfc_add_modify_expr (pre, tmp, size);
655 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
656 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
658 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
659 gfc_add_modify_expr (pre, tmp, loop->to[n]);
661 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
662 loop->to[n], gfc_index_one_node);
664 /* Check whether the size for this dimension is negative. */
665 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
666 gfc_index_zero_node);
667 cond = gfc_evaluate_now (cond, pre);
672 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
674 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
675 size = gfc_evaluate_now (size, pre);
678 /* Get the size of the array. */
680 if (size && !callee_alloc)
682 /* If or_expr is true, then the extent in at least one
683 dimension is zero and the size is set to zero. */
684 size = fold_build3 (COND_EXPR, gfc_array_index_type,
685 or_expr, gfc_index_zero_node, size);
688 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
689 fold_convert (gfc_array_index_type,
690 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
698 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
701 if (info->dimen > loop->temp_dim)
702 loop->temp_dim = info->dimen;
708 /* Generate code to transpose array EXPR by creating a new descriptor
709 in which the dimension specifications have been reversed. */
712 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
714 tree dest, src, dest_index, src_index;
716 gfc_ss_info *dest_info, *src_info;
717 gfc_ss *dest_ss, *src_ss;
723 src_ss = gfc_walk_expr (expr);
726 src_info = &src_ss->data.info;
727 dest_info = &dest_ss->data.info;
728 gcc_assert (dest_info->dimen == 2);
729 gcc_assert (src_info->dimen == 2);
731 /* Get a descriptor for EXPR. */
732 gfc_init_se (&src_se, NULL);
733 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
734 gfc_add_block_to_block (&se->pre, &src_se.pre);
735 gfc_add_block_to_block (&se->post, &src_se.post);
738 /* Allocate a new descriptor for the return value. */
739 dest = gfc_create_var (TREE_TYPE (src), "atmp");
740 dest_info->descriptor = dest;
743 /* Copy across the dtype field. */
744 gfc_add_modify_expr (&se->pre,
745 gfc_conv_descriptor_dtype (dest),
746 gfc_conv_descriptor_dtype (src));
748 /* Copy the dimension information, renumbering dimension 1 to 0 and
750 for (n = 0; n < 2; n++)
752 dest_info->delta[n] = gfc_index_zero_node;
753 dest_info->start[n] = gfc_index_zero_node;
754 dest_info->end[n] = gfc_index_zero_node;
755 dest_info->stride[n] = gfc_index_one_node;
756 dest_info->dim[n] = n;
758 dest_index = gfc_rank_cst[n];
759 src_index = gfc_rank_cst[1 - n];
761 gfc_add_modify_expr (&se->pre,
762 gfc_conv_descriptor_stride (dest, dest_index),
763 gfc_conv_descriptor_stride (src, src_index));
765 gfc_add_modify_expr (&se->pre,
766 gfc_conv_descriptor_lbound (dest, dest_index),
767 gfc_conv_descriptor_lbound (src, src_index));
769 gfc_add_modify_expr (&se->pre,
770 gfc_conv_descriptor_ubound (dest, dest_index),
771 gfc_conv_descriptor_ubound (src, src_index));
775 gcc_assert (integer_zerop (loop->from[n]));
776 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
777 gfc_conv_descriptor_ubound (dest, dest_index),
778 gfc_conv_descriptor_lbound (dest, dest_index));
782 /* Copy the data pointer. */
783 dest_info->data = gfc_conv_descriptor_data_get (src);
784 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
786 /* Copy the offset. This is not changed by transposition; the top-left
787 element is still at the same offset as before, except where the loop
789 if (!integer_zerop (loop->from[0]))
790 dest_info->offset = gfc_conv_descriptor_offset (src);
792 dest_info->offset = gfc_index_zero_node;
794 gfc_add_modify_expr (&se->pre,
795 gfc_conv_descriptor_offset (dest),
798 if (dest_info->dimen > loop->temp_dim)
799 loop->temp_dim = dest_info->dimen;
803 /* Return the number of iterations in a loop that starts at START,
804 ends at END, and has step STEP. */
807 gfc_get_iteration_count (tree start, tree end, tree step)
812 type = TREE_TYPE (step);
813 tmp = fold_build2 (MINUS_EXPR, type, end, start);
814 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
815 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
816 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
817 return fold_convert (gfc_array_index_type, tmp);
821 /* Extend the data in array DESC by EXTRA elements. */
824 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
831 if (integer_zerop (extra))
834 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
836 /* Add EXTRA to the upper bound. */
837 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
838 gfc_add_modify_expr (pblock, ubound, tmp);
840 /* Get the value of the current data pointer. */
841 arg0 = gfc_conv_descriptor_data_get (desc);
843 /* Calculate the new array size. */
844 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
845 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
846 arg1 = build2 (MULT_EXPR, size_type_node, fold_convert (size_type_node, tmp),
847 fold_convert (size_type_node, size));
849 /* Call the realloc() function. */
850 tmp = gfc_call_realloc (pblock, arg0, arg1);
851 gfc_conv_descriptor_data_set (pblock, desc, tmp);
855 /* Return true if the bounds of iterator I can only be determined
859 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
861 return (i->start->expr_type != EXPR_CONSTANT
862 || i->end->expr_type != EXPR_CONSTANT
863 || i->step->expr_type != EXPR_CONSTANT);
867 /* Split the size of constructor element EXPR into the sum of two terms,
868 one of which can be determined at compile time and one of which must
869 be calculated at run time. Set *SIZE to the former and return true
870 if the latter might be nonzero. */
873 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
875 if (expr->expr_type == EXPR_ARRAY)
876 return gfc_get_array_constructor_size (size, expr->value.constructor);
877 else if (expr->rank > 0)
879 /* Calculate everything at run time. */
880 mpz_set_ui (*size, 0);
885 /* A single element. */
886 mpz_set_ui (*size, 1);
892 /* Like gfc_get_array_constructor_element_size, but applied to the whole
893 of array constructor C. */
896 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
903 mpz_set_ui (*size, 0);
908 for (; c; c = c->next)
911 if (i && gfc_iterator_has_dynamic_bounds (i))
915 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
918 /* Multiply the static part of the element size by the
919 number of iterations. */
920 mpz_sub (val, i->end->value.integer, i->start->value.integer);
921 mpz_fdiv_q (val, val, i->step->value.integer);
922 mpz_add_ui (val, val, 1);
923 if (mpz_sgn (val) > 0)
924 mpz_mul (len, len, val);
928 mpz_add (*size, *size, len);
937 /* Make sure offset is a variable. */
940 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
943 /* We should have already created the offset variable. We cannot
944 create it here because we may be in an inner scope. */
945 gcc_assert (*offsetvar != NULL_TREE);
946 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
947 *poffset = *offsetvar;
948 TREE_USED (*offsetvar) = 1;
952 /* Assign an element of an array constructor. */
955 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
956 tree offset, gfc_se * se, gfc_expr * expr)
960 gfc_conv_expr (se, expr);
962 /* Store the value. */
963 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
964 tmp = gfc_build_array_ref (tmp, offset);
965 if (expr->ts.type == BT_CHARACTER)
967 gfc_conv_string_parameter (se);
968 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
970 /* The temporary is an array of pointers. */
971 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
972 gfc_add_modify_expr (&se->pre, tmp, se->expr);
976 /* The temporary is an array of string values. */
977 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
978 /* We know the temporary and the value will be the same length,
979 so can use memcpy. */
980 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
981 tmp, se->expr, se->string_length);
982 gfc_add_expr_to_block (&se->pre, tmp);
987 /* TODO: Should the frontend already have done this conversion? */
988 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
989 gfc_add_modify_expr (&se->pre, tmp, se->expr);
992 gfc_add_block_to_block (pblock, &se->pre);
993 gfc_add_block_to_block (pblock, &se->post);
997 /* Add the contents of an array to the constructor. DYNAMIC is as for
998 gfc_trans_array_constructor_value. */
1001 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1002 tree type ATTRIBUTE_UNUSED,
1003 tree desc, gfc_expr * expr,
1004 tree * poffset, tree * offsetvar,
1015 /* We need this to be a variable so we can increment it. */
1016 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1018 gfc_init_se (&se, NULL);
1020 /* Walk the array expression. */
1021 ss = gfc_walk_expr (expr);
1022 gcc_assert (ss != gfc_ss_terminator);
1024 /* Initialize the scalarizer. */
1025 gfc_init_loopinfo (&loop);
1026 gfc_add_ss_to_loop (&loop, ss);
1028 /* Initialize the loop. */
1029 gfc_conv_ss_startstride (&loop);
1030 gfc_conv_loop_setup (&loop);
1032 /* Make sure the constructed array has room for the new data. */
1035 /* Set SIZE to the total number of elements in the subarray. */
1036 size = gfc_index_one_node;
1037 for (n = 0; n < loop.dimen; n++)
1039 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1040 gfc_index_one_node);
1041 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1044 /* Grow the constructed array by SIZE elements. */
1045 gfc_grow_array (&loop.pre, desc, size);
1048 /* Make the loop body. */
1049 gfc_mark_ss_chain_used (ss, 1);
1050 gfc_start_scalarized_body (&loop, &body);
1051 gfc_copy_loopinfo_to_se (&se, &loop);
1054 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1055 gcc_assert (se.ss == gfc_ss_terminator);
1057 /* Increment the offset. */
1058 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1059 gfc_add_modify_expr (&body, *poffset, tmp);
1061 /* Finish the loop. */
1062 gfc_trans_scalarizing_loops (&loop, &body);
1063 gfc_add_block_to_block (&loop.pre, &loop.post);
1064 tmp = gfc_finish_block (&loop.pre);
1065 gfc_add_expr_to_block (pblock, tmp);
1067 gfc_cleanup_loop (&loop);
1071 /* Assign the values to the elements of an array constructor. DYNAMIC
1072 is true if descriptor DESC only contains enough data for the static
1073 size calculated by gfc_get_array_constructor_size. When true, memory
1074 for the dynamic parts must be allocated using realloc. */
1077 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1078 tree desc, gfc_constructor * c,
1079 tree * poffset, tree * offsetvar,
1088 for (; c; c = c->next)
1090 /* If this is an iterator or an array, the offset must be a variable. */
1091 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1092 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1094 gfc_start_block (&body);
1096 if (c->expr->expr_type == EXPR_ARRAY)
1098 /* Array constructors can be nested. */
1099 gfc_trans_array_constructor_value (&body, type, desc,
1100 c->expr->value.constructor,
1101 poffset, offsetvar, dynamic);
1103 else if (c->expr->rank > 0)
1105 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1106 poffset, offsetvar, dynamic);
1110 /* This code really upsets the gimplifier so don't bother for now. */
1117 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1124 /* Scalar values. */
1125 gfc_init_se (&se, NULL);
1126 gfc_trans_array_ctor_element (&body, desc, *poffset,
1129 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1130 *poffset, gfc_index_one_node);
1134 /* Collect multiple scalar constants into a constructor. */
1142 /* Count the number of consecutive scalar constants. */
1143 while (p && !(p->iterator
1144 || p->expr->expr_type != EXPR_CONSTANT))
1146 gfc_init_se (&se, NULL);
1147 gfc_conv_constant (&se, p->expr);
1148 if (p->expr->ts.type == BT_CHARACTER
1149 && POINTER_TYPE_P (type))
1151 /* For constant character array constructors we build
1152 an array of pointers. */
1153 se.expr = gfc_build_addr_expr (pchar_type_node,
1157 list = tree_cons (NULL_TREE, se.expr, list);
1162 bound = build_int_cst (NULL_TREE, n - 1);
1163 /* Create an array type to hold them. */
1164 tmptype = build_range_type (gfc_array_index_type,
1165 gfc_index_zero_node, bound);
1166 tmptype = build_array_type (type, tmptype);
1168 init = build_constructor_from_list (tmptype, nreverse (list));
1169 TREE_CONSTANT (init) = 1;
1170 TREE_INVARIANT (init) = 1;
1171 TREE_STATIC (init) = 1;
1172 /* Create a static variable to hold the data. */
1173 tmp = gfc_create_var (tmptype, "data");
1174 TREE_STATIC (tmp) = 1;
1175 TREE_CONSTANT (tmp) = 1;
1176 TREE_INVARIANT (tmp) = 1;
1177 TREE_READONLY (tmp) = 1;
1178 DECL_INITIAL (tmp) = init;
1181 /* Use BUILTIN_MEMCPY to assign the values. */
1182 tmp = gfc_conv_descriptor_data_get (desc);
1183 tmp = build_fold_indirect_ref (tmp);
1184 tmp = gfc_build_array_ref (tmp, *poffset);
1185 tmp = build_fold_addr_expr (tmp);
1186 init = build_fold_addr_expr (init);
1188 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1189 bound = build_int_cst (NULL_TREE, n * size);
1190 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1192 gfc_add_expr_to_block (&body, tmp);
1194 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1196 build_int_cst (gfc_array_index_type, n));
1198 if (!INTEGER_CST_P (*poffset))
1200 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1201 *poffset = *offsetvar;
1205 /* The frontend should already have done any expansions possible
1209 /* Pass the code as is. */
1210 tmp = gfc_finish_block (&body);
1211 gfc_add_expr_to_block (pblock, tmp);
1215 /* Build the implied do-loop. */
1225 loopbody = gfc_finish_block (&body);
1227 gfc_init_se (&se, NULL);
1228 gfc_conv_expr (&se, c->iterator->var);
1229 gfc_add_block_to_block (pblock, &se.pre);
1232 /* Make a temporary, store the current value in that
1233 and return it, once the loop is done. */
1234 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1235 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1237 /* Initialize the loop. */
1238 gfc_init_se (&se, NULL);
1239 gfc_conv_expr_val (&se, c->iterator->start);
1240 gfc_add_block_to_block (pblock, &se.pre);
1241 gfc_add_modify_expr (pblock, loopvar, se.expr);
1243 gfc_init_se (&se, NULL);
1244 gfc_conv_expr_val (&se, c->iterator->end);
1245 gfc_add_block_to_block (pblock, &se.pre);
1246 end = gfc_evaluate_now (se.expr, pblock);
1248 gfc_init_se (&se, NULL);
1249 gfc_conv_expr_val (&se, c->iterator->step);
1250 gfc_add_block_to_block (pblock, &se.pre);
1251 step = gfc_evaluate_now (se.expr, pblock);
1253 /* If this array expands dynamically, and the number of iterations
1254 is not constant, we won't have allocated space for the static
1255 part of C->EXPR's size. Do that now. */
1256 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1258 /* Get the number of iterations. */
1259 tmp = gfc_get_iteration_count (loopvar, end, step);
1261 /* Get the static part of C->EXPR's size. */
1262 gfc_get_array_constructor_element_size (&size, c->expr);
1263 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1265 /* Grow the array by TMP * TMP2 elements. */
1266 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1267 gfc_grow_array (pblock, desc, tmp);
1270 /* Generate the loop body. */
1271 exit_label = gfc_build_label_decl (NULL_TREE);
1272 gfc_start_block (&body);
1274 /* Generate the exit condition. Depending on the sign of
1275 the step variable we have to generate the correct
1277 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1278 build_int_cst (TREE_TYPE (step), 0));
1279 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1280 build2 (GT_EXPR, boolean_type_node,
1282 build2 (LT_EXPR, boolean_type_node,
1284 tmp = build1_v (GOTO_EXPR, exit_label);
1285 TREE_USED (exit_label) = 1;
1286 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1287 gfc_add_expr_to_block (&body, tmp);
1289 /* The main loop body. */
1290 gfc_add_expr_to_block (&body, loopbody);
1292 /* Increase loop variable by step. */
1293 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1294 gfc_add_modify_expr (&body, loopvar, tmp);
1296 /* Finish the loop. */
1297 tmp = gfc_finish_block (&body);
1298 tmp = build1_v (LOOP_EXPR, tmp);
1299 gfc_add_expr_to_block (pblock, tmp);
1301 /* Add the exit label. */
1302 tmp = build1_v (LABEL_EXPR, exit_label);
1303 gfc_add_expr_to_block (pblock, tmp);
1305 /* Restore the original value of the loop counter. */
1306 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1313 /* Figure out the string length of a variable reference expression.
1314 Used by get_array_ctor_strlen. */
1317 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1323 /* Don't bother if we already know the length is a constant. */
1324 if (*len && INTEGER_CST_P (*len))
1327 ts = &expr->symtree->n.sym->ts;
1328 for (ref = expr->ref; ref; ref = ref->next)
1333 /* Array references don't change the string length. */
1337 /* Use the length of the component. */
1338 ts = &ref->u.c.component->ts;
1342 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1343 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1345 mpz_init_set_ui (char_len, 1);
1346 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1347 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1348 *len = gfc_conv_mpz_to_tree (char_len,
1349 gfc_default_character_kind);
1350 *len = convert (gfc_charlen_type_node, *len);
1351 mpz_clear (char_len);
1355 /* TODO: Substrings are tricky because we can't evaluate the
1356 expression more than once. For now we just give up, and hope
1357 we can figure it out elsewhere. */
1362 *len = ts->cl->backend_decl;
1366 /* A catch-all to obtain the string length for anything that is not a
1367 constant, array or variable. */
1369 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1374 /* Don't bother if we already know the length is a constant. */
1375 if (*len && INTEGER_CST_P (*len))
1378 if (!e->ref && e->ts.cl->length
1379 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1382 gfc_conv_const_charlen (e->ts.cl);
1383 *len = e->ts.cl->backend_decl;
1387 /* Otherwise, be brutal even if inefficient. */
1388 ss = gfc_walk_expr (e);
1389 gfc_init_se (&se, NULL);
1391 /* No function call, in case of side effects. */
1392 se.no_function_call = 1;
1393 if (ss == gfc_ss_terminator)
1394 gfc_conv_expr (&se, e);
1396 gfc_conv_expr_descriptor (&se, e, ss);
1398 /* Fix the value. */
1399 *len = gfc_evaluate_now (se.string_length, &se.pre);
1401 gfc_add_block_to_block (block, &se.pre);
1402 gfc_add_block_to_block (block, &se.post);
1404 e->ts.cl->backend_decl = *len;
1409 /* Figure out the string length of a character array constructor.
1410 Returns TRUE if all elements are character constants. */
1413 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1421 *len = build_int_cstu (gfc_charlen_type_node, 0);
1425 for (; c; c = c->next)
1427 switch (c->expr->expr_type)
1430 if (!(*len && INTEGER_CST_P (*len)))
1431 *len = build_int_cstu (gfc_charlen_type_node,
1432 c->expr->value.character.length);
1436 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1442 get_array_ctor_var_strlen (c->expr, len);
1447 get_array_ctor_all_strlen (block, c->expr, len);
1455 /* Check whether the array constructor C consists entirely of constant
1456 elements, and if so returns the number of those elements, otherwise
1457 return zero. Note, an empty or NULL array constructor returns zero. */
1459 unsigned HOST_WIDE_INT
1460 gfc_constant_array_constructor_p (gfc_constructor * c)
1462 unsigned HOST_WIDE_INT nelem = 0;
1467 || c->expr->rank > 0
1468 || c->expr->expr_type != EXPR_CONSTANT)
1477 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1478 and the tree type of it's elements, TYPE, return a static constant
1479 variable that is compile-time initialized. */
1482 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1484 tree tmptype, list, init, tmp;
1485 HOST_WIDE_INT nelem;
1491 /* First traverse the constructor list, converting the constants
1492 to tree to build an initializer. */
1495 c = expr->value.constructor;
1498 gfc_init_se (&se, NULL);
1499 gfc_conv_constant (&se, c->expr);
1500 if (c->expr->ts.type == BT_CHARACTER
1501 && POINTER_TYPE_P (type))
1502 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1503 list = tree_cons (NULL_TREE, se.expr, list);
1508 /* Next determine the tree type for the array. We use the gfortran
1509 front-end's gfc_get_nodesc_array_type in order to create a suitable
1510 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1512 memset (&as, 0, sizeof (gfc_array_spec));
1514 as.rank = expr->rank;
1515 as.type = AS_EXPLICIT;
1518 as.lower[0] = gfc_int_expr (0);
1519 as.upper[0] = gfc_int_expr (nelem - 1);
1522 for (i = 0; i < expr->rank; i++)
1524 int tmp = (int) mpz_get_si (expr->shape[i]);
1525 as.lower[i] = gfc_int_expr (0);
1526 as.upper[i] = gfc_int_expr (tmp - 1);
1529 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1531 init = build_constructor_from_list (tmptype, nreverse (list));
1533 TREE_CONSTANT (init) = 1;
1534 TREE_INVARIANT (init) = 1;
1535 TREE_STATIC (init) = 1;
1537 tmp = gfc_create_var (tmptype, "A");
1538 TREE_STATIC (tmp) = 1;
1539 TREE_CONSTANT (tmp) = 1;
1540 TREE_INVARIANT (tmp) = 1;
1541 TREE_READONLY (tmp) = 1;
1542 DECL_INITIAL (tmp) = init;
1548 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1549 This mostly initializes the scalarizer state info structure with the
1550 appropriate values to directly use the array created by the function
1551 gfc_build_constant_array_constructor. */
1554 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1555 gfc_ss * ss, tree type)
1561 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1563 info = &ss->data.info;
1565 info->descriptor = tmp;
1566 info->data = build_fold_addr_expr (tmp);
1567 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1570 for (i = 0; i < info->dimen; i++)
1572 info->delta[i] = gfc_index_zero_node;
1573 info->start[i] = gfc_index_zero_node;
1574 info->end[i] = gfc_index_zero_node;
1575 info->stride[i] = gfc_index_one_node;
1579 if (info->dimen > loop->temp_dim)
1580 loop->temp_dim = info->dimen;
1583 /* Helper routine of gfc_trans_array_constructor to determine if the
1584 bounds of the loop specified by LOOP are constant and simple enough
1585 to use with gfc_trans_constant_array_constructor. Returns the
1586 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1589 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1591 tree size = gfc_index_one_node;
1595 for (i = 0; i < loop->dimen; i++)
1597 /* If the bounds aren't constant, return NULL_TREE. */
1598 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1600 if (!integer_zerop (loop->from[i]))
1602 /* Only allow nonzero "from" in one-dimensional arrays. */
1603 if (loop->dimen != 1)
1605 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1606 loop->to[i], loop->from[i]);
1610 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1611 tmp, gfc_index_one_node);
1612 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1619 /* Array constructors are handled by constructing a temporary, then using that
1620 within the scalarization loop. This is not optimal, but seems by far the
1624 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1633 ss->data.info.dimen = loop->dimen;
1635 c = ss->expr->value.constructor;
1636 if (ss->expr->ts.type == BT_CHARACTER)
1638 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1639 if (!ss->string_length)
1640 gfc_todo_error ("complex character array constructors");
1642 /* It is surprising but still possible to wind up with expressions that
1643 lack a character length.
1644 TODO Find the offending part of the front end and cure this properly.
1645 Concatenation involving arrays is the main culprit. */
1646 if (!ss->expr->ts.cl)
1648 ss->expr->ts.cl = gfc_get_charlen ();
1649 ss->expr->ts.cl->next = gfc_current_ns->cl_list;
1650 gfc_current_ns->cl_list = ss->expr->ts.cl->next;
1653 ss->expr->ts.cl->backend_decl = ss->string_length;
1655 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1657 type = build_pointer_type (type);
1660 type = gfc_typenode_for_spec (&ss->expr->ts);
1662 /* See if the constructor determines the loop bounds. */
1665 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1667 /* We have a multidimensional parameter. */
1669 for (n = 0; n < ss->expr->rank; n++)
1671 loop->from[n] = gfc_index_zero_node;
1672 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1673 gfc_index_integer_kind);
1674 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1675 loop->to[n], gfc_index_one_node);
1679 if (loop->to[0] == NULL_TREE)
1683 /* We should have a 1-dimensional, zero-based loop. */
1684 gcc_assert (loop->dimen == 1);
1685 gcc_assert (integer_zerop (loop->from[0]));
1687 /* Split the constructor size into a static part and a dynamic part.
1688 Allocate the static size up-front and record whether the dynamic
1689 size might be nonzero. */
1691 dynamic = gfc_get_array_constructor_size (&size, c);
1692 mpz_sub_ui (size, size, 1);
1693 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1697 /* Special case constant array constructors. */
1700 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1703 tree size = constant_array_constructor_loop_size (loop);
1704 if (size && compare_tree_int (size, nelem) == 0)
1706 gfc_trans_constant_array_constructor (loop, ss, type);
1712 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1713 type, dynamic, true, false);
1715 desc = ss->data.info.descriptor;
1716 offset = gfc_index_zero_node;
1717 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1718 TREE_NO_WARNING (offsetvar) = 1;
1719 TREE_USED (offsetvar) = 0;
1720 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1721 &offset, &offsetvar, dynamic);
1723 /* If the array grows dynamically, the upper bound of the loop variable
1724 is determined by the array's final upper bound. */
1726 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1728 if (TREE_USED (offsetvar))
1729 pushdecl (offsetvar);
1731 gcc_assert (INTEGER_CST_P (offset));
1733 /* Disable bound checking for now because it's probably broken. */
1734 if (flag_bounds_check)
1742 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1743 called after evaluating all of INFO's vector dimensions. Go through
1744 each such vector dimension and see if we can now fill in any missing
1748 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1757 for (n = 0; n < loop->dimen; n++)
1760 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1761 && loop->to[n] == NULL)
1763 /* Loop variable N indexes vector dimension DIM, and we don't
1764 yet know the upper bound of loop variable N. Set it to the
1765 difference between the vector's upper and lower bounds. */
1766 gcc_assert (loop->from[n] == gfc_index_zero_node);
1767 gcc_assert (info->subscript[dim]
1768 && info->subscript[dim]->type == GFC_SS_VECTOR);
1770 gfc_init_se (&se, NULL);
1771 desc = info->subscript[dim]->data.info.descriptor;
1772 zero = gfc_rank_cst[0];
1773 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1774 gfc_conv_descriptor_ubound (desc, zero),
1775 gfc_conv_descriptor_lbound (desc, zero));
1776 tmp = gfc_evaluate_now (tmp, &loop->pre);
1783 /* Add the pre and post chains for all the scalar expressions in a SS chain
1784 to loop. This is called after the loop parameters have been calculated,
1785 but before the actual scalarizing loops. */
1788 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1793 /* TODO: This can generate bad code if there are ordering dependencies.
1794 eg. a callee allocated function and an unknown size constructor. */
1795 gcc_assert (ss != NULL);
1797 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1804 /* Scalar expression. Evaluate this now. This includes elemental
1805 dimension indices, but not array section bounds. */
1806 gfc_init_se (&se, NULL);
1807 gfc_conv_expr (&se, ss->expr);
1808 gfc_add_block_to_block (&loop->pre, &se.pre);
1810 if (ss->expr->ts.type != BT_CHARACTER)
1812 /* Move the evaluation of scalar expressions outside the
1813 scalarization loop. */
1815 se.expr = convert(gfc_array_index_type, se.expr);
1816 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1817 gfc_add_block_to_block (&loop->pre, &se.post);
1820 gfc_add_block_to_block (&loop->post, &se.post);
1822 ss->data.scalar.expr = se.expr;
1823 ss->string_length = se.string_length;
1826 case GFC_SS_REFERENCE:
1827 /* Scalar reference. Evaluate this now. */
1828 gfc_init_se (&se, NULL);
1829 gfc_conv_expr_reference (&se, ss->expr);
1830 gfc_add_block_to_block (&loop->pre, &se.pre);
1831 gfc_add_block_to_block (&loop->post, &se.post);
1833 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1834 ss->string_length = se.string_length;
1837 case GFC_SS_SECTION:
1838 /* Add the expressions for scalar and vector subscripts. */
1839 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1840 if (ss->data.info.subscript[n])
1841 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1843 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1847 /* Get the vector's descriptor and store it in SS. */
1848 gfc_init_se (&se, NULL);
1849 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1850 gfc_add_block_to_block (&loop->pre, &se.pre);
1851 gfc_add_block_to_block (&loop->post, &se.post);
1852 ss->data.info.descriptor = se.expr;
1855 case GFC_SS_INTRINSIC:
1856 gfc_add_intrinsic_ss_code (loop, ss);
1859 case GFC_SS_FUNCTION:
1860 /* Array function return value. We call the function and save its
1861 result in a temporary for use inside the loop. */
1862 gfc_init_se (&se, NULL);
1865 gfc_conv_expr (&se, ss->expr);
1866 gfc_add_block_to_block (&loop->pre, &se.pre);
1867 gfc_add_block_to_block (&loop->post, &se.post);
1868 ss->string_length = se.string_length;
1871 case GFC_SS_CONSTRUCTOR:
1872 gfc_trans_array_constructor (loop, ss);
1876 case GFC_SS_COMPONENT:
1877 /* Do nothing. These are handled elsewhere. */
1887 /* Translate expressions for the descriptor and data pointer of a SS. */
1891 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1896 /* Get the descriptor for the array to be scalarized. */
1897 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1898 gfc_init_se (&se, NULL);
1899 se.descriptor_only = 1;
1900 gfc_conv_expr_lhs (&se, ss->expr);
1901 gfc_add_block_to_block (block, &se.pre);
1902 ss->data.info.descriptor = se.expr;
1903 ss->string_length = se.string_length;
1907 /* Also the data pointer. */
1908 tmp = gfc_conv_array_data (se.expr);
1909 /* If this is a variable or address of a variable we use it directly.
1910 Otherwise we must evaluate it now to avoid breaking dependency
1911 analysis by pulling the expressions for elemental array indices
1914 || (TREE_CODE (tmp) == ADDR_EXPR
1915 && DECL_P (TREE_OPERAND (tmp, 0)))))
1916 tmp = gfc_evaluate_now (tmp, block);
1917 ss->data.info.data = tmp;
1919 tmp = gfc_conv_array_offset (se.expr);
1920 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1925 /* Initialize a gfc_loopinfo structure. */
1928 gfc_init_loopinfo (gfc_loopinfo * loop)
1932 memset (loop, 0, sizeof (gfc_loopinfo));
1933 gfc_init_block (&loop->pre);
1934 gfc_init_block (&loop->post);
1936 /* Initially scalarize in order. */
1937 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1940 loop->ss = gfc_ss_terminator;
1944 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1948 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1954 /* Return an expression for the data pointer of an array. */
1957 gfc_conv_array_data (tree descriptor)
1961 type = TREE_TYPE (descriptor);
1962 if (GFC_ARRAY_TYPE_P (type))
1964 if (TREE_CODE (type) == POINTER_TYPE)
1968 /* Descriptorless arrays. */
1969 return build_fold_addr_expr (descriptor);
1973 return gfc_conv_descriptor_data_get (descriptor);
1977 /* Return an expression for the base offset of an array. */
1980 gfc_conv_array_offset (tree descriptor)
1984 type = TREE_TYPE (descriptor);
1985 if (GFC_ARRAY_TYPE_P (type))
1986 return GFC_TYPE_ARRAY_OFFSET (type);
1988 return gfc_conv_descriptor_offset (descriptor);
1992 /* Get an expression for the array stride. */
1995 gfc_conv_array_stride (tree descriptor, int dim)
2000 type = TREE_TYPE (descriptor);
2002 /* For descriptorless arrays use the array size. */
2003 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2004 if (tmp != NULL_TREE)
2007 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2012 /* Like gfc_conv_array_stride, but for the lower bound. */
2015 gfc_conv_array_lbound (tree descriptor, int dim)
2020 type = TREE_TYPE (descriptor);
2022 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2023 if (tmp != NULL_TREE)
2026 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2031 /* Like gfc_conv_array_stride, but for the upper bound. */
2034 gfc_conv_array_ubound (tree descriptor, int dim)
2039 type = TREE_TYPE (descriptor);
2041 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2042 if (tmp != NULL_TREE)
2045 /* This should only ever happen when passing an assumed shape array
2046 as an actual parameter. The value will never be used. */
2047 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2048 return gfc_index_zero_node;
2050 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2055 /* Generate code to perform an array index bound check. */
2058 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2059 locus * where, bool check_upper)
2064 const char * name = NULL;
2066 if (!flag_bounds_check)
2069 index = gfc_evaluate_now (index, &se->pre);
2071 /* We find a name for the error message. */
2073 name = se->ss->expr->symtree->name;
2075 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2076 && se->loop->ss->expr->symtree)
2077 name = se->loop->ss->expr->symtree->name;
2079 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2080 && se->loop->ss->loop_chain->expr
2081 && se->loop->ss->loop_chain->expr->symtree)
2082 name = se->loop->ss->loop_chain->expr->symtree->name;
2084 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2085 && se->loop->ss->loop_chain->expr->symtree)
2086 name = se->loop->ss->loop_chain->expr->symtree->name;
2088 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2090 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2091 && se->loop->ss->expr->value.function.name)
2092 name = se->loop->ss->expr->value.function.name;
2094 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2095 || se->loop->ss->type == GFC_SS_SCALAR)
2096 name = "unnamed constant";
2099 /* Check lower bound. */
2100 tmp = gfc_conv_array_lbound (descriptor, n);
2101 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2103 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2104 gfc_msg_fault, name, n+1);
2106 asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
2107 "smaller than %%ld", gfc_msg_fault, n+1);
2108 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2109 fold_convert (long_integer_type_node, index),
2110 fold_convert (long_integer_type_node, tmp));
2113 /* Check upper bound. */
2116 tmp = gfc_conv_array_ubound (descriptor, n);
2117 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2119 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2120 " exceeded", gfc_msg_fault, name, n+1);
2122 asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
2123 "larger than %%ld", gfc_msg_fault, n+1);
2124 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2125 fold_convert (long_integer_type_node, index),
2126 fold_convert (long_integer_type_node, tmp));
2134 /* Return the offset for an index. Performs bound checking for elemental
2135 dimensions. Single element references are processed separately. */
2138 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2139 gfc_array_ref * ar, tree stride)
2145 /* Get the index into the array for this dimension. */
2148 gcc_assert (ar->type != AR_ELEMENT);
2149 switch (ar->dimen_type[dim])
2152 gcc_assert (i == -1);
2153 /* Elemental dimension. */
2154 gcc_assert (info->subscript[dim]
2155 && info->subscript[dim]->type == GFC_SS_SCALAR);
2156 /* We've already translated this value outside the loop. */
2157 index = info->subscript[dim]->data.scalar.expr;
2159 index = gfc_trans_array_bound_check (se, info->descriptor,
2160 index, dim, &ar->where,
2161 (ar->as->type != AS_ASSUMED_SIZE
2162 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2166 gcc_assert (info && se->loop);
2167 gcc_assert (info->subscript[dim]
2168 && info->subscript[dim]->type == GFC_SS_VECTOR);
2169 desc = info->subscript[dim]->data.info.descriptor;
2171 /* Get a zero-based index into the vector. */
2172 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2173 se->loop->loopvar[i], se->loop->from[i]);
2175 /* Multiply the index by the stride. */
2176 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2177 index, gfc_conv_array_stride (desc, 0));
2179 /* Read the vector to get an index into info->descriptor. */
2180 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2181 index = gfc_build_array_ref (data, index);
2182 index = gfc_evaluate_now (index, &se->pre);
2184 /* Do any bounds checking on the final info->descriptor index. */
2185 index = gfc_trans_array_bound_check (se, info->descriptor,
2186 index, dim, &ar->where,
2187 (ar->as->type != AS_ASSUMED_SIZE
2188 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2192 /* Scalarized dimension. */
2193 gcc_assert (info && se->loop);
2195 /* Multiply the loop variable by the stride and delta. */
2196 index = se->loop->loopvar[i];
2197 if (!integer_onep (info->stride[i]))
2198 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2200 if (!integer_zerop (info->delta[i]))
2201 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2211 /* Temporary array or derived type component. */
2212 gcc_assert (se->loop);
2213 index = se->loop->loopvar[se->loop->order[i]];
2214 if (!integer_zerop (info->delta[i]))
2215 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2216 index, info->delta[i]);
2219 /* Multiply by the stride. */
2220 if (!integer_onep (stride))
2221 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2227 /* Build a scalarized reference to an array. */
2230 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2237 info = &se->ss->data.info;
2239 n = se->loop->order[0];
2243 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2245 /* Add the offset for this dimension to the stored offset for all other
2247 if (!integer_zerop (info->offset))
2248 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2250 tmp = build_fold_indirect_ref (info->data);
2251 se->expr = gfc_build_array_ref (tmp, index);
2255 /* Translate access of temporary array. */
2258 gfc_conv_tmp_array_ref (gfc_se * se)
2260 se->string_length = se->ss->string_length;
2261 gfc_conv_scalarized_array_ref (se, NULL);
2265 /* Build an array reference. se->expr already holds the array descriptor.
2266 This should be either a variable, indirect variable reference or component
2267 reference. For arrays which do not have a descriptor, se->expr will be
2269 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2272 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2281 /* Handle scalarized references separately. */
2282 if (ar->type != AR_ELEMENT)
2284 gfc_conv_scalarized_array_ref (se, ar);
2285 gfc_advance_se_ss_chain (se);
2289 index = gfc_index_zero_node;
2291 /* Calculate the offsets from all the dimensions. */
2292 for (n = 0; n < ar->dimen; n++)
2294 /* Calculate the index for this dimension. */
2295 gfc_init_se (&indexse, se);
2296 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2297 gfc_add_block_to_block (&se->pre, &indexse.pre);
2299 if (flag_bounds_check)
2301 /* Check array bounds. */
2305 /* Evaluate the indexse.expr only once. */
2306 indexse.expr = save_expr (indexse.expr);
2309 tmp = gfc_conv_array_lbound (se->expr, n);
2310 cond = fold_build2 (LT_EXPR, boolean_type_node,
2312 asprintf (&msg, "%s for array '%s', "
2313 "lower bound of dimension %d exceeded, %%ld is smaller "
2314 "than %%ld", gfc_msg_fault, sym->name, n+1);
2315 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2316 fold_convert (long_integer_type_node,
2318 fold_convert (long_integer_type_node, tmp));
2321 /* Upper bound, but not for the last dimension of assumed-size
2323 if (n < ar->dimen - 1
2324 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2326 tmp = gfc_conv_array_ubound (se->expr, n);
2327 cond = fold_build2 (GT_EXPR, boolean_type_node,
2329 asprintf (&msg, "%s for array '%s', "
2330 "upper bound of dimension %d exceeded, %%ld is "
2331 "greater than %%ld", gfc_msg_fault, sym->name, n+1);
2332 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2333 fold_convert (long_integer_type_node,
2335 fold_convert (long_integer_type_node, tmp));
2340 /* Multiply the index by the stride. */
2341 stride = gfc_conv_array_stride (se->expr, n);
2342 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2345 /* And add it to the total. */
2346 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2349 tmp = gfc_conv_array_offset (se->expr);
2350 if (!integer_zerop (tmp))
2351 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2353 /* Access the calculated element. */
2354 tmp = gfc_conv_array_data (se->expr);
2355 tmp = build_fold_indirect_ref (tmp);
2356 se->expr = gfc_build_array_ref (tmp, index);
2360 /* Generate the code to be executed immediately before entering a
2361 scalarization loop. */
2364 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2365 stmtblock_t * pblock)
2374 /* This code will be executed before entering the scalarization loop
2375 for this dimension. */
2376 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2378 if ((ss->useflags & flag) == 0)
2381 if (ss->type != GFC_SS_SECTION
2382 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2383 && ss->type != GFC_SS_COMPONENT)
2386 info = &ss->data.info;
2388 if (dim >= info->dimen)
2391 if (dim == info->dimen - 1)
2393 /* For the outermost loop calculate the offset due to any
2394 elemental dimensions. It will have been initialized with the
2395 base offset of the array. */
2398 for (i = 0; i < info->ref->u.ar.dimen; i++)
2400 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2403 gfc_init_se (&se, NULL);
2405 se.expr = info->descriptor;
2406 stride = gfc_conv_array_stride (info->descriptor, i);
2407 index = gfc_conv_array_index_offset (&se, info, i, -1,
2410 gfc_add_block_to_block (pblock, &se.pre);
2412 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2413 info->offset, index);
2414 info->offset = gfc_evaluate_now (info->offset, pblock);
2418 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2421 stride = gfc_conv_array_stride (info->descriptor, 0);
2423 /* Calculate the stride of the innermost loop. Hopefully this will
2424 allow the backend optimizers to do their stuff more effectively.
2426 info->stride0 = gfc_evaluate_now (stride, pblock);
2430 /* Add the offset for the previous loop dimension. */
2435 ar = &info->ref->u.ar;
2436 i = loop->order[dim + 1];
2444 gfc_init_se (&se, NULL);
2446 se.expr = info->descriptor;
2447 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2448 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2450 gfc_add_block_to_block (pblock, &se.pre);
2451 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2452 info->offset, index);
2453 info->offset = gfc_evaluate_now (info->offset, pblock);
2456 /* Remember this offset for the second loop. */
2457 if (dim == loop->temp_dim - 1)
2458 info->saved_offset = info->offset;
2463 /* Start a scalarized expression. Creates a scope and declares loop
2467 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2473 gcc_assert (!loop->array_parameter);
2475 for (dim = loop->dimen - 1; dim >= 0; dim--)
2477 n = loop->order[dim];
2479 gfc_start_block (&loop->code[n]);
2481 /* Create the loop variable. */
2482 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2484 if (dim < loop->temp_dim)
2488 /* Calculate values that will be constant within this loop. */
2489 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2491 gfc_start_block (pbody);
2495 /* Generates the actual loop code for a scalarization loop. */
2498 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2499 stmtblock_t * pbody)
2507 loopbody = gfc_finish_block (pbody);
2509 /* Initialize the loopvar. */
2510 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2512 exit_label = gfc_build_label_decl (NULL_TREE);
2514 /* Generate the loop body. */
2515 gfc_init_block (&block);
2517 /* The exit condition. */
2518 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2519 tmp = build1_v (GOTO_EXPR, exit_label);
2520 TREE_USED (exit_label) = 1;
2521 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2522 gfc_add_expr_to_block (&block, tmp);
2524 /* The main body. */
2525 gfc_add_expr_to_block (&block, loopbody);
2527 /* Increment the loopvar. */
2528 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2529 loop->loopvar[n], gfc_index_one_node);
2530 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2532 /* Build the loop. */
2533 tmp = gfc_finish_block (&block);
2534 tmp = build1_v (LOOP_EXPR, tmp);
2535 gfc_add_expr_to_block (&loop->code[n], tmp);
2537 /* Add the exit label. */
2538 tmp = build1_v (LABEL_EXPR, exit_label);
2539 gfc_add_expr_to_block (&loop->code[n], tmp);
2543 /* Finishes and generates the loops for a scalarized expression. */
2546 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2551 stmtblock_t *pblock;
2555 /* Generate the loops. */
2556 for (dim = 0; dim < loop->dimen; dim++)
2558 n = loop->order[dim];
2559 gfc_trans_scalarized_loop_end (loop, n, pblock);
2560 loop->loopvar[n] = NULL_TREE;
2561 pblock = &loop->code[n];
2564 tmp = gfc_finish_block (pblock);
2565 gfc_add_expr_to_block (&loop->pre, tmp);
2567 /* Clear all the used flags. */
2568 for (ss = loop->ss; ss; ss = ss->loop_chain)
2573 /* Finish the main body of a scalarized expression, and start the secondary
2577 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2581 stmtblock_t *pblock;
2585 /* We finish as many loops as are used by the temporary. */
2586 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2588 n = loop->order[dim];
2589 gfc_trans_scalarized_loop_end (loop, n, pblock);
2590 loop->loopvar[n] = NULL_TREE;
2591 pblock = &loop->code[n];
2594 /* We don't want to finish the outermost loop entirely. */
2595 n = loop->order[loop->temp_dim - 1];
2596 gfc_trans_scalarized_loop_end (loop, n, pblock);
2598 /* Restore the initial offsets. */
2599 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2601 if ((ss->useflags & 2) == 0)
2604 if (ss->type != GFC_SS_SECTION
2605 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2606 && ss->type != GFC_SS_COMPONENT)
2609 ss->data.info.offset = ss->data.info.saved_offset;
2612 /* Restart all the inner loops we just finished. */
2613 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2615 n = loop->order[dim];
2617 gfc_start_block (&loop->code[n]);
2619 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2621 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2624 /* Start a block for the secondary copying code. */
2625 gfc_start_block (body);
2629 /* Calculate the upper bound of an array section. */
2632 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2641 gcc_assert (ss->type == GFC_SS_SECTION);
2643 info = &ss->data.info;
2646 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2647 /* We'll calculate the upper bound once we have access to the
2648 vector's descriptor. */
2651 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2652 desc = info->descriptor;
2653 end = info->ref->u.ar.end[dim];
2657 /* The upper bound was specified. */
2658 gfc_init_se (&se, NULL);
2659 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2660 gfc_add_block_to_block (pblock, &se.pre);
2665 /* No upper bound was specified, so use the bound of the array. */
2666 bound = gfc_conv_array_ubound (desc, dim);
2673 /* Calculate the lower bound of an array section. */
2676 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2686 gcc_assert (ss->type == GFC_SS_SECTION);
2688 info = &ss->data.info;
2691 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2693 /* We use a zero-based index to access the vector. */
2694 info->start[n] = gfc_index_zero_node;
2695 info->end[n] = gfc_index_zero_node;
2696 info->stride[n] = gfc_index_one_node;
2700 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2701 desc = info->descriptor;
2702 start = info->ref->u.ar.start[dim];
2703 end = info->ref->u.ar.end[dim];
2704 stride = info->ref->u.ar.stride[dim];
2706 /* Calculate the start of the range. For vector subscripts this will
2707 be the range of the vector. */
2710 /* Specified section start. */
2711 gfc_init_se (&se, NULL);
2712 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2713 gfc_add_block_to_block (&loop->pre, &se.pre);
2714 info->start[n] = se.expr;
2718 /* No lower bound specified so use the bound of the array. */
2719 info->start[n] = gfc_conv_array_lbound (desc, dim);
2721 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2723 /* Similarly calculate the end. Although this is not used in the
2724 scalarizer, it is needed when checking bounds and where the end
2725 is an expression with side-effects. */
2728 /* Specified section start. */
2729 gfc_init_se (&se, NULL);
2730 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2731 gfc_add_block_to_block (&loop->pre, &se.pre);
2732 info->end[n] = se.expr;
2736 /* No upper bound specified so use the bound of the array. */
2737 info->end[n] = gfc_conv_array_ubound (desc, dim);
2739 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2741 /* Calculate the stride. */
2743 info->stride[n] = gfc_index_one_node;
2746 gfc_init_se (&se, NULL);
2747 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2748 gfc_add_block_to_block (&loop->pre, &se.pre);
2749 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2754 /* Calculates the range start and stride for a SS chain. Also gets the
2755 descriptor and data pointer. The range of vector subscripts is the size
2756 of the vector. Array bounds are also checked. */
2759 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2767 /* Determine the rank of the loop. */
2769 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2773 case GFC_SS_SECTION:
2774 case GFC_SS_CONSTRUCTOR:
2775 case GFC_SS_FUNCTION:
2776 case GFC_SS_COMPONENT:
2777 loop->dimen = ss->data.info.dimen;
2780 /* As usual, lbound and ubound are exceptions!. */
2781 case GFC_SS_INTRINSIC:
2782 switch (ss->expr->value.function.isym->id)
2784 case GFC_ISYM_LBOUND:
2785 case GFC_ISYM_UBOUND:
2786 loop->dimen = ss->data.info.dimen;
2797 if (loop->dimen == 0)
2798 gfc_todo_error ("Unable to determine rank of expression");
2801 /* Loop over all the SS in the chain. */
2802 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2804 if (ss->expr && ss->expr->shape && !ss->shape)
2805 ss->shape = ss->expr->shape;
2809 case GFC_SS_SECTION:
2810 /* Get the descriptor for the array. */
2811 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2813 for (n = 0; n < ss->data.info.dimen; n++)
2814 gfc_conv_section_startstride (loop, ss, n);
2817 case GFC_SS_INTRINSIC:
2818 switch (ss->expr->value.function.isym->id)
2820 /* Fall through to supply start and stride. */
2821 case GFC_ISYM_LBOUND:
2822 case GFC_ISYM_UBOUND:
2828 case GFC_SS_CONSTRUCTOR:
2829 case GFC_SS_FUNCTION:
2830 for (n = 0; n < ss->data.info.dimen; n++)
2832 ss->data.info.start[n] = gfc_index_zero_node;
2833 ss->data.info.end[n] = gfc_index_zero_node;
2834 ss->data.info.stride[n] = gfc_index_one_node;
2843 /* The rest is just runtime bound checking. */
2844 if (flag_bounds_check)
2847 tree lbound, ubound;
2849 tree size[GFC_MAX_DIMENSIONS];
2850 tree stride_pos, stride_neg, non_zerosized, tmp2;
2855 gfc_start_block (&block);
2857 for (n = 0; n < loop->dimen; n++)
2858 size[n] = NULL_TREE;
2860 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2862 if (ss->type != GFC_SS_SECTION)
2865 /* TODO: range checking for mapped dimensions. */
2866 info = &ss->data.info;
2868 /* This code only checks ranges. Elemental and vector
2869 dimensions are checked later. */
2870 for (n = 0; n < loop->dimen; n++)
2875 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2878 if (n == info->ref->u.ar.dimen - 1
2879 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2880 || info->ref->u.ar.as->cp_was_assumed))
2881 check_upper = false;
2885 /* Zero stride is not allowed. */
2886 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2887 gfc_index_zero_node);
2888 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2889 "of array '%s'", info->dim[n]+1,
2890 ss->expr->symtree->name);
2891 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg);
2894 desc = ss->data.info.descriptor;
2896 /* This is the run-time equivalent of resolve.c's
2897 check_dimension(). The logical is more readable there
2898 than it is here, with all the trees. */
2899 lbound = gfc_conv_array_lbound (desc, dim);
2902 ubound = gfc_conv_array_ubound (desc, dim);
2906 /* non_zerosized is true when the selected range is not
2908 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2909 info->stride[n], gfc_index_zero_node);
2910 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2912 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2915 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2916 info->stride[n], gfc_index_zero_node);
2917 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2919 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2921 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2922 stride_pos, stride_neg);
2924 /* Check the start of the range against the lower and upper
2925 bounds of the array, if the range is not empty. */
2926 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2928 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2929 non_zerosized, tmp);
2930 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2931 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
2932 info->dim[n]+1, ss->expr->symtree->name);
2933 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2934 fold_convert (long_integer_type_node,
2936 fold_convert (long_integer_type_node,
2942 tmp = fold_build2 (GT_EXPR, boolean_type_node,
2943 info->start[n], ubound);
2944 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2945 non_zerosized, tmp);
2946 asprintf (&msg, "%s, upper bound of dimension %d of array "
2947 "'%s' exceeded, %%ld is greater than %%ld",
2948 gfc_msg_fault, info->dim[n]+1,
2949 ss->expr->symtree->name);
2950 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2951 fold_convert (long_integer_type_node, info->start[n]),
2952 fold_convert (long_integer_type_node, ubound));
2956 /* Compute the last element of the range, which is not
2957 necessarily "end" (think 0:5:3, which doesn't contain 5)
2958 and check it against both lower and upper bounds. */
2959 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2961 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2963 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2966 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2967 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2968 non_zerosized, tmp);
2969 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2970 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
2971 info->dim[n]+1, ss->expr->symtree->name);
2972 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2973 fold_convert (long_integer_type_node,
2975 fold_convert (long_integer_type_node,
2981 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2982 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2983 non_zerosized, tmp);
2984 asprintf (&msg, "%s, upper bound of dimension %d of array "
2985 "'%s' exceeded, %%ld is greater than %%ld",
2986 gfc_msg_fault, info->dim[n]+1,
2987 ss->expr->symtree->name);
2988 gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
2989 fold_convert (long_integer_type_node, tmp2),
2990 fold_convert (long_integer_type_node, ubound));
2994 /* Check the section sizes match. */
2995 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2997 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2999 /* We remember the size of the first section, and check all the
3000 others against this. */
3004 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3005 asprintf (&msg, "%s, size mismatch for dimension %d "
3006 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3007 info->dim[n]+1, ss->expr->symtree->name);
3008 gfc_trans_runtime_check (tmp3, &block, &ss->expr->where, msg,
3009 fold_convert (long_integer_type_node, tmp),
3010 fold_convert (long_integer_type_node, size[n]));
3014 size[n] = gfc_evaluate_now (tmp, &block);
3018 tmp = gfc_finish_block (&block);
3019 gfc_add_expr_to_block (&loop->pre, tmp);
3024 /* Return true if the two SS could be aliased, i.e. both point to the same data
3026 /* TODO: resolve aliases based on frontend expressions. */
3029 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3036 lsym = lss->expr->symtree->n.sym;
3037 rsym = rss->expr->symtree->n.sym;
3038 if (gfc_symbols_could_alias (lsym, rsym))
3041 if (rsym->ts.type != BT_DERIVED
3042 && lsym->ts.type != BT_DERIVED)
3045 /* For derived types we must check all the component types. We can ignore
3046 array references as these will have the same base type as the previous
3048 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3050 if (lref->type != REF_COMPONENT)
3053 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3056 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3059 if (rref->type != REF_COMPONENT)
3062 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3067 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3069 if (rref->type != REF_COMPONENT)
3072 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3080 /* Resolve array data dependencies. Creates a temporary if required. */
3081 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3085 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3095 loop->temp_ss = NULL;
3096 aref = dest->data.info.ref;
3099 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3101 if (ss->type != GFC_SS_SECTION)
3104 if (gfc_could_be_alias (dest, ss)
3105 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3111 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3113 lref = dest->expr->ref;
3114 rref = ss->expr->ref;
3116 nDepend = gfc_dep_resolver (lref, rref);
3120 /* TODO : loop shifting. */
3123 /* Mark the dimensions for LOOP SHIFTING */
3124 for (n = 0; n < loop->dimen; n++)
3126 int dim = dest->data.info.dim[n];
3128 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3130 else if (! gfc_is_same_range (&lref->u.ar,
3131 &rref->u.ar, dim, 0))
3135 /* Put all the dimensions with dependencies in the
3138 for (n = 0; n < loop->dimen; n++)
3140 gcc_assert (loop->order[n] == n);
3142 loop->order[dim++] = n;
3145 for (n = 0; n < loop->dimen; n++)
3148 loop->order[dim++] = n;
3151 gcc_assert (dim == loop->dimen);
3160 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3161 if (GFC_ARRAY_TYPE_P (base_type)
3162 || GFC_DESCRIPTOR_TYPE_P (base_type))
3163 base_type = gfc_get_element_type (base_type);
3164 loop->temp_ss = gfc_get_ss ();
3165 loop->temp_ss->type = GFC_SS_TEMP;
3166 loop->temp_ss->data.temp.type = base_type;
3167 loop->temp_ss->string_length = dest->string_length;
3168 loop->temp_ss->data.temp.dimen = loop->dimen;
3169 loop->temp_ss->next = gfc_ss_terminator;
3170 gfc_add_ss_to_loop (loop, loop->temp_ss);
3173 loop->temp_ss = NULL;
3177 /* Initialize the scalarization loop. Creates the loop variables. Determines
3178 the range of the loop variables. Creates a temporary if required.
3179 Calculates how to transform from loop variables to array indices for each
3180 expression. Also generates code for scalar expressions which have been
3181 moved outside the loop. */
3184 gfc_conv_loop_setup (gfc_loopinfo * loop)
3189 gfc_ss_info *specinfo;
3193 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3194 bool dynamic[GFC_MAX_DIMENSIONS];
3200 for (n = 0; n < loop->dimen; n++)
3204 /* We use one SS term, and use that to determine the bounds of the
3205 loop for this dimension. We try to pick the simplest term. */
3206 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3210 /* The frontend has worked out the size for us. */
3215 if (ss->type == GFC_SS_CONSTRUCTOR)
3217 /* An unknown size constructor will always be rank one.
3218 Higher rank constructors will either have known shape,
3219 or still be wrapped in a call to reshape. */
3220 gcc_assert (loop->dimen == 1);
3222 /* Always prefer to use the constructor bounds if the size
3223 can be determined at compile time. Prefer not to otherwise,
3224 since the general case involves realloc, and it's better to
3225 avoid that overhead if possible. */
3226 c = ss->expr->value.constructor;
3227 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3228 if (!dynamic[n] || !loopspec[n])
3233 /* TODO: Pick the best bound if we have a choice between a
3234 function and something else. */
3235 if (ss->type == GFC_SS_FUNCTION)
3241 if (ss->type != GFC_SS_SECTION)
3245 specinfo = &loopspec[n]->data.info;
3248 info = &ss->data.info;
3252 /* Criteria for choosing a loop specifier (most important first):
3253 doesn't need realloc
3259 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3261 else if (integer_onep (info->stride[n])
3262 && !integer_onep (specinfo->stride[n]))
3264 else if (INTEGER_CST_P (info->stride[n])
3265 && !INTEGER_CST_P (specinfo->stride[n]))
3267 else if (INTEGER_CST_P (info->start[n])
3268 && !INTEGER_CST_P (specinfo->start[n]))
3270 /* We don't work out the upper bound.
3271 else if (INTEGER_CST_P (info->finish[n])
3272 && ! INTEGER_CST_P (specinfo->finish[n]))
3273 loopspec[n] = ss; */
3277 gfc_todo_error ("Unable to find scalarization loop specifier");
3279 info = &loopspec[n]->data.info;
3281 /* Set the extents of this range. */
3282 cshape = loopspec[n]->shape;
3283 if (cshape && INTEGER_CST_P (info->start[n])
3284 && INTEGER_CST_P (info->stride[n]))
3286 loop->from[n] = info->start[n];
3287 mpz_set (i, cshape[n]);
3288 mpz_sub_ui (i, i, 1);
3289 /* To = from + (size - 1) * stride. */
3290 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3291 if (!integer_onep (info->stride[n]))
3292 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3293 tmp, info->stride[n]);
3294 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3295 loop->from[n], tmp);
3299 loop->from[n] = info->start[n];
3300 switch (loopspec[n]->type)
3302 case GFC_SS_CONSTRUCTOR:
3303 /* The upper bound is calculated when we expand the
3305 gcc_assert (loop->to[n] == NULL_TREE);
3308 case GFC_SS_SECTION:
3309 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3313 case GFC_SS_FUNCTION:
3314 /* The loop bound will be set when we generate the call. */
3315 gcc_assert (loop->to[n] == NULL_TREE);
3323 /* Transform everything so we have a simple incrementing variable. */
3324 if (integer_onep (info->stride[n]))
3325 info->delta[n] = gfc_index_zero_node;
3328 /* Set the delta for this section. */
3329 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3330 /* Number of iterations is (end - start + step) / step.
3331 with start = 0, this simplifies to
3333 for (i = 0; i<=last; i++){...}; */
3334 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3335 loop->to[n], loop->from[n]);
3336 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3337 tmp, info->stride[n]);
3338 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3339 /* Make the loop variable start at 0. */
3340 loop->from[n] = gfc_index_zero_node;
3344 /* Add all the scalar code that can be taken out of the loops.
3345 This may include calculating the loop bounds, so do it before
3346 allocating the temporary. */
3347 gfc_add_loop_ss_code (loop, loop->ss, false);
3349 /* If we want a temporary then create it. */
3350 if (loop->temp_ss != NULL)
3352 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3353 tmp = loop->temp_ss->data.temp.type;
3354 len = loop->temp_ss->string_length;
3355 n = loop->temp_ss->data.temp.dimen;
3356 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3357 loop->temp_ss->type = GFC_SS_SECTION;
3358 loop->temp_ss->data.info.dimen = n;
3359 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3360 &loop->temp_ss->data.info, tmp, false, true,
3364 for (n = 0; n < loop->temp_dim; n++)
3365 loopspec[loop->order[n]] = NULL;
3369 /* For array parameters we don't have loop variables, so don't calculate the
3371 if (loop->array_parameter)
3374 /* Calculate the translation from loop variables to array indices. */
3375 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3377 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3380 info = &ss->data.info;
3382 for (n = 0; n < info->dimen; n++)
3386 /* If we are specifying the range the delta is already set. */
3387 if (loopspec[n] != ss)
3389 /* Calculate the offset relative to the loop variable.
3390 First multiply by the stride. */
3391 tmp = loop->from[n];
3392 if (!integer_onep (info->stride[n]))
3393 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3394 tmp, info->stride[n]);
3396 /* Then subtract this from our starting value. */
3397 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3398 info->start[n], tmp);
3400 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3407 /* Fills in an array descriptor, and returns the size of the array. The size
3408 will be a simple_val, ie a variable or a constant. Also calculates the
3409 offset of the base. Returns the size of the array.
3413 for (n = 0; n < rank; n++)
3415 a.lbound[n] = specified_lower_bound;
3416 offset = offset + a.lbond[n] * stride;
3418 a.ubound[n] = specified_upper_bound;
3419 a.stride[n] = stride;
3420 size = ubound + size; //size = ubound + 1 - lbound
3421 stride = stride * size;
3428 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3429 gfc_expr ** lower, gfc_expr ** upper,
3430 stmtblock_t * pblock)
3442 stmtblock_t thenblock;
3443 stmtblock_t elseblock;
3448 type = TREE_TYPE (descriptor);
3450 stride = gfc_index_one_node;
3451 offset = gfc_index_zero_node;
3453 /* Set the dtype. */
3454 tmp = gfc_conv_descriptor_dtype (descriptor);
3455 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3457 or_expr = NULL_TREE;
3459 for (n = 0; n < rank; n++)
3461 /* We have 3 possibilities for determining the size of the array:
3462 lower == NULL => lbound = 1, ubound = upper[n]
3463 upper[n] = NULL => lbound = 1, ubound = lower[n]
3464 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3467 /* Set lower bound. */
3468 gfc_init_se (&se, NULL);
3470 se.expr = gfc_index_one_node;
3473 gcc_assert (lower[n]);
3476 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3477 gfc_add_block_to_block (pblock, &se.pre);
3481 se.expr = gfc_index_one_node;
3485 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3486 gfc_add_modify_expr (pblock, tmp, se.expr);
3488 /* Work out the offset for this component. */
3489 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3490 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3492 /* Start the calculation for the size of this dimension. */
3493 size = build2 (MINUS_EXPR, gfc_array_index_type,
3494 gfc_index_one_node, se.expr);
3496 /* Set upper bound. */
3497 gfc_init_se (&se, NULL);
3498 gcc_assert (ubound);
3499 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3500 gfc_add_block_to_block (pblock, &se.pre);
3502 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3503 gfc_add_modify_expr (pblock, tmp, se.expr);
3505 /* Store the stride. */
3506 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3507 gfc_add_modify_expr (pblock, tmp, stride);
3509 /* Calculate the size of this dimension. */
3510 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3512 /* Check whether the size for this dimension is negative. */
3513 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3514 gfc_index_zero_node);
3518 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3520 /* Multiply the stride by the number of elements in this dimension. */
3521 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3522 stride = gfc_evaluate_now (stride, pblock);
3525 /* The stride is the number of elements in the array, so multiply by the
3526 size of an element to get the total size. */
3527 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3528 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3529 fold_convert (gfc_array_index_type, tmp));
3531 if (poffset != NULL)
3533 offset = gfc_evaluate_now (offset, pblock);
3537 if (integer_zerop (or_expr))
3539 if (integer_onep (or_expr))
3540 return gfc_index_zero_node;
3542 var = gfc_create_var (TREE_TYPE (size), "size");
3543 gfc_start_block (&thenblock);
3544 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3545 thencase = gfc_finish_block (&thenblock);
3547 gfc_start_block (&elseblock);
3548 gfc_add_modify_expr (&elseblock, var, size);
3549 elsecase = gfc_finish_block (&elseblock);
3551 tmp = gfc_evaluate_now (or_expr, pblock);
3552 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3553 gfc_add_expr_to_block (pblock, tmp);
3559 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3560 the work for an ALLOCATE statement. */
3564 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3572 gfc_ref *ref, *prev_ref = NULL;
3573 bool allocatable_array;
3577 /* Find the last reference in the chain. */
3578 while (ref && ref->next != NULL)
3580 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3585 if (ref == NULL || ref->type != REF_ARRAY)
3589 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3591 allocatable_array = prev_ref->u.c.component->allocatable;
3593 /* Figure out the size of the array. */
3594 switch (ref->u.ar.type)
3598 upper = ref->u.ar.start;
3602 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3604 lower = ref->u.ar.as->lower;
3605 upper = ref->u.ar.as->upper;
3609 lower = ref->u.ar.start;
3610 upper = ref->u.ar.end;
3618 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3619 lower, upper, &se->pre);
3621 /* Allocate memory to store the data. */
3622 pointer = gfc_conv_descriptor_data_get (se->expr);
3623 STRIP_NOPS (pointer);
3625 /* The allocate_array variants take the old pointer as first argument. */
3626 if (allocatable_array)
3627 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
3629 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3630 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3631 gfc_add_expr_to_block (&se->pre, tmp);
3633 tmp = gfc_conv_descriptor_offset (se->expr);
3634 gfc_add_modify_expr (&se->pre, tmp, offset);
3636 if (expr->ts.type == BT_DERIVED
3637 && expr->ts.derived->attr.alloc_comp)
3639 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3640 ref->u.ar.as->rank);
3641 gfc_add_expr_to_block (&se->pre, tmp);
3648 /* Deallocate an array variable. Also used when an allocated variable goes
3653 gfc_array_deallocate (tree descriptor, tree pstat)
3659 gfc_start_block (&block);
3660 /* Get a pointer to the data. */
3661 var = gfc_conv_descriptor_data_get (descriptor);
3664 /* Parameter is the address of the data component. */
3665 tmp = gfc_deallocate_with_status (var, pstat, false);
3666 gfc_add_expr_to_block (&block, tmp);
3668 /* Zero the data pointer. */
3669 tmp = build2 (MODIFY_EXPR, void_type_node,
3670 var, build_int_cst (TREE_TYPE (var), 0));
3671 gfc_add_expr_to_block (&block, tmp);
3673 return gfc_finish_block (&block);
3677 /* Create an array constructor from an initialization expression.
3678 We assume the frontend already did any expansions and conversions. */
3681 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3688 unsigned HOST_WIDE_INT lo;
3690 VEC(constructor_elt,gc) *v = NULL;
3692 switch (expr->expr_type)
3695 case EXPR_STRUCTURE:
3696 /* A single scalar or derived type value. Create an array with all
3697 elements equal to that value. */
3698 gfc_init_se (&se, NULL);
3700 if (expr->expr_type == EXPR_CONSTANT)
3701 gfc_conv_constant (&se, expr);
3703 gfc_conv_structure (&se, expr, 1);
3705 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3706 gcc_assert (tmp && INTEGER_CST_P (tmp));
3707 hi = TREE_INT_CST_HIGH (tmp);
3708 lo = TREE_INT_CST_LOW (tmp);
3712 /* This will probably eat buckets of memory for large arrays. */
3713 while (hi != 0 || lo != 0)
3715 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3723 /* Create a vector of all the elements. */
3724 for (c = expr->value.constructor; c; c = c->next)
3728 /* Problems occur when we get something like
3729 integer :: a(lots) = (/(i, i=1,lots)/) */
3730 /* TODO: Unexpanded array initializers. */
3732 ("Possible frontend bug: array constructor not expanded");
3734 if (mpz_cmp_si (c->n.offset, 0) != 0)
3735 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3739 if (mpz_cmp_si (c->repeat, 0) != 0)
3743 mpz_set (maxval, c->repeat);
3744 mpz_add (maxval, c->n.offset, maxval);
3745 mpz_sub_ui (maxval, maxval, 1);
3746 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3747 if (mpz_cmp_si (c->n.offset, 0) != 0)
3749 mpz_add_ui (maxval, c->n.offset, 1);
3750 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3753 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3755 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3761 gfc_init_se (&se, NULL);
3762 switch (c->expr->expr_type)
3765 gfc_conv_constant (&se, c->expr);
3766 if (range == NULL_TREE)
3767 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3770 if (index != NULL_TREE)
3771 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3772 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3776 case EXPR_STRUCTURE:
3777 gfc_conv_structure (&se, c->expr, 1);
3778 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3788 return gfc_build_null_descriptor (type);
3794 /* Create a constructor from the list of elements. */
3795 tmp = build_constructor (type, v);
3796 TREE_CONSTANT (tmp) = 1;
3797 TREE_INVARIANT (tmp) = 1;
3802 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3803 returns the size (in elements) of the array. */
3806 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3807 stmtblock_t * pblock)
3822 size = gfc_index_one_node;
3823 offset = gfc_index_zero_node;
3824 for (dim = 0; dim < as->rank; dim++)
3826 /* Evaluate non-constant array bound expressions. */
3827 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3828 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3830 gfc_init_se (&se, NULL);
3831 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3832 gfc_add_block_to_block (pblock, &se.pre);
3833 gfc_add_modify_expr (pblock, lbound, se.expr);
3835 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3836 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3838 gfc_init_se (&se, NULL);
3839 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3840 gfc_add_block_to_block (pblock, &se.pre);
3841 gfc_add_modify_expr (pblock, ubound, se.expr);
3843 /* The offset of this dimension. offset = offset - lbound * stride. */
3844 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3845 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3847 /* The size of this dimension, and the stride of the next. */
3848 if (dim + 1 < as->rank)
3849 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3851 stride = GFC_TYPE_ARRAY_SIZE (type);
3853 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3855 /* Calculate stride = size * (ubound + 1 - lbound). */
3856 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3857 gfc_index_one_node, lbound);
3858 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3859 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3861 gfc_add_modify_expr (pblock, stride, tmp);
3863 stride = gfc_evaluate_now (tmp, pblock);
3865 /* Make sure that negative size arrays are translated
3866 to being zero size. */
3867 tmp = build2 (GE_EXPR, boolean_type_node,
3868 stride, gfc_index_zero_node);
3869 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3870 stride, gfc_index_zero_node);
3871 gfc_add_modify_expr (pblock, stride, tmp);
3877 gfc_trans_vla_type_sizes (sym, pblock);
3884 /* Generate code to initialize/allocate an array variable. */
3887 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3896 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3898 /* Do nothing for USEd variables. */
3899 if (sym->attr.use_assoc)
3902 type = TREE_TYPE (decl);
3903 gcc_assert (GFC_ARRAY_TYPE_P (type));
3904 onstack = TREE_CODE (type) != POINTER_TYPE;
3906 gfc_start_block (&block);
3908 /* Evaluate character string length. */
3909 if (sym->ts.type == BT_CHARACTER
3910 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3912 gfc_trans_init_string_length (sym->ts.cl, &block);
3914 gfc_trans_vla_type_sizes (sym, &block);
3916 /* Emit a DECL_EXPR for this variable, which will cause the
3917 gimplifier to allocate storage, and all that good stuff. */
3918 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3919 gfc_add_expr_to_block (&block, tmp);
3924 gfc_add_expr_to_block (&block, fnbody);
3925 return gfc_finish_block (&block);
3928 type = TREE_TYPE (type);
3930 gcc_assert (!sym->attr.use_assoc);
3931 gcc_assert (!TREE_STATIC (decl));
3932 gcc_assert (!sym->module);
3934 if (sym->ts.type == BT_CHARACTER
3935 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3936 gfc_trans_init_string_length (sym->ts.cl, &block);
3938 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3940 /* Don't actually allocate space for Cray Pointees. */
3941 if (sym->attr.cray_pointee)
3943 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3944 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3945 gfc_add_expr_to_block (&block, fnbody);
3946 return gfc_finish_block (&block);
3949 /* The size is the number of elements in the array, so multiply by the
3950 size of an element to get the total size. */
3951 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3952 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
3953 fold_convert (gfc_array_index_type, tmp));
3955 /* Allocate memory to hold the data. */
3956 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3957 gfc_add_modify_expr (&block, decl, tmp);
3959 /* Set offset of the array. */
3960 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3961 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3964 /* Automatic arrays should not have initializers. */
3965 gcc_assert (!sym->value);
3967 gfc_add_expr_to_block (&block, fnbody);
3969 /* Free the temporary. */
3970 tmp = gfc_call_free (convert (pvoid_type_node, decl));
3971 gfc_add_expr_to_block (&block, tmp);
3973 return gfc_finish_block (&block);
3977 /* Generate entry and exit code for g77 calling convention arrays. */
3980 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3990 gfc_get_backend_locus (&loc);
3991 gfc_set_backend_locus (&sym->declared_at);
3993 /* Descriptor type. */
3994 parm = sym->backend_decl;
3995 type = TREE_TYPE (parm);
3996 gcc_assert (GFC_ARRAY_TYPE_P (type));
3998 gfc_start_block (&block);
4000 if (sym->ts.type == BT_CHARACTER
4001 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4002 gfc_trans_init_string_length (sym->ts.cl, &block);
4004 /* Evaluate the bounds of the array. */
4005 gfc_trans_array_bounds (type, sym, &offset, &block);
4007 /* Set the offset. */
4008 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4009 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4011 /* Set the pointer itself if we aren't using the parameter directly. */
4012 if (TREE_CODE (parm) != PARM_DECL)
4014 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4015 gfc_add_modify_expr (&block, parm, tmp);
4017 stmt = gfc_finish_block (&block);
4019 gfc_set_backend_locus (&loc);
4021 gfc_start_block (&block);
4023 /* Add the initialization code to the start of the function. */
4025 if (sym->attr.optional || sym->attr.not_always_present)
4027 tmp = gfc_conv_expr_present (sym);
4028 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4031 gfc_add_expr_to_block (&block, stmt);
4032 gfc_add_expr_to_block (&block, body);
4034 return gfc_finish_block (&block);
4038 /* Modify the descriptor of an array parameter so that it has the
4039 correct lower bound. Also move the upper bound accordingly.
4040 If the array is not packed, it will be copied into a temporary.
4041 For each dimension we set the new lower and upper bounds. Then we copy the
4042 stride and calculate the offset for this dimension. We also work out
4043 what the stride of a packed array would be, and see it the two match.
4044 If the array need repacking, we set the stride to the values we just
4045 calculated, recalculate the offset and copy the array data.
4046 Code is also added to copy the data back at the end of the function.
4050 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4057 stmtblock_t cleanup;
4065 tree stride, stride2;
4075 /* Do nothing for pointer and allocatable arrays. */
4076 if (sym->attr.pointer || sym->attr.allocatable)
4079 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4080 return gfc_trans_g77_array (sym, body);
4082 gfc_get_backend_locus (&loc);
4083 gfc_set_backend_locus (&sym->declared_at);
4085 /* Descriptor type. */
4086 type = TREE_TYPE (tmpdesc);
4087 gcc_assert (GFC_ARRAY_TYPE_P (type));
4088 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4089 dumdesc = build_fold_indirect_ref (dumdesc);
4090 gfc_start_block (&block);
4092 if (sym->ts.type == BT_CHARACTER
4093 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4094 gfc_trans_init_string_length (sym->ts.cl, &block);
4096 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4098 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4099 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4101 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4103 /* For non-constant shape arrays we only check if the first dimension
4104 is contiguous. Repacking higher dimensions wouldn't gain us
4105 anything as we still don't know the array stride. */
4106 partial = gfc_create_var (boolean_type_node, "partial");
4107 TREE_USED (partial) = 1;
4108 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4109 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4110 gfc_add_modify_expr (&block, partial, tmp);
4114 partial = NULL_TREE;
4117 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4118 here, however I think it does the right thing. */
4121 /* Set the first stride. */
4122 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4123 stride = gfc_evaluate_now (stride, &block);
4125 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4126 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4127 gfc_index_one_node, stride);
4128 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4129 gfc_add_modify_expr (&block, stride, tmp);
4131 /* Allow the user to disable array repacking. */
4132 stmt_unpacked = NULL_TREE;
4136 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4137 /* A library call to repack the array if necessary. */
4138 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4139 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4141 stride = gfc_index_one_node;
4144 /* This is for the case where the array data is used directly without
4145 calling the repack function. */
4146 if (no_repack || partial != NULL_TREE)
4147 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4149 stmt_packed = NULL_TREE;
4151 /* Assign the data pointer. */
4152 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4154 /* Don't repack unknown shape arrays when the first stride is 1. */
4155 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4156 stmt_packed, stmt_unpacked);
4159 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4160 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4162 offset = gfc_index_zero_node;
4163 size = gfc_index_one_node;
4165 /* Evaluate the bounds of the array. */
4166 for (n = 0; n < sym->as->rank; n++)
4168 if (checkparm || !sym->as->upper[n])
4170 /* Get the bounds of the actual parameter. */
4171 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4172 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4176 dubound = NULL_TREE;
4177 dlbound = NULL_TREE;
4180 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4181 if (!INTEGER_CST_P (lbound))
4183 gfc_init_se (&se, NULL);
4184 gfc_conv_expr_type (&se, sym->as->lower[n],
4185 gfc_array_index_type);
4186 gfc_add_block_to_block (&block, &se.pre);
4187 gfc_add_modify_expr (&block, lbound, se.expr);
4190 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4191 /* Set the desired upper bound. */
4192 if (sym->as->upper[n])
4194 /* We know what we want the upper bound to be. */
4195 if (!INTEGER_CST_P (ubound))
4197 gfc_init_se (&se, NULL);
4198 gfc_conv_expr_type (&se, sym->as->upper[n],
4199 gfc_array_index_type);
4200 gfc_add_block_to_block (&block, &se.pre);
4201 gfc_add_modify_expr (&block, ubound, se.expr);
4204 /* Check the sizes match. */
4207 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4210 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4212 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4214 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4215 asprintf (&msg, "%s for dimension %d of array '%s'",
4216 gfc_msg_bounds, n+1, sym->name);
4217 gfc_trans_runtime_check (tmp, &block, &loc, msg);
4223 /* For assumed shape arrays move the upper bound by the same amount
4224 as the lower bound. */
4225 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4226 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4227 gfc_add_modify_expr (&block, ubound, tmp);
4229 /* The offset of this dimension. offset = offset - lbound * stride. */
4230 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4231 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4233 /* The size of this dimension, and the stride of the next. */
4234 if (n + 1 < sym->as->rank)
4236 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4238 if (no_repack || partial != NULL_TREE)
4241 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4244 /* Figure out the stride if not a known constant. */
4245 if (!INTEGER_CST_P (stride))
4248 stmt_packed = NULL_TREE;
4251 /* Calculate stride = size * (ubound + 1 - lbound). */
4252 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4253 gfc_index_one_node, lbound);
4254 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4256 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4261 /* Assign the stride. */
4262 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4263 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4264 stmt_unpacked, stmt_packed);
4266 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4267 gfc_add_modify_expr (&block, stride, tmp);
4272 stride = GFC_TYPE_ARRAY_SIZE (type);
4274 if (stride && !INTEGER_CST_P (stride))
4276 /* Calculate size = stride * (ubound + 1 - lbound). */
4277 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4278 gfc_index_one_node, lbound);
4279 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4281 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4282 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4283 gfc_add_modify_expr (&block, stride, tmp);
4288 /* Set the offset. */
4289 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4290 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4292 gfc_trans_vla_type_sizes (sym, &block);
4294 stmt = gfc_finish_block (&block);
4296 gfc_start_block (&block);
4298 /* Only do the entry/initialization code if the arg is present. */
4299 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4300 optional_arg = (sym->attr.optional
4301 || (sym->ns->proc_name->attr.entry_master
4302 && sym->attr.dummy));
4305 tmp = gfc_conv_expr_present (sym);
4306 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4308 gfc_add_expr_to_block (&block, stmt);
4310 /* Add the main function body. */
4311 gfc_add_expr_to_block (&block, body);
4316 gfc_start_block (&cleanup);
4318 if (sym->attr.intent != INTENT_IN)
4320 /* Copy the data back. */
4321 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4322 gfc_add_expr_to_block (&cleanup, tmp);
4325 /* Free the temporary. */
4326 tmp = gfc_call_free (tmpdesc);
4327 gfc_add_expr_to_block (&cleanup, tmp);
4329 stmt = gfc_finish_block (&cleanup);
4331 /* Only do the cleanup if the array was repacked. */
4332 tmp = build_fold_indirect_ref (dumdesc);
4333 tmp = gfc_conv_descriptor_data_get (tmp);
4334 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4335 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4339 tmp = gfc_conv_expr_present (sym);
4340 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4342 gfc_add_expr_to_block (&block, stmt);
4344 /* We don't need to free any memory allocated by internal_pack as it will
4345 be freed at the end of the function by pop_context. */
4346 return gfc_finish_block (&block);
4350 /* Convert an array for passing as an actual argument. Expressions and
4351 vector subscripts are evaluated and stored in a temporary, which is then
4352 passed. For whole arrays the descriptor is passed. For array sections
4353 a modified copy of the descriptor is passed, but using the original data.
4355 This function is also used for array pointer assignments, and there
4358 - se->want_pointer && !se->direct_byref
4359 EXPR is an actual argument. On exit, se->expr contains a
4360 pointer to the array descriptor.
4362 - !se->want_pointer && !se->direct_byref
4363 EXPR is an actual argument to an intrinsic function or the
4364 left-hand side of a pointer assignment. On exit, se->expr
4365 contains the descriptor for EXPR.
4367 - !se->want_pointer && se->direct_byref
4368 EXPR is the right-hand side of a pointer assignment and
4369 se->expr is the descriptor for the previously-evaluated
4370 left-hand side. The function creates an assignment from
4371 EXPR to se->expr. */
4374 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4388 gcc_assert (ss != gfc_ss_terminator);
4390 /* Special case things we know we can pass easily. */
4391 switch (expr->expr_type)
4394 /* If we have a linear array section, we can pass it directly.
4395 Otherwise we need to copy it into a temporary. */
4397 /* Find the SS for the array section. */
4399 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4400 secss = secss->next;
4402 gcc_assert (secss != gfc_ss_terminator);
4403 info = &secss->data.info;
4405 /* Get the descriptor for the array. */
4406 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4407 desc = info->descriptor;
4409 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4412 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4414 /* Create a new descriptor if the array doesn't have one. */
4417 else if (info->ref->u.ar.type == AR_FULL)
4419 else if (se->direct_byref)
4422 full = gfc_full_array_ref_p (info->ref);
4426 if (se->direct_byref)
4428 /* Copy the descriptor for pointer assignments. */
4429 gfc_add_modify_expr (&se->pre, se->expr, desc);
4431 else if (se->want_pointer)
4433 /* We pass full arrays directly. This means that pointers and
4434 allocatable arrays should also work. */
4435 se->expr = build_fold_addr_expr (desc);
4442 if (expr->ts.type == BT_CHARACTER)
4443 se->string_length = gfc_get_expr_charlen (expr);
4450 /* A transformational function return value will be a temporary
4451 array descriptor. We still need to go through the scalarizer
4452 to create the descriptor. Elemental functions ar handled as
4453 arbitrary expressions, i.e. copy to a temporary. */
4455 /* Look for the SS for this function. */
4456 while (secss != gfc_ss_terminator
4457 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4458 secss = secss->next;
4460 if (se->direct_byref)
4462 gcc_assert (secss != gfc_ss_terminator);
4464 /* For pointer assignments pass the descriptor directly. */
4466 se->expr = build_fold_addr_expr (se->expr);
4467 gfc_conv_expr (se, expr);
4471 if (secss == gfc_ss_terminator)
4473 /* Elemental function. */
4479 /* Transformational function. */
4480 info = &secss->data.info;
4486 /* Constant array constructors don't need a temporary. */
4487 if (ss->type == GFC_SS_CONSTRUCTOR
4488 && expr->ts.type != BT_CHARACTER
4489 && gfc_constant_array_constructor_p (expr->value.constructor))
4492 info = &ss->data.info;
4504 /* Something complicated. Copy it into a temporary. */
4512 gfc_init_loopinfo (&loop);
4514 /* Associate the SS with the loop. */
4515 gfc_add_ss_to_loop (&loop, ss);
4517 /* Tell the scalarizer not to bother creating loop variables, etc. */
4519 loop.array_parameter = 1;
4521 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4522 gcc_assert (!se->direct_byref);
4524 /* Setup the scalarizing loops and bounds. */
4525 gfc_conv_ss_startstride (&loop);
4529 /* Tell the scalarizer to make a temporary. */
4530 loop.temp_ss = gfc_get_ss ();
4531 loop.temp_ss->type = GFC_SS_TEMP;
4532 loop.temp_ss->next = gfc_ss_terminator;
4533 if (expr->ts.type == BT_CHARACTER)
4535 if (expr->ts.cl == NULL)
4537 /* This had better be a substring reference! */
4538 gfc_ref *char_ref = expr->ref;
4539 for (; char_ref; char_ref = char_ref->next)
4540 if (char_ref->type == REF_SUBSTRING)
4543 expr->ts.cl = gfc_get_charlen ();
4544 expr->ts.cl->next = char_ref->u.ss.length->next;
4545 char_ref->u.ss.length->next = expr->ts.cl;
4547 mpz_init_set_ui (char_len, 1);
4548 mpz_add (char_len, char_len,
4549 char_ref->u.ss.end->value.integer);
4550 mpz_sub (char_len, char_len,
4551 char_ref->u.ss.start->value.integer);
4552 expr->ts.cl->backend_decl
4553 = gfc_conv_mpz_to_tree (char_len,
4554 gfc_default_character_kind);
4555 /* Cast is necessary for *-charlen refs. */
4556 expr->ts.cl->backend_decl
4557 = convert (gfc_charlen_type_node,
4558 expr->ts.cl->backend_decl);
4559 mpz_clear (char_len);
4562 gcc_assert (char_ref != NULL);
4563 loop.temp_ss->data.temp.type
4564 = gfc_typenode_for_spec (&expr->ts);
4565 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4567 else if (expr->ts.cl->length
4568 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4570 gfc_conv_const_charlen (expr->ts.cl);
4571 loop.temp_ss->data.temp.type
4572 = gfc_typenode_for_spec (&expr->ts);
4573 loop.temp_ss->string_length
4574 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4578 loop.temp_ss->data.temp.type
4579 = gfc_typenode_for_spec (&expr->ts);
4580 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4582 se->string_length = loop.temp_ss->string_length;
4586 loop.temp_ss->data.temp.type
4587 = gfc_typenode_for_spec (&expr->ts);
4588 loop.temp_ss->string_length = NULL;
4590 loop.temp_ss->data.temp.dimen = loop.dimen;
4591 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4594 gfc_conv_loop_setup (&loop);
4598 /* Copy into a temporary and pass that. We don't need to copy the data
4599 back because expressions and vector subscripts must be INTENT_IN. */
4600 /* TODO: Optimize passing function return values. */
4604 /* Start the copying loops. */
4605 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4606 gfc_mark_ss_chain_used (ss, 1);
4607 gfc_start_scalarized_body (&loop, &block);
4609 /* Copy each data element. */
4610 gfc_init_se (&lse, NULL);
4611 gfc_copy_loopinfo_to_se (&lse, &loop);
4612 gfc_init_se (&rse, NULL);
4613 gfc_copy_loopinfo_to_se (&rse, &loop);
4615 lse.ss = loop.temp_ss;
4618 gfc_conv_scalarized_array_ref (&lse, NULL);
4619 if (expr->ts.type == BT_CHARACTER)
4621 gfc_conv_expr (&rse, expr);
4622 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4623 rse.expr = build_fold_indirect_ref (rse.expr);
4626 gfc_conv_expr_val (&rse, expr);
4628 gfc_add_block_to_block (&block, &rse.pre);
4629 gfc_add_block_to_block (&block, &lse.pre);
4631 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4633 /* Finish the copying loops. */
4634 gfc_trans_scalarizing_loops (&loop, &block);
4636 desc = loop.temp_ss->data.info.descriptor;
4638 gcc_assert (is_gimple_lvalue (desc));
4640 else if (expr->expr_type == EXPR_FUNCTION)
4642 desc = info->descriptor;
4643 se->string_length = ss->string_length;
4647 /* We pass sections without copying to a temporary. Make a new
4648 descriptor and point it at the section we want. The loop variable
4649 limits will be the limits of the section.
4650 A function may decide to repack the array to speed up access, but
4651 we're not bothered about that here. */
4660 /* Set the string_length for a character array. */
4661 if (expr->ts.type == BT_CHARACTER)
4662 se->string_length = gfc_get_expr_charlen (expr);
4664 desc = info->descriptor;
4665 gcc_assert (secss && secss != gfc_ss_terminator);
4666 if (se->direct_byref)
4668 /* For pointer assignments we fill in the destination. */
4670 parmtype = TREE_TYPE (parm);
4674 /* Otherwise make a new one. */
4675 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4676 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4677 loop.from, loop.to, 0);
4678 parm = gfc_create_var (parmtype, "parm");
4681 offset = gfc_index_zero_node;
4684 /* The following can be somewhat confusing. We have two
4685 descriptors, a new one and the original array.
4686 {parm, parmtype, dim} refer to the new one.
4687 {desc, type, n, secss, loop} refer to the original, which maybe
4688 a descriptorless array.
4689 The bounds of the scalarization are the bounds of the section.
4690 We don't have to worry about numeric overflows when calculating
4691 the offsets because all elements are within the array data. */
4693 /* Set the dtype. */
4694 tmp = gfc_conv_descriptor_dtype (parm);
4695 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4697 /* Set offset for assignments to pointer only to zero if it is not
4699 if (se->direct_byref
4700 && info->ref && info->ref->u.ar.type != AR_FULL)
4701 base = gfc_index_zero_node;
4702 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4703 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4707 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4708 for (n = 0; n < ndim; n++)
4710 stride = gfc_conv_array_stride (desc, n);
4712 /* Work out the offset. */
4714 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4716 gcc_assert (info->subscript[n]
4717 && info->subscript[n]->type == GFC_SS_SCALAR);
4718 start = info->subscript[n]->data.scalar.expr;
4722 /* Check we haven't somehow got out of sync. */
4723 gcc_assert (info->dim[dim] == n);
4725 /* Evaluate and remember the start of the section. */
4726 start = info->start[dim];
4727 stride = gfc_evaluate_now (stride, &loop.pre);
4730 tmp = gfc_conv_array_lbound (desc, n);
4731 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4733 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4734 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4737 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4739 /* For elemental dimensions, we only need the offset. */
4743 /* Vector subscripts need copying and are handled elsewhere. */
4745 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4747 /* Set the new lower bound. */
4748 from = loop.from[dim];
4751 /* If we have an array section or are assigning make sure that
4752 the lower bound is 1. References to the full
4753 array should otherwise keep the original bounds. */
4755 || info->ref->u.ar.type != AR_FULL)
4756 && !integer_onep (from))
4758 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4759 gfc_index_one_node, from);
4760 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4761 from = gfc_index_one_node;
4763 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4764 gfc_add_modify_expr (&loop.pre, tmp, from);
4766 /* Set the new upper bound. */
4767 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4768 gfc_add_modify_expr (&loop.pre, tmp, to);
4770 /* Multiply the stride by the section stride to get the
4772 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4773 stride, info->stride[dim]);
4775 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
4777 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4780 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4782 tmp = gfc_conv_array_lbound (desc, n);
4783 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4784 tmp, loop.from[dim]);
4785 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
4786 tmp, gfc_conv_array_stride (desc, n));
4787 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
4791 /* Store the new stride. */
4792 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4793 gfc_add_modify_expr (&loop.pre, tmp, stride);
4798 if (se->data_not_needed)
4799 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4802 /* Point the data pointer at the first element in the section. */
4803 tmp = gfc_conv_array_data (desc);
4804 tmp = build_fold_indirect_ref (tmp);
4805 tmp = gfc_build_array_ref (tmp, offset);
4806 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4807 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4810 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4811 && !se->data_not_needed)
4813 /* Set the offset. */
4814 tmp = gfc_conv_descriptor_offset (parm);
4815 gfc_add_modify_expr (&loop.pre, tmp, base);
4819 /* Only the callee knows what the correct offset it, so just set
4821 tmp = gfc_conv_descriptor_offset (parm);
4822 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4827 if (!se->direct_byref)
4829 /* Get a pointer to the new descriptor. */
4830 if (se->want_pointer)
4831 se->expr = build_fold_addr_expr (desc);
4836 gfc_add_block_to_block (&se->pre, &loop.pre);
4837 gfc_add_block_to_block (&se->post, &loop.post);
4839 /* Cleanup the scalarizer. */
4840 gfc_cleanup_loop (&loop);
4844 /* Convert an array for passing as an actual parameter. */
4845 /* TODO: Optimize passing g77 arrays. */
4848 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4852 tree tmp = NULL_TREE;
4854 tree parent = DECL_CONTEXT (current_function_decl);
4855 bool full_array_var, this_array_result;
4859 full_array_var = (expr->expr_type == EXPR_VARIABLE
4860 && expr->ref->u.ar.type == AR_FULL);
4861 sym = full_array_var ? expr->symtree->n.sym : NULL;
4863 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
4865 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
4866 expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
4867 se->string_length = expr->ts.cl->backend_decl;
4870 /* Is this the result of the enclosing procedure? */
4871 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4872 if (this_array_result
4873 && (sym->backend_decl != current_function_decl)
4874 && (sym->backend_decl != parent))
4875 this_array_result = false;
4877 /* Passing address of the array if it is not pointer or assumed-shape. */
4878 if (full_array_var && g77 && !this_array_result)
4880 tmp = gfc_get_symbol_decl (sym);
4882 if (sym->ts.type == BT_CHARACTER)
4883 se->string_length = sym->ts.cl->backend_decl;
4884 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4885 && !sym->attr.allocatable)
4887 /* Some variables are declared directly, others are declared as
4888 pointers and allocated on the heap. */
4889 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4892 se->expr = build_fold_addr_expr (tmp);
4895 if (sym->attr.allocatable)
4897 if (sym->attr.dummy)
4899 gfc_conv_expr_descriptor (se, expr, ss);
4900 se->expr = gfc_conv_array_data (se->expr);
4903 se->expr = gfc_conv_array_data (tmp);
4908 if (this_array_result)
4910 /* Result of the enclosing function. */
4911 gfc_conv_expr_descriptor (se, expr, ss);
4912 se->expr = build_fold_addr_expr (se->expr);
4914 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
4915 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4916 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
4922 /* Every other type of array. */
4923 se->want_pointer = 1;
4924 gfc_conv_expr_descriptor (se, expr, ss);
4928 /* Deallocate the allocatable components of structures that are
4930 if (expr->ts.type == BT_DERIVED
4931 && expr->ts.derived->attr.alloc_comp
4932 && expr->expr_type != EXPR_VARIABLE)
4934 tmp = build_fold_indirect_ref (se->expr);
4935 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4936 gfc_add_expr_to_block (&se->post, tmp);
4942 /* Repack the array. */
4943 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
4944 ptr = gfc_evaluate_now (ptr, &se->pre);
4947 gfc_start_block (&block);
4949 /* Copy the data back. */
4950 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
4951 gfc_add_expr_to_block (&block, tmp);
4953 /* Free the temporary. */
4954 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
4955 gfc_add_expr_to_block (&block, tmp);
4957 stmt = gfc_finish_block (&block);
4959 gfc_init_block (&block);
4960 /* Only if it was repacked. This code needs to be executed before the
4961 loop cleanup code. */
4962 tmp = build_fold_indirect_ref (desc);
4963 tmp = gfc_conv_array_data (tmp);
4964 tmp = build2 (NE_EXPR, boolean_type_node,
4965 fold_convert (TREE_TYPE (tmp), ptr), tmp);
4966 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4968 gfc_add_expr_to_block (&block, tmp);
4969 gfc_add_block_to_block (&block, &se->post);
4971 gfc_init_block (&se->post);
4972 gfc_add_block_to_block (&se->post, &block);
4977 /* Generate code to deallocate an array, if it is allocated. */
4980 gfc_trans_dealloc_allocated (tree descriptor)
4986 gfc_start_block (&block);
4988 var = gfc_conv_descriptor_data_get (descriptor);
4991 /* Call array_deallocate with an int * present in the second argument.
4992 Although it is ignored here, it's presence ensures that arrays that
4993 are already deallocated are ignored. */
4994 tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
4995 gfc_add_expr_to_block (&block, tmp);
4997 /* Zero the data pointer. */
4998 tmp = build2 (MODIFY_EXPR, void_type_node,
4999 var, build_int_cst (TREE_TYPE (var), 0));
5000 gfc_add_expr_to_block (&block, tmp);
5002 return gfc_finish_block (&block);
5006 /* This helper function calculates the size in words of a full array. */
5009 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5014 idx = gfc_rank_cst[rank - 1];
5015 nelems = gfc_conv_descriptor_ubound (decl, idx);
5016 tmp = gfc_conv_descriptor_lbound (decl, idx);
5017 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5018 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
5019 tmp, gfc_index_one_node);
5020 tmp = gfc_evaluate_now (tmp, block);
5022 nelems = gfc_conv_descriptor_stride (decl, idx);
5023 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5024 return gfc_evaluate_now (tmp, block);
5028 /* Allocate dest to the same size as src, and copy src -> dest. */
5031 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5040 /* If the source is null, set the destination to null. */
5041 gfc_init_block (&block);
5042 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5043 null_data = gfc_finish_block (&block);
5045 gfc_init_block (&block);
5047 nelems = get_full_array_size (&block, src, rank);
5048 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5049 fold_convert (gfc_array_index_type,
5050 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5052 /* Allocate memory to the destination. */
5053 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5055 gfc_conv_descriptor_data_set (&block, dest, tmp);
5057 /* We know the temporary and the value will be the same length,
5058 so can use memcpy. */
5059 tmp = built_in_decls[BUILT_IN_MEMCPY];
5060 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5061 gfc_conv_descriptor_data_get (src), size);
5062 gfc_add_expr_to_block (&block, tmp);
5063 tmp = gfc_finish_block (&block);
5065 /* Null the destination if the source is null; otherwise do
5066 the allocate and copy. */
5067 null_cond = gfc_conv_descriptor_data_get (src);
5068 null_cond = convert (pvoid_type_node, null_cond);
5069 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5071 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5075 /* Recursively traverse an object of derived type, generating code to
5076 deallocate, nullify or copy allocatable components. This is the work horse
5077 function for the functions named in this enum. */
5079 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5082 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5083 tree dest, int rank, int purpose)
5087 stmtblock_t fnblock;
5088 stmtblock_t loopbody;
5098 tree null_cond = NULL_TREE;
5100 gfc_init_block (&fnblock);
5102 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5103 decl = build_fold_indirect_ref (decl);
5105 /* If this an array of derived types with allocatable components
5106 build a loop and recursively call this function. */
5107 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5108 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5110 tmp = gfc_conv_array_data (decl);
5111 var = build_fold_indirect_ref (tmp);
5113 /* Get the number of elements - 1 and set the counter. */
5114 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5116 /* Use the descriptor for an allocatable array. Since this
5117 is a full array reference, we only need the descriptor
5118 information from dimension = rank. */
5119 tmp = get_full_array_size (&fnblock, decl, rank);
5120 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
5121 tmp, gfc_index_one_node);
5123 null_cond = gfc_conv_descriptor_data_get (decl);
5124 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5125 build_int_cst (TREE_TYPE (null_cond), 0));
5129 /* Otherwise use the TYPE_DOMAIN information. */
5130 tmp = array_type_nelts (TREE_TYPE (decl));
5131 tmp = fold_convert (gfc_array_index_type, tmp);
5134 /* Remember that this is, in fact, the no. of elements - 1. */
5135 nelems = gfc_evaluate_now (tmp, &fnblock);
5136 index = gfc_create_var (gfc_array_index_type, "S");
5138 /* Build the body of the loop. */
5139 gfc_init_block (&loopbody);
5141 vref = gfc_build_array_ref (var, index);
5143 if (purpose == COPY_ALLOC_COMP)
5145 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5146 gfc_add_expr_to_block (&fnblock, tmp);
5148 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5149 dref = gfc_build_array_ref (tmp, index);
5150 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5153 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5155 gfc_add_expr_to_block (&loopbody, tmp);
5157 /* Build the loop and return. */
5158 gfc_init_loopinfo (&loop);
5160 loop.from[0] = gfc_index_zero_node;
5161 loop.loopvar[0] = index;
5162 loop.to[0] = nelems;
5163 gfc_trans_scalarizing_loops (&loop, &loopbody);
5164 gfc_add_block_to_block (&fnblock, &loop.pre);
5166 tmp = gfc_finish_block (&fnblock);
5167 if (null_cond != NULL_TREE)
5168 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5173 /* Otherwise, act on the components or recursively call self to
5174 act on a chain of components. */
5175 for (c = der_type->components; c; c = c->next)
5177 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5178 && c->ts.derived->attr.alloc_comp;
5179 cdecl = c->backend_decl;
5180 ctype = TREE_TYPE (cdecl);
5184 case DEALLOCATE_ALLOC_COMP:
5185 /* Do not deallocate the components of ultimate pointer
5187 if (cmp_has_alloc_comps && !c->pointer)
5189 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5190 rank = c->as ? c->as->rank : 0;
5191 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5193 gfc_add_expr_to_block (&fnblock, tmp);
5198 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5199 tmp = gfc_trans_dealloc_allocated (comp);
5200 gfc_add_expr_to_block (&fnblock, tmp);
5204 case NULLIFY_ALLOC_COMP:
5207 else if (c->allocatable)
5209 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5210 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5212 else if (cmp_has_alloc_comps)
5214 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5215 rank = c->as ? c->as->rank : 0;
5216 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5218 gfc_add_expr_to_block (&fnblock, tmp);
5222 case COPY_ALLOC_COMP:
5226 /* We need source and destination components. */
5227 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5228 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5229 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5231 if (c->allocatable && !cmp_has_alloc_comps)
5233 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5234 gfc_add_expr_to_block (&fnblock, tmp);
5237 if (cmp_has_alloc_comps)
5239 rank = c->as ? c->as->rank : 0;
5240 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5241 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5242 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5244 gfc_add_expr_to_block (&fnblock, tmp);
5254 return gfc_finish_block (&fnblock);
5257 /* Recursively traverse an object of derived type, generating code to
5258 nullify allocatable components. */
5261 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5263 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5264 NULLIFY_ALLOC_COMP);
5268 /* Recursively traverse an object of derived type, generating code to
5269 deallocate allocatable components. */
5272 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5274 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5275 DEALLOCATE_ALLOC_COMP);
5279 /* Recursively traverse an object of derived type, generating code to
5280 copy its allocatable components. */
5283 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5285 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5289 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5290 Do likewise, recursively if necessary, with the allocatable components of
5294 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5299 stmtblock_t fnblock;
5302 bool sym_has_alloc_comp;
5304 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5305 && sym->ts.derived->attr.alloc_comp;
5307 /* Make sure the frontend gets these right. */
5308 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5309 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5310 "allocatable attribute or derived type without allocatable "
5313 gfc_init_block (&fnblock);
5315 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5316 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5318 if (sym->ts.type == BT_CHARACTER
5319 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5321 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5322 gfc_trans_vla_type_sizes (sym, &fnblock);
5325 /* Dummy and use associated variables don't need anything special. */
5326 if (sym->attr.dummy || sym->attr.use_assoc)
5328 gfc_add_expr_to_block (&fnblock, body);
5330 return gfc_finish_block (&fnblock);
5333 gfc_get_backend_locus (&loc);
5334 gfc_set_backend_locus (&sym->declared_at);
5335 descriptor = sym->backend_decl;
5337 /* Although static, derived types with default initializers and
5338 allocatable components must not be nulled wholesale; instead they
5339 are treated component by component. */
5340 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5342 /* SAVEd variables are not freed on exit. */
5343 gfc_trans_static_array_pointer (sym);
5347 /* Get the descriptor type. */
5348 type = TREE_TYPE (sym->backend_decl);
5350 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5352 if (!sym->attr.save)
5354 rank = sym->as ? sym->as->rank : 0;
5355 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5356 gfc_add_expr_to_block (&fnblock, tmp);
5359 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5361 /* If the backend_decl is not a descriptor, we must have a pointer
5363 descriptor = build_fold_indirect_ref (sym->backend_decl);
5364 type = TREE_TYPE (descriptor);
5367 /* NULLIFY the data pointer. */
5368 if (GFC_DESCRIPTOR_TYPE_P (type))
5369 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5371 gfc_add_expr_to_block (&fnblock, body);
5373 gfc_set_backend_locus (&loc);
5375 /* Allocatable arrays need to be freed when they go out of scope.
5376 The allocatable components of pointers must not be touched. */
5377 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5378 && !sym->attr.pointer && !sym->attr.save)
5381 rank = sym->as ? sym->as->rank : 0;
5382 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5383 gfc_add_expr_to_block (&fnblock, tmp);
5386 if (sym->attr.allocatable)
5388 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5389 gfc_add_expr_to_block (&fnblock, tmp);
5392 return gfc_finish_block (&fnblock);
5395 /************ Expression Walking Functions ******************/
5397 /* Walk a variable reference.
5399 Possible extension - multiple component subscripts.
5400 x(:,:) = foo%a(:)%b(:)
5402 forall (i=..., j=...)
5403 x(i,j) = foo%a(j)%b(i)
5405 This adds a fair amount of complexity because you need to deal with more
5406 than one ref. Maybe handle in a similar manner to vector subscripts.
5407 Maybe not worth the effort. */
5411 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5419 for (ref = expr->ref; ref; ref = ref->next)
5420 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5423 for (; ref; ref = ref->next)
5425 if (ref->type == REF_SUBSTRING)
5427 newss = gfc_get_ss ();
5428 newss->type = GFC_SS_SCALAR;
5429 newss->expr = ref->u.ss.start;
5433 newss = gfc_get_ss ();
5434 newss->type = GFC_SS_SCALAR;
5435 newss->expr = ref->u.ss.end;
5440 /* We're only interested in array sections from now on. */
5441 if (ref->type != REF_ARRAY)
5448 for (n = 0; n < ar->dimen; n++)
5450 newss = gfc_get_ss ();
5451 newss->type = GFC_SS_SCALAR;
5452 newss->expr = ar->start[n];
5459 newss = gfc_get_ss ();
5460 newss->type = GFC_SS_SECTION;
5463 newss->data.info.dimen = ar->as->rank;
5464 newss->data.info.ref = ref;
5466 /* Make sure array is the same as array(:,:), this way
5467 we don't need to special case all the time. */
5468 ar->dimen = ar->as->rank;
5469 for (n = 0; n < ar->dimen; n++)
5471 newss->data.info.dim[n] = n;
5472 ar->dimen_type[n] = DIMEN_RANGE;
5474 gcc_assert (ar->start[n] == NULL);
5475 gcc_assert (ar->end[n] == NULL);
5476 gcc_assert (ar->stride[n] == NULL);
5482 newss = gfc_get_ss ();
5483 newss->type = GFC_SS_SECTION;
5486 newss->data.info.dimen = 0;
5487 newss->data.info.ref = ref;
5491 /* We add SS chains for all the subscripts in the section. */
5492 for (n = 0; n < ar->dimen; n++)
5496 switch (ar->dimen_type[n])
5499 /* Add SS for elemental (scalar) subscripts. */
5500 gcc_assert (ar->start[n]);
5501 indexss = gfc_get_ss ();
5502 indexss->type = GFC_SS_SCALAR;
5503 indexss->expr = ar->start[n];
5504 indexss->next = gfc_ss_terminator;
5505 indexss->loop_chain = gfc_ss_terminator;
5506 newss->data.info.subscript[n] = indexss;
5510 /* We don't add anything for sections, just remember this
5511 dimension for later. */
5512 newss->data.info.dim[newss->data.info.dimen] = n;
5513 newss->data.info.dimen++;
5517 /* Create a GFC_SS_VECTOR index in which we can store
5518 the vector's descriptor. */
5519 indexss = gfc_get_ss ();
5520 indexss->type = GFC_SS_VECTOR;
5521 indexss->expr = ar->start[n];
5522 indexss->next = gfc_ss_terminator;
5523 indexss->loop_chain = gfc_ss_terminator;
5524 newss->data.info.subscript[n] = indexss;
5525 newss->data.info.dim[newss->data.info.dimen] = n;
5526 newss->data.info.dimen++;
5530 /* We should know what sort of section it is by now. */
5534 /* We should have at least one non-elemental dimension. */
5535 gcc_assert (newss->data.info.dimen > 0);
5540 /* We should know what sort of section it is by now. */
5549 /* Walk an expression operator. If only one operand of a binary expression is
5550 scalar, we must also add the scalar term to the SS chain. */
5553 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5559 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5560 if (expr->value.op.op2 == NULL)
5563 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5565 /* All operands are scalar. Pass back and let the caller deal with it. */
5569 /* All operands require scalarization. */
5570 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5573 /* One of the operands needs scalarization, the other is scalar.
5574 Create a gfc_ss for the scalar expression. */
5575 newss = gfc_get_ss ();
5576 newss->type = GFC_SS_SCALAR;
5579 /* First operand is scalar. We build the chain in reverse order, so
5580 add the scarar SS after the second operand. */
5582 while (head && head->next != ss)
5584 /* Check we haven't somehow broken the chain. */
5588 newss->expr = expr->value.op.op1;
5590 else /* head2 == head */
5592 gcc_assert (head2 == head);
5593 /* Second operand is scalar. */
5594 newss->next = head2;
5596 newss->expr = expr->value.op.op2;
5603 /* Reverse a SS chain. */
5606 gfc_reverse_ss (gfc_ss * ss)
5611 gcc_assert (ss != NULL);
5613 head = gfc_ss_terminator;
5614 while (ss != gfc_ss_terminator)
5617 /* Check we didn't somehow break the chain. */
5618 gcc_assert (next != NULL);
5628 /* Walk the arguments of an elemental function. */
5631 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5639 head = gfc_ss_terminator;
5642 for (; arg; arg = arg->next)
5647 newss = gfc_walk_subexpr (head, arg->expr);
5650 /* Scalar argument. */
5651 newss = gfc_get_ss ();
5653 newss->expr = arg->expr;
5663 while (tail->next != gfc_ss_terminator)
5670 /* If all the arguments are scalar we don't need the argument SS. */
5671 gfc_free_ss_chain (head);
5676 /* Add it onto the existing chain. */
5682 /* Walk a function call. Scalar functions are passed back, and taken out of
5683 scalarization loops. For elemental functions we walk their arguments.
5684 The result of functions returning arrays is stored in a temporary outside
5685 the loop, so that the function is only called once. Hence we do not need
5686 to walk their arguments. */
5689 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5692 gfc_intrinsic_sym *isym;
5695 isym = expr->value.function.isym;
5697 /* Handle intrinsic functions separately. */
5699 return gfc_walk_intrinsic_function (ss, expr, isym);
5701 sym = expr->value.function.esym;
5703 sym = expr->symtree->n.sym;
5705 /* A function that returns arrays. */
5706 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5708 newss = gfc_get_ss ();
5709 newss->type = GFC_SS_FUNCTION;
5712 newss->data.info.dimen = expr->rank;
5716 /* Walk the parameters of an elemental function. For now we always pass
5718 if (sym->attr.elemental)
5719 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5722 /* Scalar functions are OK as these are evaluated outside the scalarization
5723 loop. Pass back and let the caller deal with it. */
5728 /* An array temporary is constructed for array constructors. */
5731 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5736 newss = gfc_get_ss ();
5737 newss->type = GFC_SS_CONSTRUCTOR;
5740 newss->data.info.dimen = expr->rank;
5741 for (n = 0; n < expr->rank; n++)
5742 newss->data.info.dim[n] = n;
5748 /* Walk an expression. Add walked expressions to the head of the SS chain.
5749 A wholly scalar expression will not be added. */
5752 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5756 switch (expr->expr_type)
5759 head = gfc_walk_variable_expr (ss, expr);
5763 head = gfc_walk_op_expr (ss, expr);
5767 head = gfc_walk_function_expr (ss, expr);
5772 case EXPR_STRUCTURE:
5773 /* Pass back and let the caller deal with it. */
5777 head = gfc_walk_array_constructor (ss, expr);
5780 case EXPR_SUBSTRING:
5781 /* Pass back and let the caller deal with it. */
5785 internal_error ("bad expression type during walk (%d)",
5792 /* Entry point for expression walking.
5793 A return value equal to the passed chain means this is
5794 a scalar expression. It is up to the caller to take whatever action is
5795 necessary to translate these. */
5798 gfc_walk_expr (gfc_expr * expr)
5802 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5803 return gfc_reverse_ss (res);