1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 = fold_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 = fold_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 = fold_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 fold_build3 (COMPONENT_REF, TREE_TYPE (field),
215 desc, field, NULL_TREE);
219 gfc_conv_descriptor_dtype (tree desc)
224 type = TREE_TYPE (desc);
225 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
227 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
228 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
230 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
231 desc, field, NULL_TREE);
235 gfc_conv_descriptor_dimension (tree desc, tree dim)
241 type = TREE_TYPE (desc);
242 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
244 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
245 gcc_assert (field != NULL_TREE
246 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
247 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
249 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
250 desc, field, NULL_TREE);
251 tmp = gfc_build_array_ref (tmp, dim, NULL);
256 gfc_conv_descriptor_stride (tree desc, tree dim)
261 tmp = gfc_conv_descriptor_dimension (desc, dim);
262 field = TYPE_FIELDS (TREE_TYPE (tmp));
263 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
264 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
266 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
267 tmp, field, NULL_TREE);
272 gfc_conv_descriptor_lbound (tree desc, tree dim)
277 tmp = gfc_conv_descriptor_dimension (desc, dim);
278 field = TYPE_FIELDS (TREE_TYPE (tmp));
279 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
280 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
282 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
283 tmp, field, NULL_TREE);
288 gfc_conv_descriptor_ubound (tree desc, tree dim)
293 tmp = gfc_conv_descriptor_dimension (desc, dim);
294 field = TYPE_FIELDS (TREE_TYPE (tmp));
295 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
296 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
298 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
299 tmp, field, NULL_TREE);
304 /* Build a null array descriptor constructor. */
307 gfc_build_null_descriptor (tree type)
312 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
313 gcc_assert (DATA_FIELD == 0);
314 field = TYPE_FIELDS (type);
316 /* Set a NULL data pointer. */
317 tmp = build_constructor_single (type, field, null_pointer_node);
318 TREE_CONSTANT (tmp) = 1;
319 TREE_INVARIANT (tmp) = 1;
320 /* All other fields are ignored. */
326 /* Cleanup those #defines. */
331 #undef DIMENSION_FIELD
332 #undef STRIDE_SUBFIELD
333 #undef LBOUND_SUBFIELD
334 #undef UBOUND_SUBFIELD
337 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
338 flags & 1 = Main loop body.
339 flags & 2 = temp copy loop. */
342 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
344 for (; ss != gfc_ss_terminator; ss = ss->next)
345 ss->useflags = flags;
348 static void gfc_free_ss (gfc_ss *);
351 /* Free a gfc_ss chain. */
354 gfc_free_ss_chain (gfc_ss * ss)
358 while (ss != gfc_ss_terminator)
360 gcc_assert (ss != NULL);
371 gfc_free_ss (gfc_ss * ss)
378 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
380 if (ss->data.info.subscript[n])
381 gfc_free_ss_chain (ss->data.info.subscript[n]);
393 /* Free all the SS associated with a loop. */
396 gfc_cleanup_loop (gfc_loopinfo * loop)
402 while (ss != gfc_ss_terminator)
404 gcc_assert (ss != NULL);
405 next = ss->loop_chain;
412 /* Associate a SS chain with a loop. */
415 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
419 if (head == gfc_ss_terminator)
423 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
425 if (ss->next == gfc_ss_terminator)
426 ss->loop_chain = loop->ss;
428 ss->loop_chain = ss->next;
430 gcc_assert (ss == gfc_ss_terminator);
435 /* Generate an initializer for a static pointer or allocatable array. */
438 gfc_trans_static_array_pointer (gfc_symbol * sym)
442 gcc_assert (TREE_STATIC (sym->backend_decl));
443 /* Just zero the data member. */
444 type = TREE_TYPE (sym->backend_decl);
445 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
449 /* If the bounds of SE's loop have not yet been set, see if they can be
450 determined from array spec AS, which is the array spec of a called
451 function. MAPPING maps the callee's dummy arguments to the values
452 that the caller is passing. Add any initialization and finalization
456 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
457 gfc_se * se, gfc_array_spec * as)
465 if (as && as->type == AS_EXPLICIT)
466 for (dim = 0; dim < se->loop->dimen; dim++)
468 n = se->loop->order[dim];
469 if (se->loop->to[n] == NULL_TREE)
471 /* Evaluate the lower bound. */
472 gfc_init_se (&tmpse, NULL);
473 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
474 gfc_add_block_to_block (&se->pre, &tmpse.pre);
475 gfc_add_block_to_block (&se->post, &tmpse.post);
478 /* ...and the upper bound. */
479 gfc_init_se (&tmpse, NULL);
480 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
481 gfc_add_block_to_block (&se->pre, &tmpse.pre);
482 gfc_add_block_to_block (&se->post, &tmpse.post);
485 /* Set the upper bound of the loop to UPPER - LOWER. */
486 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
487 tmp = gfc_evaluate_now (tmp, &se->pre);
488 se->loop->to[n] = tmp;
494 /* Generate code to allocate an array temporary, or create a variable to
495 hold the data. If size is NULL, zero the descriptor so that the
496 callee will allocate the array. If DEALLOC is true, also generate code to
497 free the array afterwards.
499 Initialization code is added to PRE and finalization code to POST.
500 DYNAMIC is true if the caller may want to extend the array later
501 using realloc. This prevents us from putting the array on the stack. */
504 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
505 gfc_ss_info * info, tree size, tree nelem,
506 bool dynamic, bool dealloc)
512 desc = info->descriptor;
513 info->offset = gfc_index_zero_node;
514 if (size == NULL_TREE || integer_zerop (size))
516 /* A callee allocated array. */
517 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
522 /* Allocate the temporary. */
523 onstack = !dynamic && gfc_can_put_var_on_stack (size);
527 /* Make a temporary variable to hold the data. */
528 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
530 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
532 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
534 tmp = gfc_create_var (tmp, "A");
535 tmp = build_fold_addr_expr (tmp);
536 gfc_conv_descriptor_data_set (pre, desc, tmp);
540 /* Allocate memory to hold the data. */
541 tmp = gfc_call_malloc (pre, NULL, size);
542 tmp = gfc_evaluate_now (tmp, pre);
543 gfc_conv_descriptor_data_set (pre, desc, tmp);
546 info->data = gfc_conv_descriptor_data_get (desc);
548 /* The offset is zero because we create temporaries with a zero
550 tmp = gfc_conv_descriptor_offset (desc);
551 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
553 if (dealloc && !onstack)
555 /* Free the temporary. */
556 tmp = gfc_conv_descriptor_data_get (desc);
557 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
558 gfc_add_expr_to_block (post, tmp);
563 /* Generate code to create and initialize the descriptor for a temporary
564 array. This is used for both temporaries needed by the scalarizer, and
565 functions returning arrays. Adjusts the loop variables to be
566 zero-based, and calculates the loop bounds for callee allocated arrays.
567 Allocate the array unless it's callee allocated (we have a callee
568 allocated array if 'callee_alloc' is true, or if loop->to[n] is
569 NULL_TREE for any n). Also fills in the descriptor, data and offset
570 fields of info if known. Returns the size of the array, or NULL for a
571 callee allocated array.
573 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
577 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
578 gfc_loopinfo * loop, gfc_ss_info * info,
579 tree eltype, bool dynamic, bool dealloc,
592 gcc_assert (info->dimen > 0);
593 /* Set the lower bound to zero. */
594 for (dim = 0; dim < info->dimen; dim++)
596 n = loop->order[dim];
597 /* TODO: Investigate why "if (n < loop->temp_dim)
598 gcc_assert (integer_zerop (loop->from[n]));" fails here. */
599 if (n >= loop->temp_dim)
601 /* Callee allocated arrays may not have a known bound yet. */
603 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
604 loop->to[n], loop->from[n]);
605 loop->from[n] = gfc_index_zero_node;
608 info->delta[dim] = gfc_index_zero_node;
609 info->start[dim] = gfc_index_zero_node;
610 info->end[dim] = gfc_index_zero_node;
611 info->stride[dim] = gfc_index_one_node;
612 info->dim[dim] = dim;
615 /* Initialize the descriptor. */
617 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
619 desc = gfc_create_var (type, "atmp");
620 GFC_DECL_PACKED_ARRAY (desc) = 1;
622 info->descriptor = desc;
623 size = gfc_index_one_node;
625 /* Fill in the array dtype. */
626 tmp = gfc_conv_descriptor_dtype (desc);
627 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
630 Fill in the bounds and stride. This is a packed array, so:
633 for (n = 0; n < rank; n++)
636 delta = ubound[n] + 1 - lbound[n];
639 size = size * sizeof(element);
644 for (n = 0; n < info->dimen; n++)
646 if (loop->to[n] == NULL_TREE)
648 /* For a callee allocated array express the loop bounds in terms
649 of the descriptor fields. */
651 fold_build2 (MINUS_EXPR, gfc_array_index_type,
652 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
653 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
659 /* Store the stride and bound components in the descriptor. */
660 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
661 gfc_add_modify_expr (pre, tmp, size);
663 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
664 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
666 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
667 gfc_add_modify_expr (pre, tmp, loop->to[n]);
669 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
670 loop->to[n], gfc_index_one_node);
672 /* Check whether the size for this dimension is negative. */
673 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
674 gfc_index_zero_node);
675 cond = gfc_evaluate_now (cond, pre);
680 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
682 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
683 size = gfc_evaluate_now (size, pre);
686 /* Get the size of the array. */
688 if (size && !callee_alloc)
690 /* If or_expr is true, then the extent in at least one
691 dimension is zero and the size is set to zero. */
692 size = fold_build3 (COND_EXPR, gfc_array_index_type,
693 or_expr, gfc_index_zero_node, size);
696 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
697 fold_convert (gfc_array_index_type,
698 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
706 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
709 if (info->dimen > loop->temp_dim)
710 loop->temp_dim = info->dimen;
716 /* Generate code to transpose array EXPR by creating a new descriptor
717 in which the dimension specifications have been reversed. */
720 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
722 tree dest, src, dest_index, src_index;
724 gfc_ss_info *dest_info, *src_info;
725 gfc_ss *dest_ss, *src_ss;
731 src_ss = gfc_walk_expr (expr);
734 src_info = &src_ss->data.info;
735 dest_info = &dest_ss->data.info;
736 gcc_assert (dest_info->dimen == 2);
737 gcc_assert (src_info->dimen == 2);
739 /* Get a descriptor for EXPR. */
740 gfc_init_se (&src_se, NULL);
741 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
742 gfc_add_block_to_block (&se->pre, &src_se.pre);
743 gfc_add_block_to_block (&se->post, &src_se.post);
746 /* Allocate a new descriptor for the return value. */
747 dest = gfc_create_var (TREE_TYPE (src), "atmp");
748 dest_info->descriptor = dest;
751 /* Copy across the dtype field. */
752 gfc_add_modify_expr (&se->pre,
753 gfc_conv_descriptor_dtype (dest),
754 gfc_conv_descriptor_dtype (src));
756 /* Copy the dimension information, renumbering dimension 1 to 0 and
758 for (n = 0; n < 2; n++)
760 dest_info->delta[n] = gfc_index_zero_node;
761 dest_info->start[n] = gfc_index_zero_node;
762 dest_info->end[n] = gfc_index_zero_node;
763 dest_info->stride[n] = gfc_index_one_node;
764 dest_info->dim[n] = n;
766 dest_index = gfc_rank_cst[n];
767 src_index = gfc_rank_cst[1 - n];
769 gfc_add_modify_expr (&se->pre,
770 gfc_conv_descriptor_stride (dest, dest_index),
771 gfc_conv_descriptor_stride (src, src_index));
773 gfc_add_modify_expr (&se->pre,
774 gfc_conv_descriptor_lbound (dest, dest_index),
775 gfc_conv_descriptor_lbound (src, src_index));
777 gfc_add_modify_expr (&se->pre,
778 gfc_conv_descriptor_ubound (dest, dest_index),
779 gfc_conv_descriptor_ubound (src, src_index));
783 gcc_assert (integer_zerop (loop->from[n]));
785 fold_build2 (MINUS_EXPR, gfc_array_index_type,
786 gfc_conv_descriptor_ubound (dest, dest_index),
787 gfc_conv_descriptor_lbound (dest, dest_index));
791 /* Copy the data pointer. */
792 dest_info->data = gfc_conv_descriptor_data_get (src);
793 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
795 /* Copy the offset. This is not changed by transposition; the top-left
796 element is still at the same offset as before, except where the loop
798 if (!integer_zerop (loop->from[0]))
799 dest_info->offset = gfc_conv_descriptor_offset (src);
801 dest_info->offset = gfc_index_zero_node;
803 gfc_add_modify_expr (&se->pre,
804 gfc_conv_descriptor_offset (dest),
807 if (dest_info->dimen > loop->temp_dim)
808 loop->temp_dim = dest_info->dimen;
812 /* Return the number of iterations in a loop that starts at START,
813 ends at END, and has step STEP. */
816 gfc_get_iteration_count (tree start, tree end, tree step)
821 type = TREE_TYPE (step);
822 tmp = fold_build2 (MINUS_EXPR, type, end, start);
823 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
824 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
825 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
826 return fold_convert (gfc_array_index_type, tmp);
830 /* Extend the data in array DESC by EXTRA elements. */
833 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
840 if (integer_zerop (extra))
843 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
845 /* Add EXTRA to the upper bound. */
846 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
847 gfc_add_modify_expr (pblock, ubound, tmp);
849 /* Get the value of the current data pointer. */
850 arg0 = gfc_conv_descriptor_data_get (desc);
852 /* Calculate the new array size. */
853 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
854 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
855 ubound, gfc_index_one_node);
856 arg1 = fold_build2 (MULT_EXPR, size_type_node,
857 fold_convert (size_type_node, tmp),
858 fold_convert (size_type_node, size));
860 /* Call the realloc() function. */
861 tmp = gfc_call_realloc (pblock, arg0, arg1);
862 gfc_conv_descriptor_data_set (pblock, desc, tmp);
866 /* Return true if the bounds of iterator I can only be determined
870 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
872 return (i->start->expr_type != EXPR_CONSTANT
873 || i->end->expr_type != EXPR_CONSTANT
874 || i->step->expr_type != EXPR_CONSTANT);
878 /* Split the size of constructor element EXPR into the sum of two terms,
879 one of which can be determined at compile time and one of which must
880 be calculated at run time. Set *SIZE to the former and return true
881 if the latter might be nonzero. */
884 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
886 if (expr->expr_type == EXPR_ARRAY)
887 return gfc_get_array_constructor_size (size, expr->value.constructor);
888 else if (expr->rank > 0)
890 /* Calculate everything at run time. */
891 mpz_set_ui (*size, 0);
896 /* A single element. */
897 mpz_set_ui (*size, 1);
903 /* Like gfc_get_array_constructor_element_size, but applied to the whole
904 of array constructor C. */
907 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
914 mpz_set_ui (*size, 0);
919 for (; c; c = c->next)
922 if (i && gfc_iterator_has_dynamic_bounds (i))
926 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
929 /* Multiply the static part of the element size by the
930 number of iterations. */
931 mpz_sub (val, i->end->value.integer, i->start->value.integer);
932 mpz_fdiv_q (val, val, i->step->value.integer);
933 mpz_add_ui (val, val, 1);
934 if (mpz_sgn (val) > 0)
935 mpz_mul (len, len, val);
939 mpz_add (*size, *size, len);
948 /* Make sure offset is a variable. */
951 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
954 /* We should have already created the offset variable. We cannot
955 create it here because we may be in an inner scope. */
956 gcc_assert (*offsetvar != NULL_TREE);
957 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
958 *poffset = *offsetvar;
959 TREE_USED (*offsetvar) = 1;
963 /* Assign an element of an array constructor. */
964 static bool first_len;
965 static tree first_len_val;
968 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
969 tree offset, gfc_se * se, gfc_expr * expr)
974 gfc_conv_expr (se, expr);
976 /* Store the value. */
977 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
978 tmp = gfc_build_array_ref (tmp, offset, NULL);
980 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
981 esize = fold_convert (gfc_charlen_type_node, esize);
983 if (expr->ts.type == BT_CHARACTER)
985 gfc_conv_string_parameter (se);
986 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
988 /* The temporary is an array of pointers. */
989 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
990 gfc_add_modify_expr (&se->pre, tmp, se->expr);
994 /* The temporary is an array of string values. */
995 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
996 /* We know the temporary and the value will be the same length,
997 so can use memcpy. */
998 gfc_trans_string_copy (&se->pre, esize, tmp,
1002 if (flag_bounds_check)
1006 gfc_add_modify_expr (&se->pre, first_len_val,
1012 /* Verify that all constructor elements are of the same
1014 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1015 first_len_val, se->string_length);
1016 gfc_trans_runtime_check
1017 (cond, &se->pre, &expr->where,
1018 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1019 fold_convert (long_integer_type_node, first_len_val),
1020 fold_convert (long_integer_type_node, se->string_length));
1026 /* TODO: Should the frontend already have done this conversion? */
1027 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1028 gfc_add_modify_expr (&se->pre, tmp, se->expr);
1031 gfc_add_block_to_block (pblock, &se->pre);
1032 gfc_add_block_to_block (pblock, &se->post);
1036 /* Add the contents of an array to the constructor. DYNAMIC is as for
1037 gfc_trans_array_constructor_value. */
1040 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1041 tree type ATTRIBUTE_UNUSED,
1042 tree desc, gfc_expr * expr,
1043 tree * poffset, tree * offsetvar,
1054 /* We need this to be a variable so we can increment it. */
1055 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1057 gfc_init_se (&se, NULL);
1059 /* Walk the array expression. */
1060 ss = gfc_walk_expr (expr);
1061 gcc_assert (ss != gfc_ss_terminator);
1063 /* Initialize the scalarizer. */
1064 gfc_init_loopinfo (&loop);
1065 gfc_add_ss_to_loop (&loop, ss);
1067 /* Initialize the loop. */
1068 gfc_conv_ss_startstride (&loop);
1069 gfc_conv_loop_setup (&loop);
1071 /* Make sure the constructed array has room for the new data. */
1074 /* Set SIZE to the total number of elements in the subarray. */
1075 size = gfc_index_one_node;
1076 for (n = 0; n < loop.dimen; n++)
1078 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1079 gfc_index_one_node);
1080 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1083 /* Grow the constructed array by SIZE elements. */
1084 gfc_grow_array (&loop.pre, desc, size);
1087 /* Make the loop body. */
1088 gfc_mark_ss_chain_used (ss, 1);
1089 gfc_start_scalarized_body (&loop, &body);
1090 gfc_copy_loopinfo_to_se (&se, &loop);
1093 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1094 gcc_assert (se.ss == gfc_ss_terminator);
1096 /* Increment the offset. */
1097 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1098 *poffset, gfc_index_one_node);
1099 gfc_add_modify_expr (&body, *poffset, tmp);
1101 /* Finish the loop. */
1102 gfc_trans_scalarizing_loops (&loop, &body);
1103 gfc_add_block_to_block (&loop.pre, &loop.post);
1104 tmp = gfc_finish_block (&loop.pre);
1105 gfc_add_expr_to_block (pblock, tmp);
1107 gfc_cleanup_loop (&loop);
1111 /* Assign the values to the elements of an array constructor. DYNAMIC
1112 is true if descriptor DESC only contains enough data for the static
1113 size calculated by gfc_get_array_constructor_size. When true, memory
1114 for the dynamic parts must be allocated using realloc. */
1117 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1118 tree desc, gfc_constructor * c,
1119 tree * poffset, tree * offsetvar,
1128 for (; c; c = c->next)
1130 /* If this is an iterator or an array, the offset must be a variable. */
1131 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1132 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1134 gfc_start_block (&body);
1136 if (c->expr->expr_type == EXPR_ARRAY)
1138 /* Array constructors can be nested. */
1139 gfc_trans_array_constructor_value (&body, type, desc,
1140 c->expr->value.constructor,
1141 poffset, offsetvar, dynamic);
1143 else if (c->expr->rank > 0)
1145 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1146 poffset, offsetvar, dynamic);
1150 /* This code really upsets the gimplifier so don't bother for now. */
1157 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1164 /* Scalar values. */
1165 gfc_init_se (&se, NULL);
1166 gfc_trans_array_ctor_element (&body, desc, *poffset,
1169 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1170 *poffset, gfc_index_one_node);
1174 /* Collect multiple scalar constants into a constructor. */
1182 /* Count the number of consecutive scalar constants. */
1183 while (p && !(p->iterator
1184 || p->expr->expr_type != EXPR_CONSTANT))
1186 gfc_init_se (&se, NULL);
1187 gfc_conv_constant (&se, p->expr);
1188 if (p->expr->ts.type == BT_CHARACTER
1189 && POINTER_TYPE_P (type))
1191 /* For constant character array constructors we build
1192 an array of pointers. */
1193 se.expr = gfc_build_addr_expr (pchar_type_node,
1197 list = tree_cons (NULL_TREE, se.expr, list);
1202 bound = build_int_cst (NULL_TREE, n - 1);
1203 /* Create an array type to hold them. */
1204 tmptype = build_range_type (gfc_array_index_type,
1205 gfc_index_zero_node, bound);
1206 tmptype = build_array_type (type, tmptype);
1208 init = build_constructor_from_list (tmptype, nreverse (list));
1209 TREE_CONSTANT (init) = 1;
1210 TREE_INVARIANT (init) = 1;
1211 TREE_STATIC (init) = 1;
1212 /* Create a static variable to hold the data. */
1213 tmp = gfc_create_var (tmptype, "data");
1214 TREE_STATIC (tmp) = 1;
1215 TREE_CONSTANT (tmp) = 1;
1216 TREE_INVARIANT (tmp) = 1;
1217 TREE_READONLY (tmp) = 1;
1218 DECL_INITIAL (tmp) = init;
1221 /* Use BUILTIN_MEMCPY to assign the values. */
1222 tmp = gfc_conv_descriptor_data_get (desc);
1223 tmp = build_fold_indirect_ref (tmp);
1224 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1225 tmp = build_fold_addr_expr (tmp);
1226 init = build_fold_addr_expr (init);
1228 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1229 bound = build_int_cst (NULL_TREE, n * size);
1230 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1232 gfc_add_expr_to_block (&body, tmp);
1234 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1236 build_int_cst (gfc_array_index_type, n));
1238 if (!INTEGER_CST_P (*poffset))
1240 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1241 *poffset = *offsetvar;
1245 /* The frontend should already have done any expansions possible
1249 /* Pass the code as is. */
1250 tmp = gfc_finish_block (&body);
1251 gfc_add_expr_to_block (pblock, tmp);
1255 /* Build the implied do-loop. */
1265 loopbody = gfc_finish_block (&body);
1267 if (c->iterator->var->symtree->n.sym->backend_decl)
1269 gfc_init_se (&se, NULL);
1270 gfc_conv_expr (&se, c->iterator->var);
1271 gfc_add_block_to_block (pblock, &se.pre);
1276 /* If the iterator appears in a specification expression in
1277 an interface mapping, we need to make a temp for the loop
1278 variable because it is not declared locally. */
1279 loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
1280 loopvar = gfc_create_var (loopvar, "loopvar");
1283 /* Make a temporary, store the current value in that
1284 and return it, once the loop is done. */
1285 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1286 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1288 /* Initialize the loop. */
1289 gfc_init_se (&se, NULL);
1290 gfc_conv_expr_val (&se, c->iterator->start);
1291 gfc_add_block_to_block (pblock, &se.pre);
1292 gfc_add_modify_expr (pblock, loopvar, se.expr);
1294 gfc_init_se (&se, NULL);
1295 gfc_conv_expr_val (&se, c->iterator->end);
1296 gfc_add_block_to_block (pblock, &se.pre);
1297 end = gfc_evaluate_now (se.expr, pblock);
1299 gfc_init_se (&se, NULL);
1300 gfc_conv_expr_val (&se, c->iterator->step);
1301 gfc_add_block_to_block (pblock, &se.pre);
1302 step = gfc_evaluate_now (se.expr, pblock);
1304 /* If this array expands dynamically, and the number of iterations
1305 is not constant, we won't have allocated space for the static
1306 part of C->EXPR's size. Do that now. */
1307 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1309 /* Get the number of iterations. */
1310 tmp = gfc_get_iteration_count (loopvar, end, step);
1312 /* Get the static part of C->EXPR's size. */
1313 gfc_get_array_constructor_element_size (&size, c->expr);
1314 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1316 /* Grow the array by TMP * TMP2 elements. */
1317 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1318 gfc_grow_array (pblock, desc, tmp);
1321 /* Generate the loop body. */
1322 exit_label = gfc_build_label_decl (NULL_TREE);
1323 gfc_start_block (&body);
1325 /* Generate the exit condition. Depending on the sign of
1326 the step variable we have to generate the correct
1328 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1329 build_int_cst (TREE_TYPE (step), 0));
1330 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1331 fold_build2 (GT_EXPR, boolean_type_node,
1333 fold_build2 (LT_EXPR, boolean_type_node,
1335 tmp = build1_v (GOTO_EXPR, exit_label);
1336 TREE_USED (exit_label) = 1;
1337 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1338 gfc_add_expr_to_block (&body, tmp);
1340 /* The main loop body. */
1341 gfc_add_expr_to_block (&body, loopbody);
1343 /* Increase loop variable by step. */
1344 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1345 gfc_add_modify_expr (&body, loopvar, tmp);
1347 /* Finish the loop. */
1348 tmp = gfc_finish_block (&body);
1349 tmp = build1_v (LOOP_EXPR, tmp);
1350 gfc_add_expr_to_block (pblock, tmp);
1352 /* Add the exit label. */
1353 tmp = build1_v (LABEL_EXPR, exit_label);
1354 gfc_add_expr_to_block (pblock, tmp);
1356 /* Restore the original value of the loop counter. */
1357 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1364 /* Figure out the string length of a variable reference expression.
1365 Used by get_array_ctor_strlen. */
1368 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1374 /* Don't bother if we already know the length is a constant. */
1375 if (*len && INTEGER_CST_P (*len))
1378 ts = &expr->symtree->n.sym->ts;
1379 for (ref = expr->ref; ref; ref = ref->next)
1384 /* Array references don't change the string length. */
1388 /* Use the length of the component. */
1389 ts = &ref->u.c.component->ts;
1393 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1394 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1396 mpz_init_set_ui (char_len, 1);
1397 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1398 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1399 *len = gfc_conv_mpz_to_tree (char_len,
1400 gfc_default_character_kind);
1401 *len = convert (gfc_charlen_type_node, *len);
1402 mpz_clear (char_len);
1406 /* TODO: Substrings are tricky because we can't evaluate the
1407 expression more than once. For now we just give up, and hope
1408 we can figure it out elsewhere. */
1413 *len = ts->cl->backend_decl;
1417 /* A catch-all to obtain the string length for anything that is not a
1418 constant, array or variable. */
1420 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1425 /* Don't bother if we already know the length is a constant. */
1426 if (*len && INTEGER_CST_P (*len))
1429 if (!e->ref && e->ts.cl && e->ts.cl->length
1430 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1433 gfc_conv_const_charlen (e->ts.cl);
1434 *len = e->ts.cl->backend_decl;
1438 /* Otherwise, be brutal even if inefficient. */
1439 ss = gfc_walk_expr (e);
1440 gfc_init_se (&se, NULL);
1442 /* No function call, in case of side effects. */
1443 se.no_function_call = 1;
1444 if (ss == gfc_ss_terminator)
1445 gfc_conv_expr (&se, e);
1447 gfc_conv_expr_descriptor (&se, e, ss);
1449 /* Fix the value. */
1450 *len = gfc_evaluate_now (se.string_length, &se.pre);
1452 gfc_add_block_to_block (block, &se.pre);
1453 gfc_add_block_to_block (block, &se.post);
1455 e->ts.cl->backend_decl = *len;
1460 /* Figure out the string length of a character array constructor.
1461 Returns TRUE if all elements are character constants. */
1464 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1472 *len = build_int_cstu (gfc_charlen_type_node, 0);
1476 for (; c; c = c->next)
1478 switch (c->expr->expr_type)
1481 if (!(*len && INTEGER_CST_P (*len)))
1482 *len = build_int_cstu (gfc_charlen_type_node,
1483 c->expr->value.character.length);
1487 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1493 get_array_ctor_var_strlen (c->expr, len);
1498 get_array_ctor_all_strlen (block, c->expr, len);
1506 /* Check whether the array constructor C consists entirely of constant
1507 elements, and if so returns the number of those elements, otherwise
1508 return zero. Note, an empty or NULL array constructor returns zero. */
1510 unsigned HOST_WIDE_INT
1511 gfc_constant_array_constructor_p (gfc_constructor * c)
1513 unsigned HOST_WIDE_INT nelem = 0;
1518 || c->expr->rank > 0
1519 || c->expr->expr_type != EXPR_CONSTANT)
1528 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1529 and the tree type of it's elements, TYPE, return a static constant
1530 variable that is compile-time initialized. */
1533 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1535 tree tmptype, list, init, tmp;
1536 HOST_WIDE_INT nelem;
1542 /* First traverse the constructor list, converting the constants
1543 to tree to build an initializer. */
1546 c = expr->value.constructor;
1549 gfc_init_se (&se, NULL);
1550 gfc_conv_constant (&se, c->expr);
1551 if (c->expr->ts.type == BT_CHARACTER
1552 && POINTER_TYPE_P (type))
1553 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1554 list = tree_cons (NULL_TREE, se.expr, list);
1559 /* Next determine the tree type for the array. We use the gfortran
1560 front-end's gfc_get_nodesc_array_type in order to create a suitable
1561 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1563 memset (&as, 0, sizeof (gfc_array_spec));
1565 as.rank = expr->rank;
1566 as.type = AS_EXPLICIT;
1569 as.lower[0] = gfc_int_expr (0);
1570 as.upper[0] = gfc_int_expr (nelem - 1);
1573 for (i = 0; i < expr->rank; i++)
1575 int tmp = (int) mpz_get_si (expr->shape[i]);
1576 as.lower[i] = gfc_int_expr (0);
1577 as.upper[i] = gfc_int_expr (tmp - 1);
1580 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1582 init = build_constructor_from_list (tmptype, nreverse (list));
1584 TREE_CONSTANT (init) = 1;
1585 TREE_INVARIANT (init) = 1;
1586 TREE_STATIC (init) = 1;
1588 tmp = gfc_create_var (tmptype, "A");
1589 TREE_STATIC (tmp) = 1;
1590 TREE_CONSTANT (tmp) = 1;
1591 TREE_INVARIANT (tmp) = 1;
1592 TREE_READONLY (tmp) = 1;
1593 DECL_INITIAL (tmp) = init;
1599 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1600 This mostly initializes the scalarizer state info structure with the
1601 appropriate values to directly use the array created by the function
1602 gfc_build_constant_array_constructor. */
1605 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1606 gfc_ss * ss, tree type)
1612 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1614 info = &ss->data.info;
1616 info->descriptor = tmp;
1617 info->data = build_fold_addr_expr (tmp);
1618 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1621 for (i = 0; i < info->dimen; i++)
1623 info->delta[i] = gfc_index_zero_node;
1624 info->start[i] = gfc_index_zero_node;
1625 info->end[i] = gfc_index_zero_node;
1626 info->stride[i] = gfc_index_one_node;
1630 if (info->dimen > loop->temp_dim)
1631 loop->temp_dim = info->dimen;
1634 /* Helper routine of gfc_trans_array_constructor to determine if the
1635 bounds of the loop specified by LOOP are constant and simple enough
1636 to use with gfc_trans_constant_array_constructor. Returns the
1637 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1640 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1642 tree size = gfc_index_one_node;
1646 for (i = 0; i < loop->dimen; i++)
1648 /* If the bounds aren't constant, return NULL_TREE. */
1649 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1651 if (!integer_zerop (loop->from[i]))
1653 /* Only allow nonzero "from" in one-dimensional arrays. */
1654 if (loop->dimen != 1)
1656 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1657 loop->to[i], loop->from[i]);
1661 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1662 tmp, gfc_index_one_node);
1663 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1670 /* Array constructors are handled by constructing a temporary, then using that
1671 within the scalarization loop. This is not optimal, but seems by far the
1675 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1684 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER)
1686 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1690 ss->data.info.dimen = loop->dimen;
1692 c = ss->expr->value.constructor;
1693 if (ss->expr->ts.type == BT_CHARACTER)
1695 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1697 /* Complex character array constructors should have been taken care of
1698 and not end up here. */
1699 gcc_assert (ss->string_length);
1701 ss->expr->ts.cl->backend_decl = ss->string_length;
1703 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1705 type = build_pointer_type (type);
1708 type = gfc_typenode_for_spec (&ss->expr->ts);
1710 /* See if the constructor determines the loop bounds. */
1713 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1715 /* We have a multidimensional parameter. */
1717 for (n = 0; n < ss->expr->rank; n++)
1719 loop->from[n] = gfc_index_zero_node;
1720 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1721 gfc_index_integer_kind);
1722 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1723 loop->to[n], gfc_index_one_node);
1727 if (loop->to[0] == NULL_TREE)
1731 /* We should have a 1-dimensional, zero-based loop. */
1732 gcc_assert (loop->dimen == 1);
1733 gcc_assert (integer_zerop (loop->from[0]));
1735 /* Split the constructor size into a static part and a dynamic part.
1736 Allocate the static size up-front and record whether the dynamic
1737 size might be nonzero. */
1739 dynamic = gfc_get_array_constructor_size (&size, c);
1740 mpz_sub_ui (size, size, 1);
1741 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1745 /* Special case constant array constructors. */
1748 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1751 tree size = constant_array_constructor_loop_size (loop);
1752 if (size && compare_tree_int (size, nelem) == 0)
1754 gfc_trans_constant_array_constructor (loop, ss, type);
1760 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1761 type, dynamic, true, false);
1763 desc = ss->data.info.descriptor;
1764 offset = gfc_index_zero_node;
1765 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1766 TREE_NO_WARNING (offsetvar) = 1;
1767 TREE_USED (offsetvar) = 0;
1768 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1769 &offset, &offsetvar, dynamic);
1771 /* If the array grows dynamically, the upper bound of the loop variable
1772 is determined by the array's final upper bound. */
1774 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1776 if (TREE_USED (offsetvar))
1777 pushdecl (offsetvar);
1779 gcc_assert (INTEGER_CST_P (offset));
1781 /* Disable bound checking for now because it's probably broken. */
1782 if (flag_bounds_check)
1790 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1791 called after evaluating all of INFO's vector dimensions. Go through
1792 each such vector dimension and see if we can now fill in any missing
1796 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1805 for (n = 0; n < loop->dimen; n++)
1808 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1809 && loop->to[n] == NULL)
1811 /* Loop variable N indexes vector dimension DIM, and we don't
1812 yet know the upper bound of loop variable N. Set it to the
1813 difference between the vector's upper and lower bounds. */
1814 gcc_assert (loop->from[n] == gfc_index_zero_node);
1815 gcc_assert (info->subscript[dim]
1816 && info->subscript[dim]->type == GFC_SS_VECTOR);
1818 gfc_init_se (&se, NULL);
1819 desc = info->subscript[dim]->data.info.descriptor;
1820 zero = gfc_rank_cst[0];
1821 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1822 gfc_conv_descriptor_ubound (desc, zero),
1823 gfc_conv_descriptor_lbound (desc, zero));
1824 tmp = gfc_evaluate_now (tmp, &loop->pre);
1831 /* Add the pre and post chains for all the scalar expressions in a SS chain
1832 to loop. This is called after the loop parameters have been calculated,
1833 but before the actual scalarizing loops. */
1836 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1841 /* TODO: This can generate bad code if there are ordering dependencies.
1842 eg. a callee allocated function and an unknown size constructor. */
1843 gcc_assert (ss != NULL);
1845 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1852 /* Scalar expression. Evaluate this now. This includes elemental
1853 dimension indices, but not array section bounds. */
1854 gfc_init_se (&se, NULL);
1855 gfc_conv_expr (&se, ss->expr);
1856 gfc_add_block_to_block (&loop->pre, &se.pre);
1858 if (ss->expr->ts.type != BT_CHARACTER)
1860 /* Move the evaluation of scalar expressions outside the
1861 scalarization loop. */
1863 se.expr = convert(gfc_array_index_type, se.expr);
1864 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1865 gfc_add_block_to_block (&loop->pre, &se.post);
1868 gfc_add_block_to_block (&loop->post, &se.post);
1870 ss->data.scalar.expr = se.expr;
1871 ss->string_length = se.string_length;
1874 case GFC_SS_REFERENCE:
1875 /* Scalar reference. Evaluate this now. */
1876 gfc_init_se (&se, NULL);
1877 gfc_conv_expr_reference (&se, ss->expr);
1878 gfc_add_block_to_block (&loop->pre, &se.pre);
1879 gfc_add_block_to_block (&loop->post, &se.post);
1881 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1882 ss->string_length = se.string_length;
1885 case GFC_SS_SECTION:
1886 /* Add the expressions for scalar and vector subscripts. */
1887 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1888 if (ss->data.info.subscript[n])
1889 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1891 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1895 /* Get the vector's descriptor and store it in SS. */
1896 gfc_init_se (&se, NULL);
1897 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1898 gfc_add_block_to_block (&loop->pre, &se.pre);
1899 gfc_add_block_to_block (&loop->post, &se.post);
1900 ss->data.info.descriptor = se.expr;
1903 case GFC_SS_INTRINSIC:
1904 gfc_add_intrinsic_ss_code (loop, ss);
1907 case GFC_SS_FUNCTION:
1908 /* Array function return value. We call the function and save its
1909 result in a temporary for use inside the loop. */
1910 gfc_init_se (&se, NULL);
1913 gfc_conv_expr (&se, ss->expr);
1914 gfc_add_block_to_block (&loop->pre, &se.pre);
1915 gfc_add_block_to_block (&loop->post, &se.post);
1916 ss->string_length = se.string_length;
1919 case GFC_SS_CONSTRUCTOR:
1920 if (ss->expr->ts.type == BT_CHARACTER
1921 && ss->string_length == NULL
1923 && ss->expr->ts.cl->length)
1925 gfc_init_se (&se, NULL);
1926 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
1927 gfc_charlen_type_node);
1928 ss->string_length = se.expr;
1929 gfc_add_block_to_block (&loop->pre, &se.pre);
1930 gfc_add_block_to_block (&loop->post, &se.post);
1932 gfc_trans_array_constructor (loop, ss);
1936 case GFC_SS_COMPONENT:
1937 /* Do nothing. These are handled elsewhere. */
1947 /* Translate expressions for the descriptor and data pointer of a SS. */
1951 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1956 /* Get the descriptor for the array to be scalarized. */
1957 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1958 gfc_init_se (&se, NULL);
1959 se.descriptor_only = 1;
1960 gfc_conv_expr_lhs (&se, ss->expr);
1961 gfc_add_block_to_block (block, &se.pre);
1962 ss->data.info.descriptor = se.expr;
1963 ss->string_length = se.string_length;
1967 /* Also the data pointer. */
1968 tmp = gfc_conv_array_data (se.expr);
1969 /* If this is a variable or address of a variable we use it directly.
1970 Otherwise we must evaluate it now to avoid breaking dependency
1971 analysis by pulling the expressions for elemental array indices
1974 || (TREE_CODE (tmp) == ADDR_EXPR
1975 && DECL_P (TREE_OPERAND (tmp, 0)))))
1976 tmp = gfc_evaluate_now (tmp, block);
1977 ss->data.info.data = tmp;
1979 tmp = gfc_conv_array_offset (se.expr);
1980 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1985 /* Initialize a gfc_loopinfo structure. */
1988 gfc_init_loopinfo (gfc_loopinfo * loop)
1992 memset (loop, 0, sizeof (gfc_loopinfo));
1993 gfc_init_block (&loop->pre);
1994 gfc_init_block (&loop->post);
1996 /* Initially scalarize in order. */
1997 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2000 loop->ss = gfc_ss_terminator;
2004 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2008 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2014 /* Return an expression for the data pointer of an array. */
2017 gfc_conv_array_data (tree descriptor)
2021 type = TREE_TYPE (descriptor);
2022 if (GFC_ARRAY_TYPE_P (type))
2024 if (TREE_CODE (type) == POINTER_TYPE)
2028 /* Descriptorless arrays. */
2029 return build_fold_addr_expr (descriptor);
2033 return gfc_conv_descriptor_data_get (descriptor);
2037 /* Return an expression for the base offset of an array. */
2040 gfc_conv_array_offset (tree descriptor)
2044 type = TREE_TYPE (descriptor);
2045 if (GFC_ARRAY_TYPE_P (type))
2046 return GFC_TYPE_ARRAY_OFFSET (type);
2048 return gfc_conv_descriptor_offset (descriptor);
2052 /* Get an expression for the array stride. */
2055 gfc_conv_array_stride (tree descriptor, int dim)
2060 type = TREE_TYPE (descriptor);
2062 /* For descriptorless arrays use the array size. */
2063 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2064 if (tmp != NULL_TREE)
2067 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2072 /* Like gfc_conv_array_stride, but for the lower bound. */
2075 gfc_conv_array_lbound (tree descriptor, int dim)
2080 type = TREE_TYPE (descriptor);
2082 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2083 if (tmp != NULL_TREE)
2086 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2091 /* Like gfc_conv_array_stride, but for the upper bound. */
2094 gfc_conv_array_ubound (tree descriptor, int dim)
2099 type = TREE_TYPE (descriptor);
2101 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2102 if (tmp != NULL_TREE)
2105 /* This should only ever happen when passing an assumed shape array
2106 as an actual parameter. The value will never be used. */
2107 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2108 return gfc_index_zero_node;
2110 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2115 /* Generate code to perform an array index bound check. */
2118 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2119 locus * where, bool check_upper)
2124 const char * name = NULL;
2126 if (!flag_bounds_check)
2129 index = gfc_evaluate_now (index, &se->pre);
2131 /* We find a name for the error message. */
2133 name = se->ss->expr->symtree->name;
2135 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2136 && se->loop->ss->expr->symtree)
2137 name = se->loop->ss->expr->symtree->name;
2139 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2140 && se->loop->ss->loop_chain->expr
2141 && se->loop->ss->loop_chain->expr->symtree)
2142 name = se->loop->ss->loop_chain->expr->symtree->name;
2144 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2145 && se->loop->ss->loop_chain->expr->symtree)
2146 name = se->loop->ss->loop_chain->expr->symtree->name;
2148 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2150 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2151 && se->loop->ss->expr->value.function.name)
2152 name = se->loop->ss->expr->value.function.name;
2154 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2155 || se->loop->ss->type == GFC_SS_SCALAR)
2156 name = "unnamed constant";
2159 /* Check lower bound. */
2160 tmp = gfc_conv_array_lbound (descriptor, n);
2161 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2163 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2164 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2166 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2167 gfc_msg_fault, n+1);
2168 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2169 fold_convert (long_integer_type_node, index),
2170 fold_convert (long_integer_type_node, tmp));
2173 /* Check upper bound. */
2176 tmp = gfc_conv_array_ubound (descriptor, n);
2177 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2179 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2180 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2182 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2183 gfc_msg_fault, n+1);
2184 gfc_trans_runtime_check (fault, &se->pre, where, msg,
2185 fold_convert (long_integer_type_node, index),
2186 fold_convert (long_integer_type_node, tmp));
2194 /* Return the offset for an index. Performs bound checking for elemental
2195 dimensions. Single element references are processed separately. */
2198 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2199 gfc_array_ref * ar, tree stride)
2205 /* Get the index into the array for this dimension. */
2208 gcc_assert (ar->type != AR_ELEMENT);
2209 switch (ar->dimen_type[dim])
2212 gcc_assert (i == -1);
2213 /* Elemental dimension. */
2214 gcc_assert (info->subscript[dim]
2215 && info->subscript[dim]->type == GFC_SS_SCALAR);
2216 /* We've already translated this value outside the loop. */
2217 index = info->subscript[dim]->data.scalar.expr;
2219 index = gfc_trans_array_bound_check (se, info->descriptor,
2220 index, dim, &ar->where,
2221 (ar->as->type != AS_ASSUMED_SIZE
2222 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2226 gcc_assert (info && se->loop);
2227 gcc_assert (info->subscript[dim]
2228 && info->subscript[dim]->type == GFC_SS_VECTOR);
2229 desc = info->subscript[dim]->data.info.descriptor;
2231 /* Get a zero-based index into the vector. */
2232 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2233 se->loop->loopvar[i], se->loop->from[i]);
2235 /* Multiply the index by the stride. */
2236 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2237 index, gfc_conv_array_stride (desc, 0));
2239 /* Read the vector to get an index into info->descriptor. */
2240 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2241 index = gfc_build_array_ref (data, index, NULL);
2242 index = gfc_evaluate_now (index, &se->pre);
2244 /* Do any bounds checking on the final info->descriptor index. */
2245 index = gfc_trans_array_bound_check (se, info->descriptor,
2246 index, dim, &ar->where,
2247 (ar->as->type != AS_ASSUMED_SIZE
2248 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2252 /* Scalarized dimension. */
2253 gcc_assert (info && se->loop);
2255 /* Multiply the loop variable by the stride and delta. */
2256 index = se->loop->loopvar[i];
2257 if (!integer_onep (info->stride[i]))
2258 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2260 if (!integer_zerop (info->delta[i]))
2261 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2271 /* Temporary array or derived type component. */
2272 gcc_assert (se->loop);
2273 index = se->loop->loopvar[se->loop->order[i]];
2274 if (!integer_zerop (info->delta[i]))
2275 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2276 index, info->delta[i]);
2279 /* Multiply by the stride. */
2280 if (!integer_onep (stride))
2281 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2287 /* Build a scalarized reference to an array. */
2290 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2293 tree decl = NULL_TREE;
2298 info = &se->ss->data.info;
2300 n = se->loop->order[0];
2304 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2306 /* Add the offset for this dimension to the stored offset for all other
2308 if (!integer_zerop (info->offset))
2309 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2311 if (se->ss->expr && is_subref_array (se->ss->expr))
2312 decl = se->ss->expr->symtree->n.sym->backend_decl;
2314 tmp = build_fold_indirect_ref (info->data);
2315 se->expr = gfc_build_array_ref (tmp, index, decl);
2319 /* Translate access of temporary array. */
2322 gfc_conv_tmp_array_ref (gfc_se * se)
2324 se->string_length = se->ss->string_length;
2325 gfc_conv_scalarized_array_ref (se, NULL);
2329 /* Build an array reference. se->expr already holds the array descriptor.
2330 This should be either a variable, indirect variable reference or component
2331 reference. For arrays which do not have a descriptor, se->expr will be
2333 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2336 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2345 /* Handle scalarized references separately. */
2346 if (ar->type != AR_ELEMENT)
2348 gfc_conv_scalarized_array_ref (se, ar);
2349 gfc_advance_se_ss_chain (se);
2353 index = gfc_index_zero_node;
2355 /* Calculate the offsets from all the dimensions. */
2356 for (n = 0; n < ar->dimen; n++)
2358 /* Calculate the index for this dimension. */
2359 gfc_init_se (&indexse, se);
2360 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2361 gfc_add_block_to_block (&se->pre, &indexse.pre);
2363 if (flag_bounds_check)
2365 /* Check array bounds. */
2369 /* Evaluate the indexse.expr only once. */
2370 indexse.expr = save_expr (indexse.expr);
2373 tmp = gfc_conv_array_lbound (se->expr, n);
2374 cond = fold_build2 (LT_EXPR, boolean_type_node,
2376 asprintf (&msg, "%s for array '%s', "
2377 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2378 gfc_msg_fault, sym->name, n+1);
2379 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2380 fold_convert (long_integer_type_node,
2382 fold_convert (long_integer_type_node, tmp));
2385 /* Upper bound, but not for the last dimension of assumed-size
2387 if (n < ar->dimen - 1
2388 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2390 tmp = gfc_conv_array_ubound (se->expr, n);
2391 cond = fold_build2 (GT_EXPR, boolean_type_node,
2393 asprintf (&msg, "%s for array '%s', "
2394 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2395 gfc_msg_fault, sym->name, n+1);
2396 gfc_trans_runtime_check (cond, &se->pre, where, msg,
2397 fold_convert (long_integer_type_node,
2399 fold_convert (long_integer_type_node, tmp));
2404 /* Multiply the index by the stride. */
2405 stride = gfc_conv_array_stride (se->expr, n);
2406 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2409 /* And add it to the total. */
2410 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2413 tmp = gfc_conv_array_offset (se->expr);
2414 if (!integer_zerop (tmp))
2415 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2417 /* Access the calculated element. */
2418 tmp = gfc_conv_array_data (se->expr);
2419 tmp = build_fold_indirect_ref (tmp);
2420 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2424 /* Generate the code to be executed immediately before entering a
2425 scalarization loop. */
2428 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2429 stmtblock_t * pblock)
2438 /* This code will be executed before entering the scalarization loop
2439 for this dimension. */
2440 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2442 if ((ss->useflags & flag) == 0)
2445 if (ss->type != GFC_SS_SECTION
2446 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2447 && ss->type != GFC_SS_COMPONENT)
2450 info = &ss->data.info;
2452 if (dim >= info->dimen)
2455 if (dim == info->dimen - 1)
2457 /* For the outermost loop calculate the offset due to any
2458 elemental dimensions. It will have been initialized with the
2459 base offset of the array. */
2462 for (i = 0; i < info->ref->u.ar.dimen; i++)
2464 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2467 gfc_init_se (&se, NULL);
2469 se.expr = info->descriptor;
2470 stride = gfc_conv_array_stride (info->descriptor, i);
2471 index = gfc_conv_array_index_offset (&se, info, i, -1,
2474 gfc_add_block_to_block (pblock, &se.pre);
2476 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2477 info->offset, index);
2478 info->offset = gfc_evaluate_now (info->offset, pblock);
2482 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2485 stride = gfc_conv_array_stride (info->descriptor, 0);
2487 /* Calculate the stride of the innermost loop. Hopefully this will
2488 allow the backend optimizers to do their stuff more effectively.
2490 info->stride0 = gfc_evaluate_now (stride, pblock);
2494 /* Add the offset for the previous loop dimension. */
2499 ar = &info->ref->u.ar;
2500 i = loop->order[dim + 1];
2508 gfc_init_se (&se, NULL);
2510 se.expr = info->descriptor;
2511 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2512 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2514 gfc_add_block_to_block (pblock, &se.pre);
2515 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2516 info->offset, index);
2517 info->offset = gfc_evaluate_now (info->offset, pblock);
2520 /* Remember this offset for the second loop. */
2521 if (dim == loop->temp_dim - 1)
2522 info->saved_offset = info->offset;
2527 /* Start a scalarized expression. Creates a scope and declares loop
2531 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2537 gcc_assert (!loop->array_parameter);
2539 for (dim = loop->dimen - 1; dim >= 0; dim--)
2541 n = loop->order[dim];
2543 gfc_start_block (&loop->code[n]);
2545 /* Create the loop variable. */
2546 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2548 if (dim < loop->temp_dim)
2552 /* Calculate values that will be constant within this loop. */
2553 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2555 gfc_start_block (pbody);
2559 /* Generates the actual loop code for a scalarization loop. */
2562 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2563 stmtblock_t * pbody)
2571 loopbody = gfc_finish_block (pbody);
2573 /* Initialize the loopvar. */
2574 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2576 exit_label = gfc_build_label_decl (NULL_TREE);
2578 /* Generate the loop body. */
2579 gfc_init_block (&block);
2581 /* The exit condition. */
2582 cond = fold_build2 (GT_EXPR, boolean_type_node,
2583 loop->loopvar[n], loop->to[n]);
2584 tmp = build1_v (GOTO_EXPR, exit_label);
2585 TREE_USED (exit_label) = 1;
2586 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2587 gfc_add_expr_to_block (&block, tmp);
2589 /* The main body. */
2590 gfc_add_expr_to_block (&block, loopbody);
2592 /* Increment the loopvar. */
2593 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2594 loop->loopvar[n], gfc_index_one_node);
2595 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2597 /* Build the loop. */
2598 tmp = gfc_finish_block (&block);
2599 tmp = build1_v (LOOP_EXPR, tmp);
2600 gfc_add_expr_to_block (&loop->code[n], tmp);
2602 /* Add the exit label. */
2603 tmp = build1_v (LABEL_EXPR, exit_label);
2604 gfc_add_expr_to_block (&loop->code[n], tmp);
2608 /* Finishes and generates the loops for a scalarized expression. */
2611 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2616 stmtblock_t *pblock;
2620 /* Generate the loops. */
2621 for (dim = 0; dim < loop->dimen; dim++)
2623 n = loop->order[dim];
2624 gfc_trans_scalarized_loop_end (loop, n, pblock);
2625 loop->loopvar[n] = NULL_TREE;
2626 pblock = &loop->code[n];
2629 tmp = gfc_finish_block (pblock);
2630 gfc_add_expr_to_block (&loop->pre, tmp);
2632 /* Clear all the used flags. */
2633 for (ss = loop->ss; ss; ss = ss->loop_chain)
2638 /* Finish the main body of a scalarized expression, and start the secondary
2642 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2646 stmtblock_t *pblock;
2650 /* We finish as many loops as are used by the temporary. */
2651 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2653 n = loop->order[dim];
2654 gfc_trans_scalarized_loop_end (loop, n, pblock);
2655 loop->loopvar[n] = NULL_TREE;
2656 pblock = &loop->code[n];
2659 /* We don't want to finish the outermost loop entirely. */
2660 n = loop->order[loop->temp_dim - 1];
2661 gfc_trans_scalarized_loop_end (loop, n, pblock);
2663 /* Restore the initial offsets. */
2664 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2666 if ((ss->useflags & 2) == 0)
2669 if (ss->type != GFC_SS_SECTION
2670 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2671 && ss->type != GFC_SS_COMPONENT)
2674 ss->data.info.offset = ss->data.info.saved_offset;
2677 /* Restart all the inner loops we just finished. */
2678 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2680 n = loop->order[dim];
2682 gfc_start_block (&loop->code[n]);
2684 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2686 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2689 /* Start a block for the secondary copying code. */
2690 gfc_start_block (body);
2694 /* Calculate the upper bound of an array section. */
2697 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2706 gcc_assert (ss->type == GFC_SS_SECTION);
2708 info = &ss->data.info;
2711 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2712 /* We'll calculate the upper bound once we have access to the
2713 vector's descriptor. */
2716 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2717 desc = info->descriptor;
2718 end = info->ref->u.ar.end[dim];
2722 /* The upper bound was specified. */
2723 gfc_init_se (&se, NULL);
2724 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2725 gfc_add_block_to_block (pblock, &se.pre);
2730 /* No upper bound was specified, so use the bound of the array. */
2731 bound = gfc_conv_array_ubound (desc, dim);
2738 /* Calculate the lower bound of an array section. */
2741 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2751 gcc_assert (ss->type == GFC_SS_SECTION);
2753 info = &ss->data.info;
2756 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2758 /* We use a zero-based index to access the vector. */
2759 info->start[n] = gfc_index_zero_node;
2760 info->end[n] = gfc_index_zero_node;
2761 info->stride[n] = gfc_index_one_node;
2765 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2766 desc = info->descriptor;
2767 start = info->ref->u.ar.start[dim];
2768 end = info->ref->u.ar.end[dim];
2769 stride = info->ref->u.ar.stride[dim];
2771 /* Calculate the start of the range. For vector subscripts this will
2772 be the range of the vector. */
2775 /* Specified section start. */
2776 gfc_init_se (&se, NULL);
2777 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2778 gfc_add_block_to_block (&loop->pre, &se.pre);
2779 info->start[n] = se.expr;
2783 /* No lower bound specified so use the bound of the array. */
2784 info->start[n] = gfc_conv_array_lbound (desc, dim);
2786 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2788 /* Similarly calculate the end. Although this is not used in the
2789 scalarizer, it is needed when checking bounds and where the end
2790 is an expression with side-effects. */
2793 /* Specified section start. */
2794 gfc_init_se (&se, NULL);
2795 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2796 gfc_add_block_to_block (&loop->pre, &se.pre);
2797 info->end[n] = se.expr;
2801 /* No upper bound specified so use the bound of the array. */
2802 info->end[n] = gfc_conv_array_ubound (desc, dim);
2804 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2806 /* Calculate the stride. */
2808 info->stride[n] = gfc_index_one_node;
2811 gfc_init_se (&se, NULL);
2812 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2813 gfc_add_block_to_block (&loop->pre, &se.pre);
2814 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2819 /* Calculates the range start and stride for a SS chain. Also gets the
2820 descriptor and data pointer. The range of vector subscripts is the size
2821 of the vector. Array bounds are also checked. */
2824 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2832 /* Determine the rank of the loop. */
2834 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2838 case GFC_SS_SECTION:
2839 case GFC_SS_CONSTRUCTOR:
2840 case GFC_SS_FUNCTION:
2841 case GFC_SS_COMPONENT:
2842 loop->dimen = ss->data.info.dimen;
2845 /* As usual, lbound and ubound are exceptions!. */
2846 case GFC_SS_INTRINSIC:
2847 switch (ss->expr->value.function.isym->id)
2849 case GFC_ISYM_LBOUND:
2850 case GFC_ISYM_UBOUND:
2851 loop->dimen = ss->data.info.dimen;
2862 /* We should have determined the rank of the expression by now. If
2863 not, that's bad news. */
2864 gcc_assert (loop->dimen != 0);
2866 /* Loop over all the SS in the chain. */
2867 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2869 if (ss->expr && ss->expr->shape && !ss->shape)
2870 ss->shape = ss->expr->shape;
2874 case GFC_SS_SECTION:
2875 /* Get the descriptor for the array. */
2876 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2878 for (n = 0; n < ss->data.info.dimen; n++)
2879 gfc_conv_section_startstride (loop, ss, n);
2882 case GFC_SS_INTRINSIC:
2883 switch (ss->expr->value.function.isym->id)
2885 /* Fall through to supply start and stride. */
2886 case GFC_ISYM_LBOUND:
2887 case GFC_ISYM_UBOUND:
2893 case GFC_SS_CONSTRUCTOR:
2894 case GFC_SS_FUNCTION:
2895 for (n = 0; n < ss->data.info.dimen; n++)
2897 ss->data.info.start[n] = gfc_index_zero_node;
2898 ss->data.info.end[n] = gfc_index_zero_node;
2899 ss->data.info.stride[n] = gfc_index_one_node;
2908 /* The rest is just runtime bound checking. */
2909 if (flag_bounds_check)
2912 tree lbound, ubound;
2914 tree size[GFC_MAX_DIMENSIONS];
2915 tree stride_pos, stride_neg, non_zerosized, tmp2;
2920 gfc_start_block (&block);
2922 for (n = 0; n < loop->dimen; n++)
2923 size[n] = NULL_TREE;
2925 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2929 if (ss->type != GFC_SS_SECTION)
2932 gfc_start_block (&inner);
2934 /* TODO: range checking for mapped dimensions. */
2935 info = &ss->data.info;
2937 /* This code only checks ranges. Elemental and vector
2938 dimensions are checked later. */
2939 for (n = 0; n < loop->dimen; n++)
2944 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2947 if (dim == info->ref->u.ar.dimen - 1
2948 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2949 || info->ref->u.ar.as->cp_was_assumed))
2950 check_upper = false;
2954 /* Zero stride is not allowed. */
2955 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2956 gfc_index_zero_node);
2957 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2958 "of array '%s'", info->dim[n]+1,
2959 ss->expr->symtree->name);
2960 gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg);
2963 desc = ss->data.info.descriptor;
2965 /* This is the run-time equivalent of resolve.c's
2966 check_dimension(). The logical is more readable there
2967 than it is here, with all the trees. */
2968 lbound = gfc_conv_array_lbound (desc, dim);
2971 ubound = gfc_conv_array_ubound (desc, dim);
2975 /* non_zerosized is true when the selected range is not
2977 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2978 info->stride[n], gfc_index_zero_node);
2979 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2981 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2984 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2985 info->stride[n], gfc_index_zero_node);
2986 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2988 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2990 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2991 stride_pos, stride_neg);
2993 /* Check the start of the range against the lower and upper
2994 bounds of the array, if the range is not empty. */
2995 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2997 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2998 non_zerosized, tmp);
2999 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3000 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3001 info->dim[n]+1, ss->expr->symtree->name);
3002 gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg,
3003 fold_convert (long_integer_type_node,
3005 fold_convert (long_integer_type_node,
3011 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3012 info->start[n], ubound);
3013 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3014 non_zerosized, tmp);
3015 asprintf (&msg, "%s, upper bound of dimension %d of array "
3016 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3017 info->dim[n]+1, ss->expr->symtree->name);
3018 gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg,
3019 fold_convert (long_integer_type_node, info->start[n]),
3020 fold_convert (long_integer_type_node, ubound));
3024 /* Compute the last element of the range, which is not
3025 necessarily "end" (think 0:5:3, which doesn't contain 5)
3026 and check it against both lower and upper bounds. */
3027 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3029 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3031 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3034 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3035 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3036 non_zerosized, tmp);
3037 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3038 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3039 info->dim[n]+1, ss->expr->symtree->name);
3040 gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg,
3041 fold_convert (long_integer_type_node,
3043 fold_convert (long_integer_type_node,
3049 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3050 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3051 non_zerosized, tmp);
3052 asprintf (&msg, "%s, upper bound of dimension %d of array "
3053 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3054 info->dim[n]+1, ss->expr->symtree->name);
3055 gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg,
3056 fold_convert (long_integer_type_node, tmp2),
3057 fold_convert (long_integer_type_node, ubound));
3061 /* Check the section sizes match. */
3062 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3064 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3066 /* We remember the size of the first section, and check all the
3067 others against this. */
3072 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3073 asprintf (&msg, "%s, size mismatch for dimension %d "
3074 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3075 info->dim[n]+1, ss->expr->symtree->name);
3076 gfc_trans_runtime_check (tmp3, &inner, &ss->expr->where, msg,
3077 fold_convert (long_integer_type_node, tmp),
3078 fold_convert (long_integer_type_node, size[n]));
3082 size[n] = gfc_evaluate_now (tmp, &inner);
3085 tmp = gfc_finish_block (&inner);
3087 /* For optional arguments, only check bounds if the argument is
3089 if (ss->expr->symtree->n.sym->attr.optional
3090 || ss->expr->symtree->n.sym->attr.not_always_present)
3091 tmp = build3_v (COND_EXPR,
3092 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3093 tmp, build_empty_stmt ());
3095 gfc_add_expr_to_block (&block, tmp);
3099 tmp = gfc_finish_block (&block);
3100 gfc_add_expr_to_block (&loop->pre, tmp);
3105 /* Return true if the two SS could be aliased, i.e. both point to the same data
3107 /* TODO: resolve aliases based on frontend expressions. */
3110 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3117 lsym = lss->expr->symtree->n.sym;
3118 rsym = rss->expr->symtree->n.sym;
3119 if (gfc_symbols_could_alias (lsym, rsym))
3122 if (rsym->ts.type != BT_DERIVED
3123 && lsym->ts.type != BT_DERIVED)
3126 /* For derived types we must check all the component types. We can ignore
3127 array references as these will have the same base type as the previous
3129 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3131 if (lref->type != REF_COMPONENT)
3134 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3137 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3140 if (rref->type != REF_COMPONENT)
3143 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3148 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3150 if (rref->type != REF_COMPONENT)
3153 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3161 /* Resolve array data dependencies. Creates a temporary if required. */
3162 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3166 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3176 loop->temp_ss = NULL;
3177 aref = dest->data.info.ref;
3180 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3182 if (ss->type != GFC_SS_SECTION)
3185 if (gfc_could_be_alias (dest, ss)
3186 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3192 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3194 lref = dest->expr->ref;
3195 rref = ss->expr->ref;
3197 nDepend = gfc_dep_resolver (lref, rref);
3201 /* TODO : loop shifting. */
3204 /* Mark the dimensions for LOOP SHIFTING */
3205 for (n = 0; n < loop->dimen; n++)
3207 int dim = dest->data.info.dim[n];
3209 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3211 else if (! gfc_is_same_range (&lref->u.ar,
3212 &rref->u.ar, dim, 0))
3216 /* Put all the dimensions with dependencies in the
3219 for (n = 0; n < loop->dimen; n++)
3221 gcc_assert (loop->order[n] == n);
3223 loop->order[dim++] = n;
3226 for (n = 0; n < loop->dimen; n++)
3229 loop->order[dim++] = n;
3232 gcc_assert (dim == loop->dimen);
3241 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3242 if (GFC_ARRAY_TYPE_P (base_type)
3243 || GFC_DESCRIPTOR_TYPE_P (base_type))
3244 base_type = gfc_get_element_type (base_type);
3245 loop->temp_ss = gfc_get_ss ();
3246 loop->temp_ss->type = GFC_SS_TEMP;
3247 loop->temp_ss->data.temp.type = base_type;
3248 loop->temp_ss->string_length = dest->string_length;
3249 loop->temp_ss->data.temp.dimen = loop->dimen;
3250 loop->temp_ss->next = gfc_ss_terminator;
3251 gfc_add_ss_to_loop (loop, loop->temp_ss);
3254 loop->temp_ss = NULL;
3258 /* Initialize the scalarization loop. Creates the loop variables. Determines
3259 the range of the loop variables. Creates a temporary if required.
3260 Calculates how to transform from loop variables to array indices for each
3261 expression. Also generates code for scalar expressions which have been
3262 moved outside the loop. */
3265 gfc_conv_loop_setup (gfc_loopinfo * loop)
3270 gfc_ss_info *specinfo;
3274 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3275 bool dynamic[GFC_MAX_DIMENSIONS];
3281 for (n = 0; n < loop->dimen; n++)
3285 /* We use one SS term, and use that to determine the bounds of the
3286 loop for this dimension. We try to pick the simplest term. */
3287 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3291 /* The frontend has worked out the size for us. */
3296 if (ss->type == GFC_SS_CONSTRUCTOR)
3298 /* An unknown size constructor will always be rank one.
3299 Higher rank constructors will either have known shape,
3300 or still be wrapped in a call to reshape. */
3301 gcc_assert (loop->dimen == 1);
3303 /* Always prefer to use the constructor bounds if the size
3304 can be determined at compile time. Prefer not to otherwise,
3305 since the general case involves realloc, and it's better to
3306 avoid that overhead if possible. */
3307 c = ss->expr->value.constructor;
3308 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3309 if (!dynamic[n] || !loopspec[n])
3314 /* TODO: Pick the best bound if we have a choice between a
3315 function and something else. */
3316 if (ss->type == GFC_SS_FUNCTION)
3322 if (ss->type != GFC_SS_SECTION)
3326 specinfo = &loopspec[n]->data.info;
3329 info = &ss->data.info;
3333 /* Criteria for choosing a loop specifier (most important first):
3334 doesn't need realloc
3340 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3342 else if (integer_onep (info->stride[n])
3343 && !integer_onep (specinfo->stride[n]))
3345 else if (INTEGER_CST_P (info->stride[n])
3346 && !INTEGER_CST_P (specinfo->stride[n]))
3348 else if (INTEGER_CST_P (info->start[n])
3349 && !INTEGER_CST_P (specinfo->start[n]))
3351 /* We don't work out the upper bound.
3352 else if (INTEGER_CST_P (info->finish[n])
3353 && ! INTEGER_CST_P (specinfo->finish[n]))
3354 loopspec[n] = ss; */
3357 /* We should have found the scalarization loop specifier. If not,
3359 gcc_assert (loopspec[n]);
3361 info = &loopspec[n]->data.info;
3363 /* Set the extents of this range. */
3364 cshape = loopspec[n]->shape;
3365 if (cshape && INTEGER_CST_P (info->start[n])
3366 && INTEGER_CST_P (info->stride[n]))
3368 loop->from[n] = info->start[n];
3369 mpz_set (i, cshape[n]);
3370 mpz_sub_ui (i, i, 1);
3371 /* To = from + (size - 1) * stride. */
3372 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3373 if (!integer_onep (info->stride[n]))
3374 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3375 tmp, info->stride[n]);
3376 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3377 loop->from[n], tmp);
3381 loop->from[n] = info->start[n];
3382 switch (loopspec[n]->type)
3384 case GFC_SS_CONSTRUCTOR:
3385 /* The upper bound is calculated when we expand the
3387 gcc_assert (loop->to[n] == NULL_TREE);
3390 case GFC_SS_SECTION:
3391 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3395 case GFC_SS_FUNCTION:
3396 /* The loop bound will be set when we generate the call. */
3397 gcc_assert (loop->to[n] == NULL_TREE);
3405 /* Transform everything so we have a simple incrementing variable. */
3406 if (integer_onep (info->stride[n]))
3407 info->delta[n] = gfc_index_zero_node;
3410 /* Set the delta for this section. */
3411 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3412 /* Number of iterations is (end - start + step) / step.
3413 with start = 0, this simplifies to
3415 for (i = 0; i<=last; i++){...}; */
3416 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3417 loop->to[n], loop->from[n]);
3418 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3419 tmp, info->stride[n]);
3420 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3421 /* Make the loop variable start at 0. */
3422 loop->from[n] = gfc_index_zero_node;
3426 /* Add all the scalar code that can be taken out of the loops.
3427 This may include calculating the loop bounds, so do it before
3428 allocating the temporary. */
3429 gfc_add_loop_ss_code (loop, loop->ss, false);
3431 /* If we want a temporary then create it. */
3432 if (loop->temp_ss != NULL)
3434 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3436 /* Make absolutely sure that this is a complete type. */
3437 if (loop->temp_ss->string_length)
3438 loop->temp_ss->data.temp.type
3439 = gfc_get_character_type_len (gfc_default_character_kind,
3440 loop->temp_ss->string_length);
3442 tmp = loop->temp_ss->data.temp.type;
3443 len = loop->temp_ss->string_length;
3444 n = loop->temp_ss->data.temp.dimen;
3445 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3446 loop->temp_ss->type = GFC_SS_SECTION;
3447 loop->temp_ss->data.info.dimen = n;
3448 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3449 &loop->temp_ss->data.info, tmp, false, true,
3453 for (n = 0; n < loop->temp_dim; n++)
3454 loopspec[loop->order[n]] = NULL;
3458 /* For array parameters we don't have loop variables, so don't calculate the
3460 if (loop->array_parameter)
3463 /* Calculate the translation from loop variables to array indices. */
3464 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3466 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3469 info = &ss->data.info;
3471 for (n = 0; n < info->dimen; n++)
3475 /* If we are specifying the range the delta is already set. */
3476 if (loopspec[n] != ss)
3478 /* Calculate the offset relative to the loop variable.
3479 First multiply by the stride. */
3480 tmp = loop->from[n];
3481 if (!integer_onep (info->stride[n]))
3482 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3483 tmp, info->stride[n]);
3485 /* Then subtract this from our starting value. */
3486 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3487 info->start[n], tmp);
3489 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3496 /* Fills in an array descriptor, and returns the size of the array. The size
3497 will be a simple_val, ie a variable or a constant. Also calculates the
3498 offset of the base. Returns the size of the array.
3502 for (n = 0; n < rank; n++)
3504 a.lbound[n] = specified_lower_bound;
3505 offset = offset + a.lbond[n] * stride;
3507 a.ubound[n] = specified_upper_bound;
3508 a.stride[n] = stride;
3509 size = ubound + size; //size = ubound + 1 - lbound
3510 stride = stride * size;
3517 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3518 gfc_expr ** lower, gfc_expr ** upper,
3519 stmtblock_t * pblock)
3531 stmtblock_t thenblock;
3532 stmtblock_t elseblock;
3537 type = TREE_TYPE (descriptor);
3539 stride = gfc_index_one_node;
3540 offset = gfc_index_zero_node;
3542 /* Set the dtype. */
3543 tmp = gfc_conv_descriptor_dtype (descriptor);
3544 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3546 or_expr = NULL_TREE;
3548 for (n = 0; n < rank; n++)
3550 /* We have 3 possibilities for determining the size of the array:
3551 lower == NULL => lbound = 1, ubound = upper[n]
3552 upper[n] = NULL => lbound = 1, ubound = lower[n]
3553 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3556 /* Set lower bound. */
3557 gfc_init_se (&se, NULL);
3559 se.expr = gfc_index_one_node;
3562 gcc_assert (lower[n]);
3565 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3566 gfc_add_block_to_block (pblock, &se.pre);
3570 se.expr = gfc_index_one_node;
3574 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3575 gfc_add_modify_expr (pblock, tmp, se.expr);
3577 /* Work out the offset for this component. */
3578 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3579 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3581 /* Start the calculation for the size of this dimension. */
3582 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3583 gfc_index_one_node, se.expr);
3585 /* Set upper bound. */
3586 gfc_init_se (&se, NULL);
3587 gcc_assert (ubound);
3588 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3589 gfc_add_block_to_block (pblock, &se.pre);
3591 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3592 gfc_add_modify_expr (pblock, tmp, se.expr);
3594 /* Store the stride. */
3595 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3596 gfc_add_modify_expr (pblock, tmp, stride);
3598 /* Calculate the size of this dimension. */
3599 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3601 /* Check whether the size for this dimension is negative. */
3602 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3603 gfc_index_zero_node);
3607 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3609 /* Multiply the stride by the number of elements in this dimension. */
3610 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3611 stride = gfc_evaluate_now (stride, pblock);
3614 /* The stride is the number of elements in the array, so multiply by the
3615 size of an element to get the total size. */
3616 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3617 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3618 fold_convert (gfc_array_index_type, tmp));
3620 if (poffset != NULL)
3622 offset = gfc_evaluate_now (offset, pblock);
3626 if (integer_zerop (or_expr))
3628 if (integer_onep (or_expr))
3629 return gfc_index_zero_node;
3631 var = gfc_create_var (TREE_TYPE (size), "size");
3632 gfc_start_block (&thenblock);
3633 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3634 thencase = gfc_finish_block (&thenblock);
3636 gfc_start_block (&elseblock);
3637 gfc_add_modify_expr (&elseblock, var, size);
3638 elsecase = gfc_finish_block (&elseblock);
3640 tmp = gfc_evaluate_now (or_expr, pblock);
3641 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3642 gfc_add_expr_to_block (pblock, tmp);
3648 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3649 the work for an ALLOCATE statement. */
3653 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3661 gfc_ref *ref, *prev_ref = NULL;
3662 bool allocatable_array;
3666 /* Find the last reference in the chain. */
3667 while (ref && ref->next != NULL)
3669 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3674 if (ref == NULL || ref->type != REF_ARRAY)
3678 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3680 allocatable_array = prev_ref->u.c.component->allocatable;
3682 /* Figure out the size of the array. */
3683 switch (ref->u.ar.type)
3687 upper = ref->u.ar.start;
3691 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3693 lower = ref->u.ar.as->lower;
3694 upper = ref->u.ar.as->upper;
3698 lower = ref->u.ar.start;
3699 upper = ref->u.ar.end;
3707 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3708 lower, upper, &se->pre);
3710 /* Allocate memory to store the data. */
3711 pointer = gfc_conv_descriptor_data_get (se->expr);
3712 STRIP_NOPS (pointer);
3714 /* The allocate_array variants take the old pointer as first argument. */
3715 if (allocatable_array)
3716 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
3718 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3719 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3720 gfc_add_expr_to_block (&se->pre, tmp);
3722 tmp = gfc_conv_descriptor_offset (se->expr);
3723 gfc_add_modify_expr (&se->pre, tmp, offset);
3725 if (expr->ts.type == BT_DERIVED
3726 && expr->ts.derived->attr.alloc_comp)
3728 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3729 ref->u.ar.as->rank);
3730 gfc_add_expr_to_block (&se->pre, tmp);
3737 /* Deallocate an array variable. Also used when an allocated variable goes
3742 gfc_array_deallocate (tree descriptor, tree pstat)
3748 gfc_start_block (&block);
3749 /* Get a pointer to the data. */
3750 var = gfc_conv_descriptor_data_get (descriptor);
3753 /* Parameter is the address of the data component. */
3754 tmp = gfc_deallocate_with_status (var, pstat, false);
3755 gfc_add_expr_to_block (&block, tmp);
3757 /* Zero the data pointer. */
3758 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3759 var, build_int_cst (TREE_TYPE (var), 0));
3760 gfc_add_expr_to_block (&block, tmp);
3762 return gfc_finish_block (&block);
3766 /* Create an array constructor from an initialization expression.
3767 We assume the frontend already did any expansions and conversions. */
3770 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3777 unsigned HOST_WIDE_INT lo;
3779 VEC(constructor_elt,gc) *v = NULL;
3781 switch (expr->expr_type)
3784 case EXPR_STRUCTURE:
3785 /* A single scalar or derived type value. Create an array with all
3786 elements equal to that value. */
3787 gfc_init_se (&se, NULL);
3789 if (expr->expr_type == EXPR_CONSTANT)
3790 gfc_conv_constant (&se, expr);
3792 gfc_conv_structure (&se, expr, 1);
3794 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3795 gcc_assert (tmp && INTEGER_CST_P (tmp));
3796 hi = TREE_INT_CST_HIGH (tmp);
3797 lo = TREE_INT_CST_LOW (tmp);
3801 /* This will probably eat buckets of memory for large arrays. */
3802 while (hi != 0 || lo != 0)
3804 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3812 /* Create a vector of all the elements. */
3813 for (c = expr->value.constructor; c; c = c->next)
3817 /* Problems occur when we get something like
3818 integer :: a(lots) = (/(i, i=1,lots)/) */
3819 /* TODO: Unexpanded array initializers. */
3821 ("Possible frontend bug: array constructor not expanded");
3823 if (mpz_cmp_si (c->n.offset, 0) != 0)
3824 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3828 if (mpz_cmp_si (c->repeat, 0) != 0)
3832 mpz_set (maxval, c->repeat);
3833 mpz_add (maxval, c->n.offset, maxval);
3834 mpz_sub_ui (maxval, maxval, 1);
3835 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3836 if (mpz_cmp_si (c->n.offset, 0) != 0)
3838 mpz_add_ui (maxval, c->n.offset, 1);
3839 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3842 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3844 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3850 gfc_init_se (&se, NULL);
3851 switch (c->expr->expr_type)
3854 gfc_conv_constant (&se, c->expr);
3855 if (range == NULL_TREE)
3856 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3859 if (index != NULL_TREE)
3860 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3861 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3865 case EXPR_STRUCTURE:
3866 gfc_conv_structure (&se, c->expr, 1);
3867 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3877 return gfc_build_null_descriptor (type);
3883 /* Create a constructor from the list of elements. */
3884 tmp = build_constructor (type, v);
3885 TREE_CONSTANT (tmp) = 1;
3886 TREE_INVARIANT (tmp) = 1;
3891 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3892 returns the size (in elements) of the array. */
3895 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3896 stmtblock_t * pblock)
3911 size = gfc_index_one_node;
3912 offset = gfc_index_zero_node;
3913 for (dim = 0; dim < as->rank; dim++)
3915 /* Evaluate non-constant array bound expressions. */
3916 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3917 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3919 gfc_init_se (&se, NULL);
3920 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3921 gfc_add_block_to_block (pblock, &se.pre);
3922 gfc_add_modify_expr (pblock, lbound, se.expr);
3924 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3925 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3927 gfc_init_se (&se, NULL);
3928 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3929 gfc_add_block_to_block (pblock, &se.pre);
3930 gfc_add_modify_expr (pblock, ubound, se.expr);
3932 /* The offset of this dimension. offset = offset - lbound * stride. */
3933 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3934 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3936 /* The size of this dimension, and the stride of the next. */
3937 if (dim + 1 < as->rank)
3938 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3940 stride = GFC_TYPE_ARRAY_SIZE (type);
3942 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3944 /* Calculate stride = size * (ubound + 1 - lbound). */
3945 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3946 gfc_index_one_node, lbound);
3947 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3948 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3950 gfc_add_modify_expr (pblock, stride, tmp);
3952 stride = gfc_evaluate_now (tmp, pblock);
3954 /* Make sure that negative size arrays are translated
3955 to being zero size. */
3956 tmp = fold_build2 (GE_EXPR, boolean_type_node,
3957 stride, gfc_index_zero_node);
3958 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
3959 stride, gfc_index_zero_node);
3960 gfc_add_modify_expr (pblock, stride, tmp);
3966 gfc_trans_vla_type_sizes (sym, pblock);
3973 /* Generate code to initialize/allocate an array variable. */
3976 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3985 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3987 /* Do nothing for USEd variables. */
3988 if (sym->attr.use_assoc)
3991 type = TREE_TYPE (decl);
3992 gcc_assert (GFC_ARRAY_TYPE_P (type));
3993 onstack = TREE_CODE (type) != POINTER_TYPE;
3995 gfc_start_block (&block);
3997 /* Evaluate character string length. */
3998 if (sym->ts.type == BT_CHARACTER
3999 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4001 gfc_conv_string_length (sym->ts.cl, &block);
4003 gfc_trans_vla_type_sizes (sym, &block);
4005 /* Emit a DECL_EXPR for this variable, which will cause the
4006 gimplifier to allocate storage, and all that good stuff. */
4007 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4008 gfc_add_expr_to_block (&block, tmp);
4013 gfc_add_expr_to_block (&block, fnbody);
4014 return gfc_finish_block (&block);
4017 type = TREE_TYPE (type);
4019 gcc_assert (!sym->attr.use_assoc);
4020 gcc_assert (!TREE_STATIC (decl));
4021 gcc_assert (!sym->module);
4023 if (sym->ts.type == BT_CHARACTER
4024 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4025 gfc_conv_string_length (sym->ts.cl, &block);
4027 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4029 /* Don't actually allocate space for Cray Pointees. */
4030 if (sym->attr.cray_pointee)
4032 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4033 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4034 gfc_add_expr_to_block (&block, fnbody);
4035 return gfc_finish_block (&block);
4038 /* The size is the number of elements in the array, so multiply by the
4039 size of an element to get the total size. */
4040 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4041 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4042 fold_convert (gfc_array_index_type, tmp));
4044 /* Allocate memory to hold the data. */
4045 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4046 gfc_add_modify_expr (&block, decl, tmp);
4048 /* Set offset of the array. */
4049 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4050 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4053 /* Automatic arrays should not have initializers. */
4054 gcc_assert (!sym->value);
4056 gfc_add_expr_to_block (&block, fnbody);
4058 /* Free the temporary. */
4059 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4060 gfc_add_expr_to_block (&block, tmp);
4062 return gfc_finish_block (&block);
4066 /* Generate entry and exit code for g77 calling convention arrays. */
4069 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4079 gfc_get_backend_locus (&loc);
4080 gfc_set_backend_locus (&sym->declared_at);
4082 /* Descriptor type. */
4083 parm = sym->backend_decl;
4084 type = TREE_TYPE (parm);
4085 gcc_assert (GFC_ARRAY_TYPE_P (type));
4087 gfc_start_block (&block);
4089 if (sym->ts.type == BT_CHARACTER
4090 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4091 gfc_conv_string_length (sym->ts.cl, &block);
4093 /* Evaluate the bounds of the array. */
4094 gfc_trans_array_bounds (type, sym, &offset, &block);
4096 /* Set the offset. */
4097 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4098 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4100 /* Set the pointer itself if we aren't using the parameter directly. */
4101 if (TREE_CODE (parm) != PARM_DECL)
4103 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4104 gfc_add_modify_expr (&block, parm, tmp);
4106 stmt = gfc_finish_block (&block);
4108 gfc_set_backend_locus (&loc);
4110 gfc_start_block (&block);
4112 /* Add the initialization code to the start of the function. */
4114 if (sym->attr.optional || sym->attr.not_always_present)
4116 tmp = gfc_conv_expr_present (sym);
4117 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4120 gfc_add_expr_to_block (&block, stmt);
4121 gfc_add_expr_to_block (&block, body);
4123 return gfc_finish_block (&block);
4127 /* Modify the descriptor of an array parameter so that it has the
4128 correct lower bound. Also move the upper bound accordingly.
4129 If the array is not packed, it will be copied into a temporary.
4130 For each dimension we set the new lower and upper bounds. Then we copy the
4131 stride and calculate the offset for this dimension. We also work out
4132 what the stride of a packed array would be, and see it the two match.
4133 If the array need repacking, we set the stride to the values we just
4134 calculated, recalculate the offset and copy the array data.
4135 Code is also added to copy the data back at the end of the function.
4139 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4146 stmtblock_t cleanup;
4154 tree stride, stride2;
4164 /* Do nothing for pointer and allocatable arrays. */
4165 if (sym->attr.pointer || sym->attr.allocatable)
4168 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4169 return gfc_trans_g77_array (sym, body);
4171 gfc_get_backend_locus (&loc);
4172 gfc_set_backend_locus (&sym->declared_at);
4174 /* Descriptor type. */
4175 type = TREE_TYPE (tmpdesc);
4176 gcc_assert (GFC_ARRAY_TYPE_P (type));
4177 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4178 dumdesc = build_fold_indirect_ref (dumdesc);
4179 gfc_start_block (&block);
4181 if (sym->ts.type == BT_CHARACTER
4182 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4183 gfc_conv_string_length (sym->ts.cl, &block);
4185 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4187 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4188 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4190 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4192 /* For non-constant shape arrays we only check if the first dimension
4193 is contiguous. Repacking higher dimensions wouldn't gain us
4194 anything as we still don't know the array stride. */
4195 partial = gfc_create_var (boolean_type_node, "partial");
4196 TREE_USED (partial) = 1;
4197 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4198 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4199 gfc_add_modify_expr (&block, partial, tmp);
4203 partial = NULL_TREE;
4206 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4207 here, however I think it does the right thing. */
4210 /* Set the first stride. */
4211 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4212 stride = gfc_evaluate_now (stride, &block);
4214 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4215 stride, gfc_index_zero_node);
4216 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4217 gfc_index_one_node, stride);
4218 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4219 gfc_add_modify_expr (&block, stride, tmp);
4221 /* Allow the user to disable array repacking. */
4222 stmt_unpacked = NULL_TREE;
4226 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4227 /* A library call to repack the array if necessary. */
4228 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4229 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4231 stride = gfc_index_one_node;
4234 /* This is for the case where the array data is used directly without
4235 calling the repack function. */
4236 if (no_repack || partial != NULL_TREE)
4237 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4239 stmt_packed = NULL_TREE;
4241 /* Assign the data pointer. */
4242 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4244 /* Don't repack unknown shape arrays when the first stride is 1. */
4245 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4246 partial, stmt_packed, stmt_unpacked);
4249 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4250 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4252 offset = gfc_index_zero_node;
4253 size = gfc_index_one_node;
4255 /* Evaluate the bounds of the array. */
4256 for (n = 0; n < sym->as->rank; n++)
4258 if (checkparm || !sym->as->upper[n])
4260 /* Get the bounds of the actual parameter. */
4261 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4262 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4266 dubound = NULL_TREE;
4267 dlbound = NULL_TREE;
4270 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4271 if (!INTEGER_CST_P (lbound))
4273 gfc_init_se (&se, NULL);
4274 gfc_conv_expr_type (&se, sym->as->lower[n],
4275 gfc_array_index_type);
4276 gfc_add_block_to_block (&block, &se.pre);
4277 gfc_add_modify_expr (&block, lbound, se.expr);
4280 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4281 /* Set the desired upper bound. */
4282 if (sym->as->upper[n])
4284 /* We know what we want the upper bound to be. */
4285 if (!INTEGER_CST_P (ubound))
4287 gfc_init_se (&se, NULL);
4288 gfc_conv_expr_type (&se, sym->as->upper[n],
4289 gfc_array_index_type);
4290 gfc_add_block_to_block (&block, &se.pre);
4291 gfc_add_modify_expr (&block, ubound, se.expr);
4294 /* Check the sizes match. */
4297 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4300 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4302 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4304 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4305 asprintf (&msg, "%s for dimension %d of array '%s'",
4306 gfc_msg_bounds, n+1, sym->name);
4307 gfc_trans_runtime_check (tmp, &block, &loc, msg);
4313 /* For assumed shape arrays move the upper bound by the same amount
4314 as the lower bound. */
4315 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4317 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4318 gfc_add_modify_expr (&block, ubound, tmp);
4320 /* The offset of this dimension. offset = offset - lbound * stride. */
4321 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4322 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4324 /* The size of this dimension, and the stride of the next. */
4325 if (n + 1 < sym->as->rank)
4327 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4329 if (no_repack || partial != NULL_TREE)
4332 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4335 /* Figure out the stride if not a known constant. */
4336 if (!INTEGER_CST_P (stride))
4339 stmt_packed = NULL_TREE;
4342 /* Calculate stride = size * (ubound + 1 - lbound). */
4343 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4344 gfc_index_one_node, lbound);
4345 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4347 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4352 /* Assign the stride. */
4353 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4354 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4355 stmt_unpacked, stmt_packed);
4357 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4358 gfc_add_modify_expr (&block, stride, tmp);
4363 stride = GFC_TYPE_ARRAY_SIZE (type);
4365 if (stride && !INTEGER_CST_P (stride))
4367 /* Calculate size = stride * (ubound + 1 - lbound). */
4368 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4369 gfc_index_one_node, lbound);
4370 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4372 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4373 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4374 gfc_add_modify_expr (&block, stride, tmp);
4379 /* Set the offset. */
4380 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4381 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4383 gfc_trans_vla_type_sizes (sym, &block);
4385 stmt = gfc_finish_block (&block);
4387 gfc_start_block (&block);
4389 /* Only do the entry/initialization code if the arg is present. */
4390 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4391 optional_arg = (sym->attr.optional
4392 || (sym->ns->proc_name->attr.entry_master
4393 && sym->attr.dummy));
4396 tmp = gfc_conv_expr_present (sym);
4397 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4399 gfc_add_expr_to_block (&block, stmt);
4401 /* Add the main function body. */
4402 gfc_add_expr_to_block (&block, body);
4407 gfc_start_block (&cleanup);
4409 if (sym->attr.intent != INTENT_IN)
4411 /* Copy the data back. */
4412 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4413 gfc_add_expr_to_block (&cleanup, tmp);
4416 /* Free the temporary. */
4417 tmp = gfc_call_free (tmpdesc);
4418 gfc_add_expr_to_block (&cleanup, tmp);
4420 stmt = gfc_finish_block (&cleanup);
4422 /* Only do the cleanup if the array was repacked. */
4423 tmp = build_fold_indirect_ref (dumdesc);
4424 tmp = gfc_conv_descriptor_data_get (tmp);
4425 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4426 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4430 tmp = gfc_conv_expr_present (sym);
4431 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4433 gfc_add_expr_to_block (&block, stmt);
4435 /* We don't need to free any memory allocated by internal_pack as it will
4436 be freed at the end of the function by pop_context. */
4437 return gfc_finish_block (&block);
4441 /* Calculate the overall offset, including subreferences. */
4443 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4444 bool subref, gfc_expr *expr)
4454 /* If offset is NULL and this is not a subreferenced array, there is
4456 if (offset == NULL_TREE)
4459 offset = gfc_index_zero_node;
4464 tmp = gfc_conv_array_data (desc);
4465 tmp = build_fold_indirect_ref (tmp);
4466 tmp = gfc_build_array_ref (tmp, offset, NULL);
4468 /* Offset the data pointer for pointer assignments from arrays with
4469 subreferences; eg. my_integer => my_type(:)%integer_component. */
4472 /* Go past the array reference. */
4473 for (ref = expr->ref; ref; ref = ref->next)
4474 if (ref->type == REF_ARRAY &&
4475 ref->u.ar.type != AR_ELEMENT)
4481 /* Calculate the offset for each subsequent subreference. */
4482 for (; ref; ref = ref->next)
4487 field = ref->u.c.component->backend_decl;
4488 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4489 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4490 tmp, field, NULL_TREE);
4494 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4495 gfc_init_se (&start, NULL);
4496 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4497 gfc_add_block_to_block (block, &start.pre);
4498 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4502 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4503 && ref->u.ar.type == AR_ELEMENT);
4505 /* TODO - Add bounds checking. */
4506 stride = gfc_index_one_node;
4507 index = gfc_index_zero_node;
4508 for (n = 0; n < ref->u.ar.dimen; n++)
4513 /* Update the index. */
4514 gfc_init_se (&start, NULL);
4515 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4516 itmp = gfc_evaluate_now (start.expr, block);
4517 gfc_init_se (&start, NULL);
4518 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4519 jtmp = gfc_evaluate_now (start.expr, block);
4520 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4521 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4522 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4523 index = gfc_evaluate_now (index, block);
4525 /* Update the stride. */
4526 gfc_init_se (&start, NULL);
4527 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4528 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4529 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4530 gfc_index_one_node, itmp);
4531 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4532 stride = gfc_evaluate_now (stride, block);
4535 /* Apply the index to obtain the array element. */
4536 tmp = gfc_build_array_ref (tmp, index, NULL);
4546 /* Set the target data pointer. */
4547 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4548 gfc_conv_descriptor_data_set (block, parm, offset);
4552 /* gfc_conv_expr_descriptor needs the character length of elemental
4553 functions before the function is called so that the size of the
4554 temporary can be obtained. The only way to do this is to convert
4555 the expression, mapping onto the actual arguments. */
4557 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4559 gfc_interface_mapping mapping;
4560 gfc_formal_arglist *formal;
4561 gfc_actual_arglist *arg;
4564 formal = expr->symtree->n.sym->formal;
4565 arg = expr->value.function.actual;
4566 gfc_init_interface_mapping (&mapping);
4568 /* Set se = NULL in the calls to the interface mapping, to supress any
4570 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4575 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4578 gfc_init_se (&tse, NULL);
4580 /* Build the expression for the character length and convert it. */
4581 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4583 gfc_add_block_to_block (&se->pre, &tse.pre);
4584 gfc_add_block_to_block (&se->post, &tse.post);
4585 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4586 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4587 build_int_cst (gfc_charlen_type_node, 0));
4588 expr->ts.cl->backend_decl = tse.expr;
4589 gfc_free_interface_mapping (&mapping);
4593 /* Convert an array for passing as an actual argument. Expressions and
4594 vector subscripts are evaluated and stored in a temporary, which is then
4595 passed. For whole arrays the descriptor is passed. For array sections
4596 a modified copy of the descriptor is passed, but using the original data.
4598 This function is also used for array pointer assignments, and there
4601 - se->want_pointer && !se->direct_byref
4602 EXPR is an actual argument. On exit, se->expr contains a
4603 pointer to the array descriptor.
4605 - !se->want_pointer && !se->direct_byref
4606 EXPR is an actual argument to an intrinsic function or the
4607 left-hand side of a pointer assignment. On exit, se->expr
4608 contains the descriptor for EXPR.
4610 - !se->want_pointer && se->direct_byref
4611 EXPR is the right-hand side of a pointer assignment and
4612 se->expr is the descriptor for the previously-evaluated
4613 left-hand side. The function creates an assignment from
4614 EXPR to se->expr. */
4617 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4630 bool subref_array_target = false;
4632 gcc_assert (ss != gfc_ss_terminator);
4634 /* Special case things we know we can pass easily. */
4635 switch (expr->expr_type)
4638 /* If we have a linear array section, we can pass it directly.
4639 Otherwise we need to copy it into a temporary. */
4641 /* Find the SS for the array section. */
4643 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4644 secss = secss->next;
4646 gcc_assert (secss != gfc_ss_terminator);
4647 info = &secss->data.info;
4649 /* Get the descriptor for the array. */
4650 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4651 desc = info->descriptor;
4653 subref_array_target = se->direct_byref && is_subref_array (expr);
4654 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4655 && !subref_array_target;
4659 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4661 /* Create a new descriptor if the array doesn't have one. */
4664 else if (info->ref->u.ar.type == AR_FULL)
4666 else if (se->direct_byref)
4669 full = gfc_full_array_ref_p (info->ref);
4673 if (se->direct_byref)
4675 /* Copy the descriptor for pointer assignments. */
4676 gfc_add_modify_expr (&se->pre, se->expr, desc);
4678 /* Add any offsets from subreferences. */
4679 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4680 subref_array_target, expr);
4682 else if (se->want_pointer)
4684 /* We pass full arrays directly. This means that pointers and
4685 allocatable arrays should also work. */
4686 se->expr = build_fold_addr_expr (desc);
4693 if (expr->ts.type == BT_CHARACTER)
4694 se->string_length = gfc_get_expr_charlen (expr);
4701 /* A transformational function return value will be a temporary
4702 array descriptor. We still need to go through the scalarizer
4703 to create the descriptor. Elemental functions ar handled as
4704 arbitrary expressions, i.e. copy to a temporary. */
4706 /* Look for the SS for this function. */
4707 while (secss != gfc_ss_terminator
4708 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4709 secss = secss->next;
4711 if (se->direct_byref)
4713 gcc_assert (secss != gfc_ss_terminator);
4715 /* For pointer assignments pass the descriptor directly. */
4717 se->expr = build_fold_addr_expr (se->expr);
4718 gfc_conv_expr (se, expr);
4722 if (secss == gfc_ss_terminator)
4724 /* Elemental function. */
4726 if (expr->ts.type == BT_CHARACTER
4727 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4728 get_elemental_fcn_charlen (expr, se);
4734 /* Transformational function. */
4735 info = &secss->data.info;
4741 /* Constant array constructors don't need a temporary. */
4742 if (ss->type == GFC_SS_CONSTRUCTOR
4743 && expr->ts.type != BT_CHARACTER
4744 && gfc_constant_array_constructor_p (expr->value.constructor))
4747 info = &ss->data.info;
4759 /* Something complicated. Copy it into a temporary. */
4767 gfc_init_loopinfo (&loop);
4769 /* Associate the SS with the loop. */
4770 gfc_add_ss_to_loop (&loop, ss);
4772 /* Tell the scalarizer not to bother creating loop variables, etc. */
4774 loop.array_parameter = 1;
4776 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4777 gcc_assert (!se->direct_byref);
4779 /* Setup the scalarizing loops and bounds. */
4780 gfc_conv_ss_startstride (&loop);
4784 /* Tell the scalarizer to make a temporary. */
4785 loop.temp_ss = gfc_get_ss ();
4786 loop.temp_ss->type = GFC_SS_TEMP;
4787 loop.temp_ss->next = gfc_ss_terminator;
4789 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4790 gfc_conv_string_length (expr->ts.cl, &se->pre);
4792 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4794 if (expr->ts.type == BT_CHARACTER)
4795 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4797 loop.temp_ss->string_length = NULL;
4799 se->string_length = loop.temp_ss->string_length;
4800 loop.temp_ss->data.temp.dimen = loop.dimen;
4801 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4804 gfc_conv_loop_setup (&loop);
4808 /* Copy into a temporary and pass that. We don't need to copy the data
4809 back because expressions and vector subscripts must be INTENT_IN. */
4810 /* TODO: Optimize passing function return values. */
4814 /* Start the copying loops. */
4815 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4816 gfc_mark_ss_chain_used (ss, 1);
4817 gfc_start_scalarized_body (&loop, &block);
4819 /* Copy each data element. */
4820 gfc_init_se (&lse, NULL);
4821 gfc_copy_loopinfo_to_se (&lse, &loop);
4822 gfc_init_se (&rse, NULL);
4823 gfc_copy_loopinfo_to_se (&rse, &loop);
4825 lse.ss = loop.temp_ss;
4828 gfc_conv_scalarized_array_ref (&lse, NULL);
4829 if (expr->ts.type == BT_CHARACTER)
4831 gfc_conv_expr (&rse, expr);
4832 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4833 rse.expr = build_fold_indirect_ref (rse.expr);
4836 gfc_conv_expr_val (&rse, expr);
4838 gfc_add_block_to_block (&block, &rse.pre);
4839 gfc_add_block_to_block (&block, &lse.pre);
4841 lse.string_length = rse.string_length;
4842 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4843 expr->expr_type == EXPR_VARIABLE);
4844 gfc_add_expr_to_block (&block, tmp);
4846 /* Finish the copying loops. */
4847 gfc_trans_scalarizing_loops (&loop, &block);
4849 desc = loop.temp_ss->data.info.descriptor;
4851 gcc_assert (is_gimple_lvalue (desc));
4853 else if (expr->expr_type == EXPR_FUNCTION)
4855 desc = info->descriptor;
4856 se->string_length = ss->string_length;
4860 /* We pass sections without copying to a temporary. Make a new
4861 descriptor and point it at the section we want. The loop variable
4862 limits will be the limits of the section.
4863 A function may decide to repack the array to speed up access, but
4864 we're not bothered about that here. */
4873 /* Set the string_length for a character array. */
4874 if (expr->ts.type == BT_CHARACTER)
4875 se->string_length = gfc_get_expr_charlen (expr);
4877 desc = info->descriptor;
4878 gcc_assert (secss && secss != gfc_ss_terminator);
4879 if (se->direct_byref)
4881 /* For pointer assignments we fill in the destination. */
4883 parmtype = TREE_TYPE (parm);
4887 /* Otherwise make a new one. */
4888 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4889 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4890 loop.from, loop.to, 0,
4892 parm = gfc_create_var (parmtype, "parm");
4895 offset = gfc_index_zero_node;
4898 /* The following can be somewhat confusing. We have two
4899 descriptors, a new one and the original array.
4900 {parm, parmtype, dim} refer to the new one.
4901 {desc, type, n, secss, loop} refer to the original, which maybe
4902 a descriptorless array.
4903 The bounds of the scalarization are the bounds of the section.
4904 We don't have to worry about numeric overflows when calculating
4905 the offsets because all elements are within the array data. */
4907 /* Set the dtype. */
4908 tmp = gfc_conv_descriptor_dtype (parm);
4909 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4911 /* Set offset for assignments to pointer only to zero if it is not
4913 if (se->direct_byref
4914 && info->ref && info->ref->u.ar.type != AR_FULL)
4915 base = gfc_index_zero_node;
4916 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4917 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4921 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4922 for (n = 0; n < ndim; n++)
4924 stride = gfc_conv_array_stride (desc, n);
4926 /* Work out the offset. */
4928 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4930 gcc_assert (info->subscript[n]
4931 && info->subscript[n]->type == GFC_SS_SCALAR);
4932 start = info->subscript[n]->data.scalar.expr;
4936 /* Check we haven't somehow got out of sync. */
4937 gcc_assert (info->dim[dim] == n);
4939 /* Evaluate and remember the start of the section. */
4940 start = info->start[dim];
4941 stride = gfc_evaluate_now (stride, &loop.pre);
4944 tmp = gfc_conv_array_lbound (desc, n);
4945 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4947 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4948 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4951 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4953 /* For elemental dimensions, we only need the offset. */
4957 /* Vector subscripts need copying and are handled elsewhere. */
4959 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4961 /* Set the new lower bound. */
4962 from = loop.from[dim];
4965 /* If we have an array section or are assigning make sure that
4966 the lower bound is 1. References to the full
4967 array should otherwise keep the original bounds. */
4969 || info->ref->u.ar.type != AR_FULL)
4970 && !integer_onep (from))
4972 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4973 gfc_index_one_node, from);
4974 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4975 from = gfc_index_one_node;
4977 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4978 gfc_add_modify_expr (&loop.pre, tmp, from);
4980 /* Set the new upper bound. */
4981 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4982 gfc_add_modify_expr (&loop.pre, tmp, to);
4984 /* Multiply the stride by the section stride to get the
4986 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4987 stride, info->stride[dim]);
4989 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
4991 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4994 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4996 tmp = gfc_conv_array_lbound (desc, n);
4997 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4998 tmp, loop.from[dim]);
4999 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5000 tmp, gfc_conv_array_stride (desc, n));
5001 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5005 /* Store the new stride. */
5006 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5007 gfc_add_modify_expr (&loop.pre, tmp, stride);
5012 if (se->data_not_needed)
5013 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5015 /* Point the data pointer at the first element in the section. */
5016 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5017 subref_array_target, expr);
5019 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5020 && !se->data_not_needed)
5022 /* Set the offset. */
5023 tmp = gfc_conv_descriptor_offset (parm);
5024 gfc_add_modify_expr (&loop.pre, tmp, base);
5028 /* Only the callee knows what the correct offset it, so just set
5030 tmp = gfc_conv_descriptor_offset (parm);
5031 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
5036 if (!se->direct_byref)
5038 /* Get a pointer to the new descriptor. */
5039 if (se->want_pointer)
5040 se->expr = build_fold_addr_expr (desc);
5045 gfc_add_block_to_block (&se->pre, &loop.pre);
5046 gfc_add_block_to_block (&se->post, &loop.post);
5048 /* Cleanup the scalarizer. */
5049 gfc_cleanup_loop (&loop);
5053 /* Convert an array for passing as an actual parameter. */
5054 /* TODO: Optimize passing g77 arrays. */
5057 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
5061 tree tmp = NULL_TREE;
5063 tree parent = DECL_CONTEXT (current_function_decl);
5064 bool full_array_var, this_array_result;
5068 full_array_var = (expr->expr_type == EXPR_VARIABLE
5069 && expr->ref->u.ar.type == AR_FULL);
5070 sym = full_array_var ? expr->symtree->n.sym : NULL;
5072 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5074 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5075 expr->ts.cl->backend_decl = tmp;
5076 se->string_length = tmp;
5079 /* Is this the result of the enclosing procedure? */
5080 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5081 if (this_array_result
5082 && (sym->backend_decl != current_function_decl)
5083 && (sym->backend_decl != parent))
5084 this_array_result = false;
5086 /* Passing address of the array if it is not pointer or assumed-shape. */
5087 if (full_array_var && g77 && !this_array_result)
5089 tmp = gfc_get_symbol_decl (sym);
5091 if (sym->ts.type == BT_CHARACTER)
5092 se->string_length = sym->ts.cl->backend_decl;
5093 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5094 && !sym->attr.allocatable)
5096 /* Some variables are declared directly, others are declared as
5097 pointers and allocated on the heap. */
5098 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5101 se->expr = build_fold_addr_expr (tmp);
5104 if (sym->attr.allocatable)
5106 if (sym->attr.dummy || sym->attr.result)
5108 gfc_conv_expr_descriptor (se, expr, ss);
5109 se->expr = gfc_conv_array_data (se->expr);
5112 se->expr = gfc_conv_array_data (tmp);
5117 if (this_array_result)
5119 /* Result of the enclosing function. */
5120 gfc_conv_expr_descriptor (se, expr, ss);
5121 se->expr = build_fold_addr_expr (se->expr);
5123 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5124 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5125 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5131 /* Every other type of array. */
5132 se->want_pointer = 1;
5133 gfc_conv_expr_descriptor (se, expr, ss);
5137 /* Deallocate the allocatable components of structures that are
5139 if (expr->ts.type == BT_DERIVED
5140 && expr->ts.derived->attr.alloc_comp
5141 && expr->expr_type != EXPR_VARIABLE)
5143 tmp = build_fold_indirect_ref (se->expr);
5144 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5145 gfc_add_expr_to_block (&se->post, tmp);
5151 /* Repack the array. */
5152 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5153 ptr = gfc_evaluate_now (ptr, &se->pre);
5156 gfc_start_block (&block);
5158 /* Copy the data back. */
5159 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5160 gfc_add_expr_to_block (&block, tmp);
5162 /* Free the temporary. */
5163 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5164 gfc_add_expr_to_block (&block, tmp);
5166 stmt = gfc_finish_block (&block);
5168 gfc_init_block (&block);
5169 /* Only if it was repacked. This code needs to be executed before the
5170 loop cleanup code. */
5171 tmp = build_fold_indirect_ref (desc);
5172 tmp = gfc_conv_array_data (tmp);
5173 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5174 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5175 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5177 gfc_add_expr_to_block (&block, tmp);
5178 gfc_add_block_to_block (&block, &se->post);
5180 gfc_init_block (&se->post);
5181 gfc_add_block_to_block (&se->post, &block);
5186 /* Generate code to deallocate an array, if it is allocated. */
5189 gfc_trans_dealloc_allocated (tree descriptor)
5195 gfc_start_block (&block);
5197 var = gfc_conv_descriptor_data_get (descriptor);
5200 /* Call array_deallocate with an int * present in the second argument.
5201 Although it is ignored here, it's presence ensures that arrays that
5202 are already deallocated are ignored. */
5203 tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
5204 gfc_add_expr_to_block (&block, tmp);
5206 /* Zero the data pointer. */
5207 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5208 var, build_int_cst (TREE_TYPE (var), 0));
5209 gfc_add_expr_to_block (&block, tmp);
5211 return gfc_finish_block (&block);
5215 /* This helper function calculates the size in words of a full array. */
5218 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5223 idx = gfc_rank_cst[rank - 1];
5224 nelems = gfc_conv_descriptor_ubound (decl, idx);
5225 tmp = gfc_conv_descriptor_lbound (decl, idx);
5226 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5227 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5228 tmp, gfc_index_one_node);
5229 tmp = gfc_evaluate_now (tmp, block);
5231 nelems = gfc_conv_descriptor_stride (decl, idx);
5232 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5233 return gfc_evaluate_now (tmp, block);
5237 /* Allocate dest to the same size as src, and copy src -> dest. */
5240 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5249 /* If the source is null, set the destination to null. */
5250 gfc_init_block (&block);
5251 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5252 null_data = gfc_finish_block (&block);
5254 gfc_init_block (&block);
5256 nelems = get_full_array_size (&block, src, rank);
5257 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5258 fold_convert (gfc_array_index_type,
5259 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5261 /* Allocate memory to the destination. */
5262 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5264 gfc_conv_descriptor_data_set (&block, dest, tmp);
5266 /* We know the temporary and the value will be the same length,
5267 so can use memcpy. */
5268 tmp = built_in_decls[BUILT_IN_MEMCPY];
5269 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5270 gfc_conv_descriptor_data_get (src), size);
5271 gfc_add_expr_to_block (&block, tmp);
5272 tmp = gfc_finish_block (&block);
5274 /* Null the destination if the source is null; otherwise do
5275 the allocate and copy. */
5276 null_cond = gfc_conv_descriptor_data_get (src);
5277 null_cond = convert (pvoid_type_node, null_cond);
5278 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5279 null_cond, null_pointer_node);
5280 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5284 /* Recursively traverse an object of derived type, generating code to
5285 deallocate, nullify or copy allocatable components. This is the work horse
5286 function for the functions named in this enum. */
5288 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5291 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5292 tree dest, int rank, int purpose)
5296 stmtblock_t fnblock;
5297 stmtblock_t loopbody;
5307 tree null_cond = NULL_TREE;
5309 gfc_init_block (&fnblock);
5311 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5312 decl = build_fold_indirect_ref (decl);
5314 /* If this an array of derived types with allocatable components
5315 build a loop and recursively call this function. */
5316 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5317 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5319 tmp = gfc_conv_array_data (decl);
5320 var = build_fold_indirect_ref (tmp);
5322 /* Get the number of elements - 1 and set the counter. */
5323 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5325 /* Use the descriptor for an allocatable array. Since this
5326 is a full array reference, we only need the descriptor
5327 information from dimension = rank. */
5328 tmp = get_full_array_size (&fnblock, decl, rank);
5329 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5330 tmp, gfc_index_one_node);
5332 null_cond = gfc_conv_descriptor_data_get (decl);
5333 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5334 build_int_cst (TREE_TYPE (null_cond), 0));
5338 /* Otherwise use the TYPE_DOMAIN information. */
5339 tmp = array_type_nelts (TREE_TYPE (decl));
5340 tmp = fold_convert (gfc_array_index_type, tmp);
5343 /* Remember that this is, in fact, the no. of elements - 1. */
5344 nelems = gfc_evaluate_now (tmp, &fnblock);
5345 index = gfc_create_var (gfc_array_index_type, "S");
5347 /* Build the body of the loop. */
5348 gfc_init_block (&loopbody);
5350 vref = gfc_build_array_ref (var, index, NULL);
5352 if (purpose == COPY_ALLOC_COMP)
5354 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5355 gfc_add_expr_to_block (&fnblock, tmp);
5357 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5358 dref = gfc_build_array_ref (tmp, index, NULL);
5359 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5362 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5364 gfc_add_expr_to_block (&loopbody, tmp);
5366 /* Build the loop and return. */
5367 gfc_init_loopinfo (&loop);
5369 loop.from[0] = gfc_index_zero_node;
5370 loop.loopvar[0] = index;
5371 loop.to[0] = nelems;
5372 gfc_trans_scalarizing_loops (&loop, &loopbody);
5373 gfc_add_block_to_block (&fnblock, &loop.pre);
5375 tmp = gfc_finish_block (&fnblock);
5376 if (null_cond != NULL_TREE)
5377 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5382 /* Otherwise, act on the components or recursively call self to
5383 act on a chain of components. */
5384 for (c = der_type->components; c; c = c->next)
5386 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5387 && c->ts.derived->attr.alloc_comp;
5388 cdecl = c->backend_decl;
5389 ctype = TREE_TYPE (cdecl);
5393 case DEALLOCATE_ALLOC_COMP:
5394 /* Do not deallocate the components of ultimate pointer
5396 if (cmp_has_alloc_comps && !c->pointer)
5398 comp = fold_build3 (COMPONENT_REF, ctype,
5399 decl, cdecl, NULL_TREE);
5400 rank = c->as ? c->as->rank : 0;
5401 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5403 gfc_add_expr_to_block (&fnblock, tmp);
5408 comp = fold_build3 (COMPONENT_REF, ctype,
5409 decl, cdecl, NULL_TREE);
5410 tmp = gfc_trans_dealloc_allocated (comp);
5411 gfc_add_expr_to_block (&fnblock, tmp);
5415 case NULLIFY_ALLOC_COMP:
5418 else if (c->allocatable)
5420 comp = fold_build3 (COMPONENT_REF, ctype,
5421 decl, cdecl, NULL_TREE);
5422 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5424 else if (cmp_has_alloc_comps)
5426 comp = fold_build3 (COMPONENT_REF, ctype,
5427 decl, cdecl, NULL_TREE);
5428 rank = c->as ? c->as->rank : 0;
5429 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5431 gfc_add_expr_to_block (&fnblock, tmp);
5435 case COPY_ALLOC_COMP:
5439 /* We need source and destination components. */
5440 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5441 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5442 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5444 if (c->allocatable && !cmp_has_alloc_comps)
5446 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5447 gfc_add_expr_to_block (&fnblock, tmp);
5450 if (cmp_has_alloc_comps)
5452 rank = c->as ? c->as->rank : 0;
5453 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5454 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5455 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5457 gfc_add_expr_to_block (&fnblock, tmp);
5467 return gfc_finish_block (&fnblock);
5470 /* Recursively traverse an object of derived type, generating code to
5471 nullify allocatable components. */
5474 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5476 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5477 NULLIFY_ALLOC_COMP);
5481 /* Recursively traverse an object of derived type, generating code to
5482 deallocate allocatable components. */
5485 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5487 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5488 DEALLOCATE_ALLOC_COMP);
5492 /* Recursively traverse an object of derived type, generating code to
5493 copy its allocatable components. */
5496 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5498 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5502 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5503 Do likewise, recursively if necessary, with the allocatable components of
5507 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5512 stmtblock_t fnblock;
5515 bool sym_has_alloc_comp;
5517 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5518 && sym->ts.derived->attr.alloc_comp;
5520 /* Make sure the frontend gets these right. */
5521 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5522 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5523 "allocatable attribute or derived type without allocatable "
5526 gfc_init_block (&fnblock);
5528 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5529 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5531 if (sym->ts.type == BT_CHARACTER
5532 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5534 gfc_conv_string_length (sym->ts.cl, &fnblock);
5535 gfc_trans_vla_type_sizes (sym, &fnblock);
5538 /* Dummy and use associated variables don't need anything special. */
5539 if (sym->attr.dummy || sym->attr.use_assoc)
5541 gfc_add_expr_to_block (&fnblock, body);
5543 return gfc_finish_block (&fnblock);
5546 gfc_get_backend_locus (&loc);
5547 gfc_set_backend_locus (&sym->declared_at);
5548 descriptor = sym->backend_decl;
5550 /* Although static, derived types with default initializers and
5551 allocatable components must not be nulled wholesale; instead they
5552 are treated component by component. */
5553 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5555 /* SAVEd variables are not freed on exit. */
5556 gfc_trans_static_array_pointer (sym);
5560 /* Get the descriptor type. */
5561 type = TREE_TYPE (sym->backend_decl);
5563 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5565 if (!sym->attr.save)
5567 rank = sym->as ? sym->as->rank : 0;
5568 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5569 gfc_add_expr_to_block (&fnblock, tmp);
5572 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5574 /* If the backend_decl is not a descriptor, we must have a pointer
5576 descriptor = build_fold_indirect_ref (sym->backend_decl);
5577 type = TREE_TYPE (descriptor);
5580 /* NULLIFY the data pointer. */
5581 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5582 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5584 gfc_add_expr_to_block (&fnblock, body);
5586 gfc_set_backend_locus (&loc);
5588 /* Allocatable arrays need to be freed when they go out of scope.
5589 The allocatable components of pointers must not be touched. */
5590 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5591 && !sym->attr.pointer && !sym->attr.save)
5594 rank = sym->as ? sym->as->rank : 0;
5595 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5596 gfc_add_expr_to_block (&fnblock, tmp);
5599 if (sym->attr.allocatable && !sym->attr.save)
5601 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5602 gfc_add_expr_to_block (&fnblock, tmp);
5605 return gfc_finish_block (&fnblock);
5608 /************ Expression Walking Functions ******************/
5610 /* Walk a variable reference.
5612 Possible extension - multiple component subscripts.
5613 x(:,:) = foo%a(:)%b(:)
5615 forall (i=..., j=...)
5616 x(i,j) = foo%a(j)%b(i)
5618 This adds a fair amount of complexity because you need to deal with more
5619 than one ref. Maybe handle in a similar manner to vector subscripts.
5620 Maybe not worth the effort. */
5624 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5632 for (ref = expr->ref; ref; ref = ref->next)
5633 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5636 for (; ref; ref = ref->next)
5638 if (ref->type == REF_SUBSTRING)
5640 newss = gfc_get_ss ();
5641 newss->type = GFC_SS_SCALAR;
5642 newss->expr = ref->u.ss.start;
5646 newss = gfc_get_ss ();
5647 newss->type = GFC_SS_SCALAR;
5648 newss->expr = ref->u.ss.end;
5653 /* We're only interested in array sections from now on. */
5654 if (ref->type != REF_ARRAY)
5661 for (n = 0; n < ar->dimen; n++)
5663 newss = gfc_get_ss ();
5664 newss->type = GFC_SS_SCALAR;
5665 newss->expr = ar->start[n];
5672 newss = gfc_get_ss ();
5673 newss->type = GFC_SS_SECTION;
5676 newss->data.info.dimen = ar->as->rank;
5677 newss->data.info.ref = ref;
5679 /* Make sure array is the same as array(:,:), this way
5680 we don't need to special case all the time. */
5681 ar->dimen = ar->as->rank;
5682 for (n = 0; n < ar->dimen; n++)
5684 newss->data.info.dim[n] = n;
5685 ar->dimen_type[n] = DIMEN_RANGE;
5687 gcc_assert (ar->start[n] == NULL);
5688 gcc_assert (ar->end[n] == NULL);
5689 gcc_assert (ar->stride[n] == NULL);
5695 newss = gfc_get_ss ();
5696 newss->type = GFC_SS_SECTION;
5699 newss->data.info.dimen = 0;
5700 newss->data.info.ref = ref;
5704 /* We add SS chains for all the subscripts in the section. */
5705 for (n = 0; n < ar->dimen; n++)
5709 switch (ar->dimen_type[n])
5712 /* Add SS for elemental (scalar) subscripts. */
5713 gcc_assert (ar->start[n]);
5714 indexss = gfc_get_ss ();
5715 indexss->type = GFC_SS_SCALAR;
5716 indexss->expr = ar->start[n];
5717 indexss->next = gfc_ss_terminator;
5718 indexss->loop_chain = gfc_ss_terminator;
5719 newss->data.info.subscript[n] = indexss;
5723 /* We don't add anything for sections, just remember this
5724 dimension for later. */
5725 newss->data.info.dim[newss->data.info.dimen] = n;
5726 newss->data.info.dimen++;
5730 /* Create a GFC_SS_VECTOR index in which we can store
5731 the vector's descriptor. */
5732 indexss = gfc_get_ss ();
5733 indexss->type = GFC_SS_VECTOR;
5734 indexss->expr = ar->start[n];
5735 indexss->next = gfc_ss_terminator;
5736 indexss->loop_chain = gfc_ss_terminator;
5737 newss->data.info.subscript[n] = indexss;
5738 newss->data.info.dim[newss->data.info.dimen] = n;
5739 newss->data.info.dimen++;
5743 /* We should know what sort of section it is by now. */
5747 /* We should have at least one non-elemental dimension. */
5748 gcc_assert (newss->data.info.dimen > 0);
5753 /* We should know what sort of section it is by now. */
5762 /* Walk an expression operator. If only one operand of a binary expression is
5763 scalar, we must also add the scalar term to the SS chain. */
5766 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5772 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5773 if (expr->value.op.op2 == NULL)
5776 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5778 /* All operands are scalar. Pass back and let the caller deal with it. */
5782 /* All operands require scalarization. */
5783 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5786 /* One of the operands needs scalarization, the other is scalar.
5787 Create a gfc_ss for the scalar expression. */
5788 newss = gfc_get_ss ();
5789 newss->type = GFC_SS_SCALAR;
5792 /* First operand is scalar. We build the chain in reverse order, so
5793 add the scarar SS after the second operand. */
5795 while (head && head->next != ss)
5797 /* Check we haven't somehow broken the chain. */
5801 newss->expr = expr->value.op.op1;
5803 else /* head2 == head */
5805 gcc_assert (head2 == head);
5806 /* Second operand is scalar. */
5807 newss->next = head2;
5809 newss->expr = expr->value.op.op2;
5816 /* Reverse a SS chain. */
5819 gfc_reverse_ss (gfc_ss * ss)
5824 gcc_assert (ss != NULL);
5826 head = gfc_ss_terminator;
5827 while (ss != gfc_ss_terminator)
5830 /* Check we didn't somehow break the chain. */
5831 gcc_assert (next != NULL);
5841 /* Walk the arguments of an elemental function. */
5844 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5852 head = gfc_ss_terminator;
5855 for (; arg; arg = arg->next)
5860 newss = gfc_walk_subexpr (head, arg->expr);
5863 /* Scalar argument. */
5864 newss = gfc_get_ss ();
5866 newss->expr = arg->expr;
5876 while (tail->next != gfc_ss_terminator)
5883 /* If all the arguments are scalar we don't need the argument SS. */
5884 gfc_free_ss_chain (head);
5889 /* Add it onto the existing chain. */
5895 /* Walk a function call. Scalar functions are passed back, and taken out of
5896 scalarization loops. For elemental functions we walk their arguments.
5897 The result of functions returning arrays is stored in a temporary outside
5898 the loop, so that the function is only called once. Hence we do not need
5899 to walk their arguments. */
5902 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5905 gfc_intrinsic_sym *isym;
5908 isym = expr->value.function.isym;
5910 /* Handle intrinsic functions separately. */
5912 return gfc_walk_intrinsic_function (ss, expr, isym);
5914 sym = expr->value.function.esym;
5916 sym = expr->symtree->n.sym;
5918 /* A function that returns arrays. */
5919 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5921 newss = gfc_get_ss ();
5922 newss->type = GFC_SS_FUNCTION;
5925 newss->data.info.dimen = expr->rank;
5929 /* Walk the parameters of an elemental function. For now we always pass
5931 if (sym->attr.elemental)
5932 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5935 /* Scalar functions are OK as these are evaluated outside the scalarization
5936 loop. Pass back and let the caller deal with it. */
5941 /* An array temporary is constructed for array constructors. */
5944 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5949 newss = gfc_get_ss ();
5950 newss->type = GFC_SS_CONSTRUCTOR;
5953 newss->data.info.dimen = expr->rank;
5954 for (n = 0; n < expr->rank; n++)
5955 newss->data.info.dim[n] = n;
5961 /* Walk an expression. Add walked expressions to the head of the SS chain.
5962 A wholly scalar expression will not be added. */
5965 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5969 switch (expr->expr_type)
5972 head = gfc_walk_variable_expr (ss, expr);
5976 head = gfc_walk_op_expr (ss, expr);
5980 head = gfc_walk_function_expr (ss, expr);
5985 case EXPR_STRUCTURE:
5986 /* Pass back and let the caller deal with it. */
5990 head = gfc_walk_array_constructor (ss, expr);
5993 case EXPR_SUBSTRING:
5994 /* Pass back and let the caller deal with it. */
5998 internal_error ("bad expression type during walk (%d)",
6005 /* Entry point for expression walking.
6006 A return value equal to the passed chain means this is
6007 a scalar expression. It is up to the caller to take whatever action is
6008 necessary to translate these. */
6011 gfc_walk_expr (gfc_expr * expr)
6015 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6016 return gfc_reverse_ss (res);