1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field. */
161 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
165 type = TREE_TYPE (desc);
166 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
168 field = TYPE_FIELDS (type);
169 gcc_assert (DATA_FIELD == 0);
171 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
172 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
176 /* This provides address access to the data field. This should only be
177 used by array allocation, passing this on to the runtime. */
180 gfc_conv_descriptor_data_addr (tree desc)
184 type = TREE_TYPE (desc);
185 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
187 field = TYPE_FIELDS (type);
188 gcc_assert (DATA_FIELD == 0);
190 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
191 return gfc_build_addr_expr (NULL, t);
195 gfc_conv_descriptor_offset (tree desc)
200 type = TREE_TYPE (desc);
201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
203 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
204 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
206 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
210 gfc_conv_descriptor_dtype (tree desc)
215 type = TREE_TYPE (desc);
216 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
218 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
219 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
221 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
225 gfc_conv_descriptor_dimension (tree desc, tree dim)
231 type = TREE_TYPE (desc);
232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
234 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
235 gcc_assert (field != NULL_TREE
236 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
237 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
239 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
240 tmp = gfc_build_array_ref (tmp, dim);
245 gfc_conv_descriptor_stride (tree desc, tree dim)
250 tmp = gfc_conv_descriptor_dimension (desc, dim);
251 field = TYPE_FIELDS (TREE_TYPE (tmp));
252 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
253 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
255 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
260 gfc_conv_descriptor_lbound (tree desc, tree dim)
265 tmp = gfc_conv_descriptor_dimension (desc, dim);
266 field = TYPE_FIELDS (TREE_TYPE (tmp));
267 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
268 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
270 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
275 gfc_conv_descriptor_ubound (tree desc, tree dim)
280 tmp = gfc_conv_descriptor_dimension (desc, dim);
281 field = TYPE_FIELDS (TREE_TYPE (tmp));
282 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
285 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
290 /* Build a null array descriptor constructor. */
293 gfc_build_null_descriptor (tree type)
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
299 gcc_assert (DATA_FIELD == 0);
300 field = TYPE_FIELDS (type);
302 /* Set a NULL data pointer. */
303 tmp = build_constructor_single (type, field, null_pointer_node);
304 TREE_CONSTANT (tmp) = 1;
305 TREE_INVARIANT (tmp) = 1;
306 /* All other fields are ignored. */
312 /* Cleanup those #defines. */
317 #undef DIMENSION_FIELD
318 #undef STRIDE_SUBFIELD
319 #undef LBOUND_SUBFIELD
320 #undef UBOUND_SUBFIELD
323 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
324 flags & 1 = Main loop body.
325 flags & 2 = temp copy loop. */
328 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
330 for (; ss != gfc_ss_terminator; ss = ss->next)
331 ss->useflags = flags;
334 static void gfc_free_ss (gfc_ss *);
337 /* Free a gfc_ss chain. */
340 gfc_free_ss_chain (gfc_ss * ss)
344 while (ss != gfc_ss_terminator)
346 gcc_assert (ss != NULL);
357 gfc_free_ss (gfc_ss * ss)
364 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
366 if (ss->data.info.subscript[n])
367 gfc_free_ss_chain (ss->data.info.subscript[n]);
379 /* Free all the SS associated with a loop. */
382 gfc_cleanup_loop (gfc_loopinfo * loop)
388 while (ss != gfc_ss_terminator)
390 gcc_assert (ss != NULL);
391 next = ss->loop_chain;
398 /* Associate a SS chain with a loop. */
401 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
405 if (head == gfc_ss_terminator)
409 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
411 if (ss->next == gfc_ss_terminator)
412 ss->loop_chain = loop->ss;
414 ss->loop_chain = ss->next;
416 gcc_assert (ss == gfc_ss_terminator);
421 /* Generate an initializer for a static pointer or allocatable array. */
424 gfc_trans_static_array_pointer (gfc_symbol * sym)
428 gcc_assert (TREE_STATIC (sym->backend_decl));
429 /* Just zero the data member. */
430 type = TREE_TYPE (sym->backend_decl);
431 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
435 /* If the bounds of SE's loop have not yet been set, see if they can be
436 determined from array spec AS, which is the array spec of a called
437 function. MAPPING maps the callee's dummy arguments to the values
438 that the caller is passing. Add any initialization and finalization
442 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
443 gfc_se * se, gfc_array_spec * as)
451 if (as && as->type == AS_EXPLICIT)
452 for (dim = 0; dim < se->loop->dimen; dim++)
454 n = se->loop->order[dim];
455 if (se->loop->to[n] == NULL_TREE)
457 /* Evaluate the lower bound. */
458 gfc_init_se (&tmpse, NULL);
459 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
460 gfc_add_block_to_block (&se->pre, &tmpse.pre);
461 gfc_add_block_to_block (&se->post, &tmpse.post);
464 /* ...and the upper bound. */
465 gfc_init_se (&tmpse, NULL);
466 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
467 gfc_add_block_to_block (&se->pre, &tmpse.pre);
468 gfc_add_block_to_block (&se->post, &tmpse.post);
471 /* Set the upper bound of the loop to UPPER - LOWER. */
472 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
473 tmp = gfc_evaluate_now (tmp, &se->pre);
474 se->loop->to[n] = tmp;
480 /* Generate code to allocate an array temporary, or create a variable to
481 hold the data. If size is NULL zero the descriptor so that so that the
482 callee will allocate the array. Also generates code to free the array
485 Initialization code is added to PRE and finalization code to POST.
486 DYNAMIC is true if the caller may want to extend the array later
487 using realloc. This prevents us from putting the array on the stack. */
490 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
491 gfc_ss_info * info, tree size, tree nelem,
499 desc = info->descriptor;
500 info->offset = gfc_index_zero_node;
501 if (size == NULL_TREE || integer_zerop (size))
503 /* A callee allocated array. */
504 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
509 /* Allocate the temporary. */
510 onstack = !dynamic && gfc_can_put_var_on_stack (size);
514 /* Make a temporary variable to hold the data. */
515 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
517 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
519 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
521 tmp = gfc_create_var (tmp, "A");
522 tmp = gfc_build_addr_expr (NULL, tmp);
523 gfc_conv_descriptor_data_set (pre, desc, tmp);
527 /* Allocate memory to hold the data. */
528 args = gfc_chainon_list (NULL_TREE, size);
530 if (gfc_index_integer_kind == 4)
531 tmp = gfor_fndecl_internal_malloc;
532 else if (gfc_index_integer_kind == 8)
533 tmp = gfor_fndecl_internal_malloc64;
536 tmp = gfc_build_function_call (tmp, args);
537 tmp = gfc_evaluate_now (tmp, pre);
538 gfc_conv_descriptor_data_set (pre, desc, tmp);
541 info->data = gfc_conv_descriptor_data_get (desc);
543 /* The offset is zero because we create temporaries with a zero
545 tmp = gfc_conv_descriptor_offset (desc);
546 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
550 /* Free the temporary. */
551 tmp = gfc_conv_descriptor_data_get (desc);
552 tmp = fold_convert (pvoid_type_node, tmp);
553 tmp = gfc_chainon_list (NULL_TREE, tmp);
554 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
555 gfc_add_expr_to_block (post, tmp);
560 /* Generate code to allocate and initialize the descriptor for a temporary
561 array. This is used for both temporaries needed by the scalarizer, and
562 functions returning arrays. Adjusts the loop variables to be zero-based,
563 and calculates the loop bounds for callee allocated arrays.
564 Also fills in the descriptor, data and offset fields of info if known.
565 Returns the size of the array, or NULL for a callee allocated array.
567 PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage. */
570 gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
571 gfc_loopinfo * loop, gfc_ss_info * info,
572 tree eltype, bool dynamic)
582 gcc_assert (info->dimen > 0);
583 /* Set the lower bound to zero. */
584 for (dim = 0; dim < info->dimen; dim++)
586 n = loop->order[dim];
587 if (n < loop->temp_dim)
588 gcc_assert (integer_zerop (loop->from[n]));
591 /* Callee allocated arrays may not have a known bound yet. */
593 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
594 loop->to[n], loop->from[n]);
595 loop->from[n] = gfc_index_zero_node;
598 info->delta[dim] = gfc_index_zero_node;
599 info->start[dim] = gfc_index_zero_node;
600 info->stride[dim] = gfc_index_one_node;
601 info->dim[dim] = dim;
604 /* Initialize the descriptor. */
606 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
607 desc = gfc_create_var (type, "atmp");
608 GFC_DECL_PACKED_ARRAY (desc) = 1;
610 info->descriptor = desc;
611 size = gfc_index_one_node;
613 /* Fill in the array dtype. */
614 tmp = gfc_conv_descriptor_dtype (desc);
615 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
618 Fill in the bounds and stride. This is a packed array, so:
621 for (n = 0; n < rank; n++)
624 delta = ubound[n] + 1 - lbound[n];
627 size = size * sizeof(element);
630 for (n = 0; n < info->dimen; n++)
632 if (loop->to[n] == NULL_TREE)
634 /* For a callee allocated array express the loop bounds in terms
635 of the descriptor fields. */
636 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
637 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
638 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
644 /* Store the stride and bound components in the descriptor. */
645 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
646 gfc_add_modify_expr (pre, tmp, size);
648 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
649 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
651 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
652 gfc_add_modify_expr (pre, tmp, loop->to[n]);
654 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
655 loop->to[n], gfc_index_one_node);
657 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
658 size = gfc_evaluate_now (size, pre);
661 /* Get the size of the array. */
664 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
665 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
667 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
669 if (info->dimen > loop->temp_dim)
670 loop->temp_dim = info->dimen;
676 /* Generate code to tranpose array EXPR by creating a new descriptor
677 in which the dimension specifications have been reversed. */
680 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
682 tree dest, src, dest_index, src_index;
684 gfc_ss_info *dest_info, *src_info;
685 gfc_ss *dest_ss, *src_ss;
691 src_ss = gfc_walk_expr (expr);
694 src_info = &src_ss->data.info;
695 dest_info = &dest_ss->data.info;
697 /* Get a descriptor for EXPR. */
698 gfc_init_se (&src_se, NULL);
699 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
700 gfc_add_block_to_block (&se->pre, &src_se.pre);
701 gfc_add_block_to_block (&se->post, &src_se.post);
704 /* Allocate a new descriptor for the return value. */
705 dest = gfc_create_var (TREE_TYPE (src), "atmp");
706 dest_info->descriptor = dest;
709 /* Copy across the dtype field. */
710 gfc_add_modify_expr (&se->pre,
711 gfc_conv_descriptor_dtype (dest),
712 gfc_conv_descriptor_dtype (src));
714 /* Copy the dimension information, renumbering dimension 1 to 0 and
716 gcc_assert (dest_info->dimen == 2);
717 gcc_assert (src_info->dimen == 2);
718 for (n = 0; n < 2; n++)
720 dest_info->delta[n] = integer_zero_node;
721 dest_info->start[n] = integer_zero_node;
722 dest_info->stride[n] = integer_one_node;
723 dest_info->dim[n] = n;
725 dest_index = gfc_rank_cst[n];
726 src_index = gfc_rank_cst[1 - n];
728 gfc_add_modify_expr (&se->pre,
729 gfc_conv_descriptor_stride (dest, dest_index),
730 gfc_conv_descriptor_stride (src, src_index));
732 gfc_add_modify_expr (&se->pre,
733 gfc_conv_descriptor_lbound (dest, dest_index),
734 gfc_conv_descriptor_lbound (src, src_index));
736 gfc_add_modify_expr (&se->pre,
737 gfc_conv_descriptor_ubound (dest, dest_index),
738 gfc_conv_descriptor_ubound (src, src_index));
742 gcc_assert (integer_zerop (loop->from[n]));
743 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
744 gfc_conv_descriptor_ubound (dest, dest_index),
745 gfc_conv_descriptor_lbound (dest, dest_index));
749 /* Copy the data pointer. */
750 dest_info->data = gfc_conv_descriptor_data_get (src);
751 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
753 /* Copy the offset. This is not changed by transposition: the top-left
754 element is still at the same offset as before. */
755 dest_info->offset = gfc_conv_descriptor_offset (src);
756 gfc_add_modify_expr (&se->pre,
757 gfc_conv_descriptor_offset (dest),
760 if (dest_info->dimen > loop->temp_dim)
761 loop->temp_dim = dest_info->dimen;
765 /* Return the number of iterations in a loop that starts at START,
766 ends at END, and has step STEP. */
769 gfc_get_iteration_count (tree start, tree end, tree step)
774 type = TREE_TYPE (step);
775 tmp = fold_build2 (MINUS_EXPR, type, end, start);
776 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
777 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
778 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
779 return fold_convert (gfc_array_index_type, tmp);
783 /* Extend the data in array DESC by EXTRA elements. */
786 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
793 if (integer_zerop (extra))
796 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
798 /* Add EXTRA to the upper bound. */
799 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
800 gfc_add_modify_expr (pblock, ubound, tmp);
802 /* Get the value of the current data pointer. */
803 tmp = gfc_conv_descriptor_data_get (desc);
804 args = gfc_chainon_list (NULL_TREE, tmp);
806 /* Calculate the new array size. */
807 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
808 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
809 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
810 args = gfc_chainon_list (args, tmp);
812 /* Pick the appropriate realloc function. */
813 if (gfc_index_integer_kind == 4)
814 tmp = gfor_fndecl_internal_realloc;
815 else if (gfc_index_integer_kind == 8)
816 tmp = gfor_fndecl_internal_realloc64;
820 /* Set the new data pointer. */
821 tmp = gfc_build_function_call (tmp, args);
822 gfc_conv_descriptor_data_set (pblock, desc, tmp);
826 /* Return true if the bounds of iterator I can only be determined
830 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
832 return (i->start->expr_type != EXPR_CONSTANT
833 || i->end->expr_type != EXPR_CONSTANT
834 || i->step->expr_type != EXPR_CONSTANT);
838 /* Split the size of constructor element EXPR into the sum of two terms,
839 one of which can be determined at compile time and one of which must
840 be calculated at run time. Set *SIZE to the former and return true
841 if the latter might be nonzero. */
844 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
846 if (expr->expr_type == EXPR_ARRAY)
847 return gfc_get_array_constructor_size (size, expr->value.constructor);
848 else if (expr->rank > 0)
850 /* Calculate everything at run time. */
851 mpz_set_ui (*size, 0);
856 /* A single element. */
857 mpz_set_ui (*size, 1);
863 /* Like gfc_get_array_constructor_element_size, but applied to the whole
864 of array constructor C. */
867 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
874 mpz_set_ui (*size, 0);
879 for (; c; c = c->next)
882 if (i && gfc_iterator_has_dynamic_bounds (i))
886 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
889 /* Multiply the static part of the element size by the
890 number of iterations. */
891 mpz_sub (val, i->end->value.integer, i->start->value.integer);
892 mpz_fdiv_q (val, val, i->step->value.integer);
893 mpz_add_ui (val, val, 1);
894 if (mpz_sgn (val) > 0)
895 mpz_mul (len, len, val);
899 mpz_add (*size, *size, len);
908 /* Make sure offset is a variable. */
911 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
914 /* We should have already created the offset variable. We cannot
915 create it here because we may be in an inner scope. */
916 gcc_assert (*offsetvar != NULL_TREE);
917 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
918 *poffset = *offsetvar;
919 TREE_USED (*offsetvar) = 1;
923 /* Assign an element of an array constructor. */
926 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
927 tree offset, gfc_se * se, gfc_expr * expr)
932 gfc_conv_expr (se, expr);
934 /* Store the value. */
935 tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
936 tmp = gfc_build_array_ref (tmp, offset);
937 if (expr->ts.type == BT_CHARACTER)
939 gfc_conv_string_parameter (se);
940 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
942 /* The temporary is an array of pointers. */
943 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
944 gfc_add_modify_expr (&se->pre, tmp, se->expr);
948 /* The temporary is an array of string values. */
949 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
950 /* We know the temporary and the value will be the same length,
951 so can use memcpy. */
952 args = gfc_chainon_list (NULL_TREE, tmp);
953 args = gfc_chainon_list (args, se->expr);
954 args = gfc_chainon_list (args, se->string_length);
955 tmp = built_in_decls[BUILT_IN_MEMCPY];
956 tmp = gfc_build_function_call (tmp, args);
957 gfc_add_expr_to_block (&se->pre, tmp);
962 /* TODO: Should the frontend already have done this conversion? */
963 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
964 gfc_add_modify_expr (&se->pre, tmp, se->expr);
967 gfc_add_block_to_block (pblock, &se->pre);
968 gfc_add_block_to_block (pblock, &se->post);
972 /* Add the contents of an array to the constructor. DYNAMIC is as for
973 gfc_trans_array_constructor_value. */
976 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
977 tree type ATTRIBUTE_UNUSED,
978 tree desc, gfc_expr * expr,
979 tree * poffset, tree * offsetvar,
990 /* We need this to be a variable so we can increment it. */
991 gfc_put_offset_into_var (pblock, poffset, offsetvar);
993 gfc_init_se (&se, NULL);
995 /* Walk the array expression. */
996 ss = gfc_walk_expr (expr);
997 gcc_assert (ss != gfc_ss_terminator);
999 /* Initialize the scalarizer. */
1000 gfc_init_loopinfo (&loop);
1001 gfc_add_ss_to_loop (&loop, ss);
1003 /* Initialize the loop. */
1004 gfc_conv_ss_startstride (&loop);
1005 gfc_conv_loop_setup (&loop);
1007 /* Make sure the constructed array has room for the new data. */
1010 /* Set SIZE to the total number of elements in the subarray. */
1011 size = gfc_index_one_node;
1012 for (n = 0; n < loop.dimen; n++)
1014 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1015 gfc_index_one_node);
1016 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1019 /* Grow the constructed array by SIZE elements. */
1020 gfc_grow_array (&loop.pre, desc, size);
1023 /* Make the loop body. */
1024 gfc_mark_ss_chain_used (ss, 1);
1025 gfc_start_scalarized_body (&loop, &body);
1026 gfc_copy_loopinfo_to_se (&se, &loop);
1029 if (expr->ts.type == BT_CHARACTER)
1030 gfc_todo_error ("character arrays in constructors");
1032 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1033 gcc_assert (se.ss == gfc_ss_terminator);
1035 /* Increment the offset. */
1036 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1037 gfc_add_modify_expr (&body, *poffset, tmp);
1039 /* Finish the loop. */
1040 gfc_trans_scalarizing_loops (&loop, &body);
1041 gfc_add_block_to_block (&loop.pre, &loop.post);
1042 tmp = gfc_finish_block (&loop.pre);
1043 gfc_add_expr_to_block (pblock, tmp);
1045 gfc_cleanup_loop (&loop);
1049 /* Assign the values to the elements of an array constructor. DYNAMIC
1050 is true if descriptor DESC only contains enough data for the static
1051 size calculated by gfc_get_array_constructor_size. When true, memory
1052 for the dynamic parts must be allocated using realloc. */
1055 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1056 tree desc, gfc_constructor * c,
1057 tree * poffset, tree * offsetvar,
1066 for (; c; c = c->next)
1068 /* If this is an iterator or an array, the offset must be a variable. */
1069 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1070 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1072 gfc_start_block (&body);
1074 if (c->expr->expr_type == EXPR_ARRAY)
1076 /* Array constructors can be nested. */
1077 gfc_trans_array_constructor_value (&body, type, desc,
1078 c->expr->value.constructor,
1079 poffset, offsetvar, dynamic);
1081 else if (c->expr->rank > 0)
1083 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1084 poffset, offsetvar, dynamic);
1088 /* This code really upsets the gimplifier so don't bother for now. */
1095 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1102 /* Scalar values. */
1103 gfc_init_se (&se, NULL);
1104 gfc_trans_array_ctor_element (&body, desc, *poffset,
1107 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1108 *poffset, gfc_index_one_node);
1112 /* Collect multiple scalar constants into a constructor. */
1120 /* Count the number of consecutive scalar constants. */
1121 while (p && !(p->iterator
1122 || p->expr->expr_type != EXPR_CONSTANT))
1124 gfc_init_se (&se, NULL);
1125 gfc_conv_constant (&se, p->expr);
1126 if (p->expr->ts.type == BT_CHARACTER
1127 && POINTER_TYPE_P (type))
1129 /* For constant character array constructors we build
1130 an array of pointers. */
1131 se.expr = gfc_build_addr_expr (pchar_type_node,
1135 list = tree_cons (NULL_TREE, se.expr, list);
1140 bound = build_int_cst (NULL_TREE, n - 1);
1141 /* Create an array type to hold them. */
1142 tmptype = build_range_type (gfc_array_index_type,
1143 gfc_index_zero_node, bound);
1144 tmptype = build_array_type (type, tmptype);
1146 init = build_constructor_from_list (tmptype, nreverse (list));
1147 TREE_CONSTANT (init) = 1;
1148 TREE_INVARIANT (init) = 1;
1149 TREE_STATIC (init) = 1;
1150 /* Create a static variable to hold the data. */
1151 tmp = gfc_create_var (tmptype, "data");
1152 TREE_STATIC (tmp) = 1;
1153 TREE_CONSTANT (tmp) = 1;
1154 TREE_INVARIANT (tmp) = 1;
1155 DECL_INITIAL (tmp) = init;
1158 /* Use BUILTIN_MEMCPY to assign the values. */
1159 tmp = gfc_conv_descriptor_data_get (desc);
1160 tmp = gfc_build_indirect_ref (tmp);
1161 tmp = gfc_build_array_ref (tmp, *poffset);
1162 tmp = gfc_build_addr_expr (NULL, tmp);
1163 init = gfc_build_addr_expr (NULL, init);
1165 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1166 bound = build_int_cst (NULL_TREE, n * size);
1167 tmp = gfc_chainon_list (NULL_TREE, tmp);
1168 tmp = gfc_chainon_list (tmp, init);
1169 tmp = gfc_chainon_list (tmp, bound);
1170 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
1172 gfc_add_expr_to_block (&body, tmp);
1174 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1175 *poffset, build_int_cst (NULL_TREE, n));
1177 if (!INTEGER_CST_P (*poffset))
1179 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1180 *poffset = *offsetvar;
1184 /* The frontend should already have done any expansions possible
1188 /* Pass the code as is. */
1189 tmp = gfc_finish_block (&body);
1190 gfc_add_expr_to_block (pblock, tmp);
1194 /* Build the implied do-loop. */
1203 loopbody = gfc_finish_block (&body);
1205 gfc_init_se (&se, NULL);
1206 gfc_conv_expr (&se, c->iterator->var);
1207 gfc_add_block_to_block (pblock, &se.pre);
1210 /* Initialize the loop. */
1211 gfc_init_se (&se, NULL);
1212 gfc_conv_expr_val (&se, c->iterator->start);
1213 gfc_add_block_to_block (pblock, &se.pre);
1214 gfc_add_modify_expr (pblock, loopvar, se.expr);
1216 gfc_init_se (&se, NULL);
1217 gfc_conv_expr_val (&se, c->iterator->end);
1218 gfc_add_block_to_block (pblock, &se.pre);
1219 end = gfc_evaluate_now (se.expr, pblock);
1221 gfc_init_se (&se, NULL);
1222 gfc_conv_expr_val (&se, c->iterator->step);
1223 gfc_add_block_to_block (pblock, &se.pre);
1224 step = gfc_evaluate_now (se.expr, pblock);
1226 /* If this array expands dynamically, and the number of iterations
1227 is not constant, we won't have allocated space for the static
1228 part of C->EXPR's size. Do that now. */
1229 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1231 /* Get the number of iterations. */
1232 tmp = gfc_get_iteration_count (loopvar, end, step);
1234 /* Get the static part of C->EXPR's size. */
1235 gfc_get_array_constructor_element_size (&size, c->expr);
1236 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1238 /* Grow the array by TMP * TMP2 elements. */
1239 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1240 gfc_grow_array (pblock, desc, tmp);
1243 /* Generate the loop body. */
1244 exit_label = gfc_build_label_decl (NULL_TREE);
1245 gfc_start_block (&body);
1247 /* Generate the exit condition. Depending on the sign of
1248 the step variable we have to generate the correct
1250 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1251 build_int_cst (TREE_TYPE (step), 0));
1252 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1253 build2 (GT_EXPR, boolean_type_node,
1255 build2 (LT_EXPR, boolean_type_node,
1257 tmp = build1_v (GOTO_EXPR, exit_label);
1258 TREE_USED (exit_label) = 1;
1259 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1260 gfc_add_expr_to_block (&body, tmp);
1262 /* The main loop body. */
1263 gfc_add_expr_to_block (&body, loopbody);
1265 /* Increase loop variable by step. */
1266 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1267 gfc_add_modify_expr (&body, loopvar, tmp);
1269 /* Finish the loop. */
1270 tmp = gfc_finish_block (&body);
1271 tmp = build1_v (LOOP_EXPR, tmp);
1272 gfc_add_expr_to_block (pblock, tmp);
1274 /* Add the exit label. */
1275 tmp = build1_v (LABEL_EXPR, exit_label);
1276 gfc_add_expr_to_block (pblock, tmp);
1283 /* Figure out the string length of a variable reference expression.
1284 Used by get_array_ctor_strlen. */
1287 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1292 /* Don't bother if we already know the length is a constant. */
1293 if (*len && INTEGER_CST_P (*len))
1296 ts = &expr->symtree->n.sym->ts;
1297 for (ref = expr->ref; ref; ref = ref->next)
1302 /* Array references don't change the string length. */
1306 /* Use the length of the component. */
1307 ts = &ref->u.c.component->ts;
1311 /* TODO: Substrings are tricky because we can't evaluate the
1312 expression more than once. For now we just give up, and hope
1313 we can figure it out elsewhere. */
1318 *len = ts->cl->backend_decl;
1322 /* Figure out the string length of a character array constructor.
1323 Returns TRUE if all elements are character constants. */
1326 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1331 for (; c; c = c->next)
1333 switch (c->expr->expr_type)
1336 if (!(*len && INTEGER_CST_P (*len)))
1337 *len = build_int_cstu (gfc_charlen_type_node,
1338 c->expr->value.character.length);
1342 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1348 get_array_ctor_var_strlen (c->expr, len);
1353 /* TODO: For now we just ignore anything we don't know how to
1354 handle, and hope we can figure it out a different way. */
1363 /* Array constructors are handled by constructing a temporary, then using that
1364 within the scalarization loop. This is not optimal, but seems by far the
1368 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1378 ss->data.info.dimen = loop->dimen;
1380 c = ss->expr->value.constructor;
1381 if (ss->expr->ts.type == BT_CHARACTER)
1383 const_string = get_array_ctor_strlen (c, &ss->string_length);
1384 if (!ss->string_length)
1385 gfc_todo_error ("complex character array constructors");
1387 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1389 type = build_pointer_type (type);
1393 const_string = TRUE;
1394 type = gfc_typenode_for_spec (&ss->expr->ts);
1397 /* See if the constructor determines the loop bounds. */
1399 if (loop->to[0] == NULL_TREE)
1403 /* We should have a 1-dimensional, zero-based loop. */
1404 gcc_assert (loop->dimen == 1);
1405 gcc_assert (integer_zerop (loop->from[0]));
1407 /* Split the constructor size into a static part and a dynamic part.
1408 Allocate the static size up-front and record whether the dynamic
1409 size might be nonzero. */
1411 dynamic = gfc_get_array_constructor_size (&size, c);
1412 mpz_sub_ui (size, size, 1);
1413 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1417 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
1418 &ss->data.info, type, dynamic);
1420 desc = ss->data.info.descriptor;
1421 offset = gfc_index_zero_node;
1422 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1423 TREE_USED (offsetvar) = 0;
1424 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1425 &offset, &offsetvar, dynamic);
1427 /* If the array grows dynamically, the upper bound of the loop variable
1428 is determined by the array's final upper bound. */
1430 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1432 if (TREE_USED (offsetvar))
1433 pushdecl (offsetvar);
1435 gcc_assert (INTEGER_CST_P (offset));
1437 /* Disable bound checking for now because it's probably broken. */
1438 if (flag_bounds_check)
1446 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1447 called after evaluating all of INFO's vector dimensions. Go through
1448 each such vector dimension and see if we can now fill in any missing
1452 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1461 for (n = 0; n < loop->dimen; n++)
1464 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1465 && loop->to[n] == NULL)
1467 /* Loop variable N indexes vector dimension DIM, and we don't
1468 yet know the upper bound of loop variable N. Set it to the
1469 difference between the vector's upper and lower bounds. */
1470 gcc_assert (loop->from[n] == gfc_index_zero_node);
1471 gcc_assert (info->subscript[dim]
1472 && info->subscript[dim]->type == GFC_SS_VECTOR);
1474 gfc_init_se (&se, NULL);
1475 desc = info->subscript[dim]->data.info.descriptor;
1476 zero = gfc_rank_cst[0];
1477 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1478 gfc_conv_descriptor_ubound (desc, zero),
1479 gfc_conv_descriptor_lbound (desc, zero));
1480 tmp = gfc_evaluate_now (tmp, &loop->pre);
1487 /* Add the pre and post chains for all the scalar expressions in a SS chain
1488 to loop. This is called after the loop parameters have been calculated,
1489 but before the actual scalarizing loops. */
1492 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1497 /* TODO: This can generate bad code if there are ordering dependencies.
1498 eg. a callee allocated function and an unknown size constructor. */
1499 gcc_assert (ss != NULL);
1501 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1508 /* Scalar expression. Evaluate this now. This includes elemental
1509 dimension indices, but not array section bounds. */
1510 gfc_init_se (&se, NULL);
1511 gfc_conv_expr (&se, ss->expr);
1512 gfc_add_block_to_block (&loop->pre, &se.pre);
1514 if (ss->expr->ts.type != BT_CHARACTER)
1516 /* Move the evaluation of scalar expressions outside the
1517 scalarization loop. */
1519 se.expr = convert(gfc_array_index_type, se.expr);
1520 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1521 gfc_add_block_to_block (&loop->pre, &se.post);
1524 gfc_add_block_to_block (&loop->post, &se.post);
1526 ss->data.scalar.expr = se.expr;
1527 ss->string_length = se.string_length;
1530 case GFC_SS_REFERENCE:
1531 /* Scalar reference. Evaluate this now. */
1532 gfc_init_se (&se, NULL);
1533 gfc_conv_expr_reference (&se, ss->expr);
1534 gfc_add_block_to_block (&loop->pre, &se.pre);
1535 gfc_add_block_to_block (&loop->post, &se.post);
1537 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1538 ss->string_length = se.string_length;
1541 case GFC_SS_SECTION:
1542 /* Add the expressions for scalar and vector subscripts. */
1543 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1544 if (ss->data.info.subscript[n])
1545 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1547 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1551 /* Get the vector's descriptor and store it in SS. */
1552 gfc_init_se (&se, NULL);
1553 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1554 gfc_add_block_to_block (&loop->pre, &se.pre);
1555 gfc_add_block_to_block (&loop->post, &se.post);
1556 ss->data.info.descriptor = se.expr;
1559 case GFC_SS_INTRINSIC:
1560 gfc_add_intrinsic_ss_code (loop, ss);
1563 case GFC_SS_FUNCTION:
1564 /* Array function return value. We call the function and save its
1565 result in a temporary for use inside the loop. */
1566 gfc_init_se (&se, NULL);
1569 gfc_conv_expr (&se, ss->expr);
1570 gfc_add_block_to_block (&loop->pre, &se.pre);
1571 gfc_add_block_to_block (&loop->post, &se.post);
1572 ss->string_length = se.string_length;
1575 case GFC_SS_CONSTRUCTOR:
1576 gfc_trans_array_constructor (loop, ss);
1580 case GFC_SS_COMPONENT:
1581 /* Do nothing. These are handled elsewhere. */
1591 /* Translate expressions for the descriptor and data pointer of a SS. */
1595 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1600 /* Get the descriptor for the array to be scalarized. */
1601 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1602 gfc_init_se (&se, NULL);
1603 se.descriptor_only = 1;
1604 gfc_conv_expr_lhs (&se, ss->expr);
1605 gfc_add_block_to_block (block, &se.pre);
1606 ss->data.info.descriptor = se.expr;
1607 ss->string_length = se.string_length;
1611 /* Also the data pointer. */
1612 tmp = gfc_conv_array_data (se.expr);
1613 /* If this is a variable or address of a variable we use it directly.
1614 Otherwise we must evaluate it now to avoid breaking dependency
1615 analysis by pulling the expressions for elemental array indices
1618 || (TREE_CODE (tmp) == ADDR_EXPR
1619 && DECL_P (TREE_OPERAND (tmp, 0)))))
1620 tmp = gfc_evaluate_now (tmp, block);
1621 ss->data.info.data = tmp;
1623 tmp = gfc_conv_array_offset (se.expr);
1624 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1629 /* Initialize a gfc_loopinfo structure. */
1632 gfc_init_loopinfo (gfc_loopinfo * loop)
1636 memset (loop, 0, sizeof (gfc_loopinfo));
1637 gfc_init_block (&loop->pre);
1638 gfc_init_block (&loop->post);
1640 /* Initially scalarize in order. */
1641 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1644 loop->ss = gfc_ss_terminator;
1648 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1652 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1658 /* Return an expression for the data pointer of an array. */
1661 gfc_conv_array_data (tree descriptor)
1665 type = TREE_TYPE (descriptor);
1666 if (GFC_ARRAY_TYPE_P (type))
1668 if (TREE_CODE (type) == POINTER_TYPE)
1672 /* Descriptorless arrays. */
1673 return gfc_build_addr_expr (NULL, descriptor);
1677 return gfc_conv_descriptor_data_get (descriptor);
1681 /* Return an expression for the base offset of an array. */
1684 gfc_conv_array_offset (tree descriptor)
1688 type = TREE_TYPE (descriptor);
1689 if (GFC_ARRAY_TYPE_P (type))
1690 return GFC_TYPE_ARRAY_OFFSET (type);
1692 return gfc_conv_descriptor_offset (descriptor);
1696 /* Get an expression for the array stride. */
1699 gfc_conv_array_stride (tree descriptor, int dim)
1704 type = TREE_TYPE (descriptor);
1706 /* For descriptorless arrays use the array size. */
1707 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1708 if (tmp != NULL_TREE)
1711 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1716 /* Like gfc_conv_array_stride, but for the lower bound. */
1719 gfc_conv_array_lbound (tree descriptor, int dim)
1724 type = TREE_TYPE (descriptor);
1726 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1727 if (tmp != NULL_TREE)
1730 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1735 /* Like gfc_conv_array_stride, but for the upper bound. */
1738 gfc_conv_array_ubound (tree descriptor, int dim)
1743 type = TREE_TYPE (descriptor);
1745 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1746 if (tmp != NULL_TREE)
1749 /* This should only ever happen when passing an assumed shape array
1750 as an actual parameter. The value will never be used. */
1751 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1752 return gfc_index_zero_node;
1754 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1759 /* Generate code to perform an array index bound check. */
1762 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1768 if (!flag_bounds_check)
1771 index = gfc_evaluate_now (index, &se->pre);
1772 /* Check lower bound. */
1773 tmp = gfc_conv_array_lbound (descriptor, n);
1774 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1775 /* Check upper bound. */
1776 tmp = gfc_conv_array_ubound (descriptor, n);
1777 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1778 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1780 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1786 /* Return the offset for an index. Performs bound checking for elemental
1787 dimensions. Single element references are processed separately. */
1790 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1791 gfc_array_ref * ar, tree stride)
1797 /* Get the index into the array for this dimension. */
1800 gcc_assert (ar->type != AR_ELEMENT);
1801 switch (ar->dimen_type[dim])
1804 gcc_assert (i == -1);
1805 /* Elemental dimension. */
1806 gcc_assert (info->subscript[dim]
1807 && info->subscript[dim]->type == GFC_SS_SCALAR);
1808 /* We've already translated this value outside the loop. */
1809 index = info->subscript[dim]->data.scalar.expr;
1812 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1816 gcc_assert (info && se->loop);
1817 gcc_assert (info->subscript[dim]
1818 && info->subscript[dim]->type == GFC_SS_VECTOR);
1819 desc = info->subscript[dim]->data.info.descriptor;
1821 /* Get a zero-based index into the vector. */
1822 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1823 se->loop->loopvar[i], se->loop->from[i]);
1825 /* Multiply the index by the stride. */
1826 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1827 index, gfc_conv_array_stride (desc, 0));
1829 /* Read the vector to get an index into info->descriptor. */
1830 data = gfc_build_indirect_ref (gfc_conv_array_data (desc));
1831 index = gfc_build_array_ref (data, index);
1832 index = gfc_evaluate_now (index, &se->pre);
1834 /* Do any bounds checking on the final info->descriptor index. */
1835 index = gfc_trans_array_bound_check (se, info->descriptor,
1840 /* Scalarized dimension. */
1841 gcc_assert (info && se->loop);
1843 /* Multiply the loop variable by the stride and delta. */
1844 index = se->loop->loopvar[i];
1845 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1847 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1857 /* Temporary array or derived type component. */
1858 gcc_assert (se->loop);
1859 index = se->loop->loopvar[se->loop->order[i]];
1860 if (!integer_zerop (info->delta[i]))
1861 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1862 index, info->delta[i]);
1865 /* Multiply by the stride. */
1866 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1872 /* Build a scalarized reference to an array. */
1875 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1882 info = &se->ss->data.info;
1884 n = se->loop->order[0];
1888 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1890 /* Add the offset for this dimension to the stored offset for all other
1892 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1894 tmp = gfc_build_indirect_ref (info->data);
1895 se->expr = gfc_build_array_ref (tmp, index);
1899 /* Translate access of temporary array. */
1902 gfc_conv_tmp_array_ref (gfc_se * se)
1904 se->string_length = se->ss->string_length;
1905 gfc_conv_scalarized_array_ref (se, NULL);
1909 /* Build an array reference. se->expr already holds the array descriptor.
1910 This should be either a variable, indirect variable reference or component
1911 reference. For arrays which do not have a descriptor, se->expr will be
1913 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1916 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1925 /* Handle scalarized references separately. */
1926 if (ar->type != AR_ELEMENT)
1928 gfc_conv_scalarized_array_ref (se, ar);
1929 gfc_advance_se_ss_chain (se);
1933 index = gfc_index_zero_node;
1935 fault = gfc_index_zero_node;
1937 /* Calculate the offsets from all the dimensions. */
1938 for (n = 0; n < ar->dimen; n++)
1940 /* Calculate the index for this dimension. */
1941 gfc_init_se (&indexse, se);
1942 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1943 gfc_add_block_to_block (&se->pre, &indexse.pre);
1945 if (flag_bounds_check)
1947 /* Check array bounds. */
1950 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1952 tmp = gfc_conv_array_lbound (se->expr, n);
1953 cond = fold_build2 (LT_EXPR, boolean_type_node,
1956 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1958 tmp = gfc_conv_array_ubound (se->expr, n);
1959 cond = fold_build2 (GT_EXPR, boolean_type_node,
1962 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1965 /* Multiply the index by the stride. */
1966 stride = gfc_conv_array_stride (se->expr, n);
1967 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1970 /* And add it to the total. */
1971 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1974 if (flag_bounds_check)
1975 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1977 tmp = gfc_conv_array_offset (se->expr);
1978 if (!integer_zerop (tmp))
1979 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1981 /* Access the calculated element. */
1982 tmp = gfc_conv_array_data (se->expr);
1983 tmp = gfc_build_indirect_ref (tmp);
1984 se->expr = gfc_build_array_ref (tmp, index);
1988 /* Generate the code to be executed immediately before entering a
1989 scalarization loop. */
1992 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1993 stmtblock_t * pblock)
2002 /* This code will be executed before entering the scalarization loop
2003 for this dimension. */
2004 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2006 if ((ss->useflags & flag) == 0)
2009 if (ss->type != GFC_SS_SECTION
2010 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2011 && ss->type != GFC_SS_COMPONENT)
2014 info = &ss->data.info;
2016 if (dim >= info->dimen)
2019 if (dim == info->dimen - 1)
2021 /* For the outermost loop calculate the offset due to any
2022 elemental dimensions. It will have been initialized with the
2023 base offset of the array. */
2026 for (i = 0; i < info->ref->u.ar.dimen; i++)
2028 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2031 gfc_init_se (&se, NULL);
2033 se.expr = info->descriptor;
2034 stride = gfc_conv_array_stride (info->descriptor, i);
2035 index = gfc_conv_array_index_offset (&se, info, i, -1,
2038 gfc_add_block_to_block (pblock, &se.pre);
2040 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2041 info->offset, index);
2042 info->offset = gfc_evaluate_now (info->offset, pblock);
2046 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2049 stride = gfc_conv_array_stride (info->descriptor, 0);
2051 /* Calculate the stride of the innermost loop. Hopefully this will
2052 allow the backend optimizers to do their stuff more effectively.
2054 info->stride0 = gfc_evaluate_now (stride, pblock);
2058 /* Add the offset for the previous loop dimension. */
2063 ar = &info->ref->u.ar;
2064 i = loop->order[dim + 1];
2072 gfc_init_se (&se, NULL);
2074 se.expr = info->descriptor;
2075 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2076 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2078 gfc_add_block_to_block (pblock, &se.pre);
2079 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2080 info->offset, index);
2081 info->offset = gfc_evaluate_now (info->offset, pblock);
2084 /* Remember this offset for the second loop. */
2085 if (dim == loop->temp_dim - 1)
2086 info->saved_offset = info->offset;
2091 /* Start a scalarized expression. Creates a scope and declares loop
2095 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2101 gcc_assert (!loop->array_parameter);
2103 for (dim = loop->dimen - 1; dim >= 0; dim--)
2105 n = loop->order[dim];
2107 gfc_start_block (&loop->code[n]);
2109 /* Create the loop variable. */
2110 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2112 if (dim < loop->temp_dim)
2116 /* Calculate values that will be constant within this loop. */
2117 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2119 gfc_start_block (pbody);
2123 /* Generates the actual loop code for a scalarization loop. */
2126 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2127 stmtblock_t * pbody)
2135 loopbody = gfc_finish_block (pbody);
2137 /* Initialize the loopvar. */
2138 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2140 exit_label = gfc_build_label_decl (NULL_TREE);
2142 /* Generate the loop body. */
2143 gfc_init_block (&block);
2145 /* The exit condition. */
2146 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2147 tmp = build1_v (GOTO_EXPR, exit_label);
2148 TREE_USED (exit_label) = 1;
2149 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2150 gfc_add_expr_to_block (&block, tmp);
2152 /* The main body. */
2153 gfc_add_expr_to_block (&block, loopbody);
2155 /* Increment the loopvar. */
2156 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2157 loop->loopvar[n], gfc_index_one_node);
2158 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2160 /* Build the loop. */
2161 tmp = gfc_finish_block (&block);
2162 tmp = build1_v (LOOP_EXPR, tmp);
2163 gfc_add_expr_to_block (&loop->code[n], tmp);
2165 /* Add the exit label. */
2166 tmp = build1_v (LABEL_EXPR, exit_label);
2167 gfc_add_expr_to_block (&loop->code[n], tmp);
2171 /* Finishes and generates the loops for a scalarized expression. */
2174 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2179 stmtblock_t *pblock;
2183 /* Generate the loops. */
2184 for (dim = 0; dim < loop->dimen; dim++)
2186 n = loop->order[dim];
2187 gfc_trans_scalarized_loop_end (loop, n, pblock);
2188 loop->loopvar[n] = NULL_TREE;
2189 pblock = &loop->code[n];
2192 tmp = gfc_finish_block (pblock);
2193 gfc_add_expr_to_block (&loop->pre, tmp);
2195 /* Clear all the used flags. */
2196 for (ss = loop->ss; ss; ss = ss->loop_chain)
2201 /* Finish the main body of a scalarized expression, and start the secondary
2205 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2209 stmtblock_t *pblock;
2213 /* We finish as many loops as are used by the temporary. */
2214 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2216 n = loop->order[dim];
2217 gfc_trans_scalarized_loop_end (loop, n, pblock);
2218 loop->loopvar[n] = NULL_TREE;
2219 pblock = &loop->code[n];
2222 /* We don't want to finish the outermost loop entirely. */
2223 n = loop->order[loop->temp_dim - 1];
2224 gfc_trans_scalarized_loop_end (loop, n, pblock);
2226 /* Restore the initial offsets. */
2227 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2229 if ((ss->useflags & 2) == 0)
2232 if (ss->type != GFC_SS_SECTION
2233 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2234 && ss->type != GFC_SS_COMPONENT)
2237 ss->data.info.offset = ss->data.info.saved_offset;
2240 /* Restart all the inner loops we just finished. */
2241 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2243 n = loop->order[dim];
2245 gfc_start_block (&loop->code[n]);
2247 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2249 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2252 /* Start a block for the secondary copying code. */
2253 gfc_start_block (body);
2257 /* Calculate the upper bound of an array section. */
2260 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2269 gcc_assert (ss->type == GFC_SS_SECTION);
2271 info = &ss->data.info;
2274 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2275 /* We'll calculate the upper bound once we have access to the
2276 vector's descriptor. */
2279 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2280 desc = info->descriptor;
2281 end = info->ref->u.ar.end[dim];
2285 /* The upper bound was specified. */
2286 gfc_init_se (&se, NULL);
2287 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2288 gfc_add_block_to_block (pblock, &se.pre);
2293 /* No upper bound was specified, so use the bound of the array. */
2294 bound = gfc_conv_array_ubound (desc, dim);
2301 /* Calculate the lower bound of an array section. */
2304 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2313 gcc_assert (ss->type == GFC_SS_SECTION);
2315 info = &ss->data.info;
2318 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2320 /* We use a zero-based index to access the vector. */
2321 info->start[n] = gfc_index_zero_node;
2322 info->stride[n] = gfc_index_one_node;
2326 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2327 desc = info->descriptor;
2328 start = info->ref->u.ar.start[dim];
2329 stride = info->ref->u.ar.stride[dim];
2331 /* Calculate the start of the range. For vector subscripts this will
2332 be the range of the vector. */
2335 /* Specified section start. */
2336 gfc_init_se (&se, NULL);
2337 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2338 gfc_add_block_to_block (&loop->pre, &se.pre);
2339 info->start[n] = se.expr;
2343 /* No lower bound specified so use the bound of the array. */
2344 info->start[n] = gfc_conv_array_lbound (desc, dim);
2346 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2348 /* Calculate the stride. */
2350 info->stride[n] = gfc_index_one_node;
2353 gfc_init_se (&se, NULL);
2354 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2355 gfc_add_block_to_block (&loop->pre, &se.pre);
2356 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2361 /* Calculates the range start and stride for a SS chain. Also gets the
2362 descriptor and data pointer. The range of vector subscripts is the size
2363 of the vector. Array bounds are also checked. */
2366 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2374 /* Determine the rank of the loop. */
2376 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2380 case GFC_SS_SECTION:
2381 case GFC_SS_CONSTRUCTOR:
2382 case GFC_SS_FUNCTION:
2383 case GFC_SS_COMPONENT:
2384 loop->dimen = ss->data.info.dimen;
2392 if (loop->dimen == 0)
2393 gfc_todo_error ("Unable to determine rank of expression");
2396 /* Loop over all the SS in the chain. */
2397 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2399 if (ss->expr && ss->expr->shape && !ss->shape)
2400 ss->shape = ss->expr->shape;
2404 case GFC_SS_SECTION:
2405 /* Get the descriptor for the array. */
2406 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2408 for (n = 0; n < ss->data.info.dimen; n++)
2409 gfc_conv_section_startstride (loop, ss, n);
2412 case GFC_SS_CONSTRUCTOR:
2413 case GFC_SS_FUNCTION:
2414 for (n = 0; n < ss->data.info.dimen; n++)
2416 ss->data.info.start[n] = gfc_index_zero_node;
2417 ss->data.info.stride[n] = gfc_index_one_node;
2426 /* The rest is just runtime bound checking. */
2427 if (flag_bounds_check)
2433 tree size[GFC_MAX_DIMENSIONS];
2437 gfc_start_block (&block);
2439 fault = integer_zero_node;
2440 for (n = 0; n < loop->dimen; n++)
2441 size[n] = NULL_TREE;
2443 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2445 if (ss->type != GFC_SS_SECTION)
2448 /* TODO: range checking for mapped dimensions. */
2449 info = &ss->data.info;
2451 /* This code only checks ranges. Elemental and vector
2452 dimensions are checked later. */
2453 for (n = 0; n < loop->dimen; n++)
2456 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2459 desc = ss->data.info.descriptor;
2461 /* Check lower bound. */
2462 bound = gfc_conv_array_lbound (desc, dim);
2463 tmp = info->start[n];
2464 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2465 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2468 /* Check the upper bound. */
2469 bound = gfc_conv_array_ubound (desc, dim);
2470 end = gfc_conv_section_upper_bound (ss, n, &block);
2471 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2472 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2475 /* Check the section sizes match. */
2476 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2478 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2480 /* We remember the size of the first section, and check all the
2481 others against this. */
2485 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2487 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2490 size[n] = gfc_evaluate_now (tmp, &block);
2493 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2495 tmp = gfc_finish_block (&block);
2496 gfc_add_expr_to_block (&loop->pre, tmp);
2501 /* Return true if the two SS could be aliased, i.e. both point to the same data
2503 /* TODO: resolve aliases based on frontend expressions. */
2506 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2513 lsym = lss->expr->symtree->n.sym;
2514 rsym = rss->expr->symtree->n.sym;
2515 if (gfc_symbols_could_alias (lsym, rsym))
2518 if (rsym->ts.type != BT_DERIVED
2519 && lsym->ts.type != BT_DERIVED)
2522 /* For derived types we must check all the component types. We can ignore
2523 array references as these will have the same base type as the previous
2525 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2527 if (lref->type != REF_COMPONENT)
2530 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2533 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2536 if (rref->type != REF_COMPONENT)
2539 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2544 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2546 if (rref->type != REF_COMPONENT)
2549 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2557 /* Resolve array data dependencies. Creates a temporary if required. */
2558 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2562 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2572 loop->temp_ss = NULL;
2573 aref = dest->data.info.ref;
2576 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2578 if (ss->type != GFC_SS_SECTION)
2581 if (gfc_could_be_alias (dest, ss))
2587 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2589 lref = dest->expr->ref;
2590 rref = ss->expr->ref;
2592 nDepend = gfc_dep_resolver (lref, rref);
2594 /* TODO : loop shifting. */
2597 /* Mark the dimensions for LOOP SHIFTING */
2598 for (n = 0; n < loop->dimen; n++)
2600 int dim = dest->data.info.dim[n];
2602 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2604 else if (! gfc_is_same_range (&lref->u.ar,
2605 &rref->u.ar, dim, 0))
2609 /* Put all the dimensions with dependencies in the
2612 for (n = 0; n < loop->dimen; n++)
2614 gcc_assert (loop->order[n] == n);
2616 loop->order[dim++] = n;
2619 for (n = 0; n < loop->dimen; n++)
2622 loop->order[dim++] = n;
2625 gcc_assert (dim == loop->dimen);
2634 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2635 if (GFC_ARRAY_TYPE_P (base_type)
2636 || GFC_DESCRIPTOR_TYPE_P (base_type))
2637 base_type = gfc_get_element_type (base_type);
2638 loop->temp_ss = gfc_get_ss ();
2639 loop->temp_ss->type = GFC_SS_TEMP;
2640 loop->temp_ss->data.temp.type = base_type;
2641 loop->temp_ss->string_length = dest->string_length;
2642 loop->temp_ss->data.temp.dimen = loop->dimen;
2643 loop->temp_ss->next = gfc_ss_terminator;
2644 gfc_add_ss_to_loop (loop, loop->temp_ss);
2647 loop->temp_ss = NULL;
2651 /* Initialize the scalarization loop. Creates the loop variables. Determines
2652 the range of the loop variables. Creates a temporary if required.
2653 Calculates how to transform from loop variables to array indices for each
2654 expression. Also generates code for scalar expressions which have been
2655 moved outside the loop. */
2658 gfc_conv_loop_setup (gfc_loopinfo * loop)
2663 gfc_ss_info *specinfo;
2667 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2668 bool dynamic[GFC_MAX_DIMENSIONS];
2674 for (n = 0; n < loop->dimen; n++)
2678 /* We use one SS term, and use that to determine the bounds of the
2679 loop for this dimension. We try to pick the simplest term. */
2680 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2684 /* The frontend has worked out the size for us. */
2689 if (ss->type == GFC_SS_CONSTRUCTOR)
2691 /* An unknown size constructor will always be rank one.
2692 Higher rank constructors will either have known shape,
2693 or still be wrapped in a call to reshape. */
2694 gcc_assert (loop->dimen == 1);
2696 /* Always prefer to use the constructor bounds if the size
2697 can be determined at compile time. Prefer not to otherwise,
2698 since the general case involves realloc, and it's better to
2699 avoid that overhead if possible. */
2700 c = ss->expr->value.constructor;
2701 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2702 if (!dynamic[n] || !loopspec[n])
2707 /* TODO: Pick the best bound if we have a choice between a
2708 function and something else. */
2709 if (ss->type == GFC_SS_FUNCTION)
2715 if (ss->type != GFC_SS_SECTION)
2719 specinfo = &loopspec[n]->data.info;
2722 info = &ss->data.info;
2726 /* Criteria for choosing a loop specifier (most important first):
2727 doesn't need realloc
2733 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2735 else if (integer_onep (info->stride[n])
2736 && !integer_onep (specinfo->stride[n]))
2738 else if (INTEGER_CST_P (info->stride[n])
2739 && !INTEGER_CST_P (specinfo->stride[n]))
2741 else if (INTEGER_CST_P (info->start[n])
2742 && !INTEGER_CST_P (specinfo->start[n]))
2744 /* We don't work out the upper bound.
2745 else if (INTEGER_CST_P (info->finish[n])
2746 && ! INTEGER_CST_P (specinfo->finish[n]))
2747 loopspec[n] = ss; */
2751 gfc_todo_error ("Unable to find scalarization loop specifier");
2753 info = &loopspec[n]->data.info;
2755 /* Set the extents of this range. */
2756 cshape = loopspec[n]->shape;
2757 if (cshape && INTEGER_CST_P (info->start[n])
2758 && INTEGER_CST_P (info->stride[n]))
2760 loop->from[n] = info->start[n];
2761 mpz_set (i, cshape[n]);
2762 mpz_sub_ui (i, i, 1);
2763 /* To = from + (size - 1) * stride. */
2764 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2765 if (!integer_onep (info->stride[n]))
2766 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2767 tmp, info->stride[n]);
2768 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2769 loop->from[n], tmp);
2773 loop->from[n] = info->start[n];
2774 switch (loopspec[n]->type)
2776 case GFC_SS_CONSTRUCTOR:
2777 /* The upper bound is calculated when we expand the
2779 gcc_assert (loop->to[n] == NULL_TREE);
2782 case GFC_SS_SECTION:
2783 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2787 case GFC_SS_FUNCTION:
2788 /* The loop bound will be set when we generate the call. */
2789 gcc_assert (loop->to[n] == NULL_TREE);
2797 /* Transform everything so we have a simple incrementing variable. */
2798 if (integer_onep (info->stride[n]))
2799 info->delta[n] = gfc_index_zero_node;
2802 /* Set the delta for this section. */
2803 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2804 /* Number of iterations is (end - start + step) / step.
2805 with start = 0, this simplifies to
2807 for (i = 0; i<=last; i++){...}; */
2808 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2809 loop->to[n], loop->from[n]);
2810 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2811 tmp, info->stride[n]);
2812 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2813 /* Make the loop variable start at 0. */
2814 loop->from[n] = gfc_index_zero_node;
2818 /* Add all the scalar code that can be taken out of the loops.
2819 This may include calculating the loop bounds, so do it before
2820 allocating the temporary. */
2821 gfc_add_loop_ss_code (loop, loop->ss, false);
2823 /* If we want a temporary then create it. */
2824 if (loop->temp_ss != NULL)
2826 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2827 tmp = loop->temp_ss->data.temp.type;
2828 len = loop->temp_ss->string_length;
2829 n = loop->temp_ss->data.temp.dimen;
2830 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2831 loop->temp_ss->type = GFC_SS_SECTION;
2832 loop->temp_ss->data.info.dimen = n;
2833 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
2834 &loop->temp_ss->data.info, tmp, false);
2837 for (n = 0; n < loop->temp_dim; n++)
2838 loopspec[loop->order[n]] = NULL;
2842 /* For array parameters we don't have loop variables, so don't calculate the
2844 if (loop->array_parameter)
2847 /* Calculate the translation from loop variables to array indices. */
2848 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2850 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2853 info = &ss->data.info;
2855 for (n = 0; n < info->dimen; n++)
2859 /* If we are specifying the range the delta is already set. */
2860 if (loopspec[n] != ss)
2862 /* Calculate the offset relative to the loop variable.
2863 First multiply by the stride. */
2864 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2865 loop->from[n], info->stride[n]);
2867 /* Then subtract this from our starting value. */
2868 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2869 info->start[n], tmp);
2871 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2878 /* Fills in an array descriptor, and returns the size of the array. The size
2879 will be a simple_val, ie a variable or a constant. Also calculates the
2880 offset of the base. Returns the size of the array.
2884 for (n = 0; n < rank; n++)
2886 a.lbound[n] = specified_lower_bound;
2887 offset = offset + a.lbond[n] * stride;
2889 a.ubound[n] = specified_upper_bound;
2890 a.stride[n] = stride;
2891 size = ubound + size; //size = ubound + 1 - lbound
2892 stride = stride * size;
2899 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2900 gfc_expr ** lower, gfc_expr ** upper,
2901 stmtblock_t * pblock)
2912 type = TREE_TYPE (descriptor);
2914 stride = gfc_index_one_node;
2915 offset = gfc_index_zero_node;
2917 /* Set the dtype. */
2918 tmp = gfc_conv_descriptor_dtype (descriptor);
2919 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2921 for (n = 0; n < rank; n++)
2923 /* We have 3 possibilities for determining the size of the array:
2924 lower == NULL => lbound = 1, ubound = upper[n]
2925 upper[n] = NULL => lbound = 1, ubound = lower[n]
2926 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2929 /* Set lower bound. */
2930 gfc_init_se (&se, NULL);
2932 se.expr = gfc_index_one_node;
2935 gcc_assert (lower[n]);
2938 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2939 gfc_add_block_to_block (pblock, &se.pre);
2943 se.expr = gfc_index_one_node;
2947 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2948 gfc_add_modify_expr (pblock, tmp, se.expr);
2950 /* Work out the offset for this component. */
2951 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2952 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2954 /* Start the calculation for the size of this dimension. */
2955 size = build2 (MINUS_EXPR, gfc_array_index_type,
2956 gfc_index_one_node, se.expr);
2958 /* Set upper bound. */
2959 gfc_init_se (&se, NULL);
2960 gcc_assert (ubound);
2961 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2962 gfc_add_block_to_block (pblock, &se.pre);
2964 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2965 gfc_add_modify_expr (pblock, tmp, se.expr);
2967 /* Store the stride. */
2968 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2969 gfc_add_modify_expr (pblock, tmp, stride);
2971 /* Calculate the size of this dimension. */
2972 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2974 /* Multiply the stride by the number of elements in this dimension. */
2975 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2976 stride = gfc_evaluate_now (stride, pblock);
2979 /* The stride is the number of elements in the array, so multiply by the
2980 size of an element to get the total size. */
2981 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2982 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2984 if (poffset != NULL)
2986 offset = gfc_evaluate_now (offset, pblock);
2990 size = gfc_evaluate_now (size, pblock);
2995 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2996 the work for an ALLOCATE statement. */
3000 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
3010 /* Figure out the size of the array. */
3011 switch (ref->u.ar.type)
3015 upper = ref->u.ar.start;
3019 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3021 lower = ref->u.ar.as->lower;
3022 upper = ref->u.ar.as->upper;
3026 lower = ref->u.ar.start;
3027 upper = ref->u.ar.end;
3035 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3036 lower, upper, &se->pre);
3038 /* Allocate memory to store the data. */
3039 tmp = gfc_conv_descriptor_data_addr (se->expr);
3040 pointer = gfc_evaluate_now (tmp, &se->pre);
3042 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3043 allocate = gfor_fndecl_allocate;
3044 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3045 allocate = gfor_fndecl_allocate64;
3049 tmp = gfc_chainon_list (NULL_TREE, pointer);
3050 tmp = gfc_chainon_list (tmp, size);
3051 tmp = gfc_chainon_list (tmp, pstat);
3052 tmp = gfc_build_function_call (allocate, tmp);
3053 gfc_add_expr_to_block (&se->pre, tmp);
3055 tmp = gfc_conv_descriptor_offset (se->expr);
3056 gfc_add_modify_expr (&se->pre, tmp, offset);
3060 /* Deallocate an array variable. Also used when an allocated variable goes
3065 gfc_array_deallocate (tree descriptor, tree pstat)
3071 gfc_start_block (&block);
3072 /* Get a pointer to the data. */
3073 tmp = gfc_conv_descriptor_data_addr (descriptor);
3074 var = gfc_evaluate_now (tmp, &block);
3076 /* Parameter is the address of the data component. */
3077 tmp = gfc_chainon_list (NULL_TREE, var);
3078 tmp = gfc_chainon_list (tmp, pstat);
3079 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3080 gfc_add_expr_to_block (&block, tmp);
3082 return gfc_finish_block (&block);
3086 /* Create an array constructor from an initialization expression.
3087 We assume the frontend already did any expansions and conversions. */
3090 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3097 unsigned HOST_WIDE_INT lo;
3099 VEC(constructor_elt,gc) *v = NULL;
3101 switch (expr->expr_type)
3104 case EXPR_STRUCTURE:
3105 /* A single scalar or derived type value. Create an array with all
3106 elements equal to that value. */
3107 gfc_init_se (&se, NULL);
3109 if (expr->expr_type == EXPR_CONSTANT)
3110 gfc_conv_constant (&se, expr);
3112 gfc_conv_structure (&se, expr, 1);
3114 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3115 gcc_assert (tmp && INTEGER_CST_P (tmp));
3116 hi = TREE_INT_CST_HIGH (tmp);
3117 lo = TREE_INT_CST_LOW (tmp);
3121 /* This will probably eat buckets of memory for large arrays. */
3122 while (hi != 0 || lo != 0)
3124 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3132 /* Create a vector of all the elements. */
3133 for (c = expr->value.constructor; c; c = c->next)
3137 /* Problems occur when we get something like
3138 integer :: a(lots) = (/(i, i=1,lots)/) */
3139 /* TODO: Unexpanded array initializers. */
3141 ("Possible frontend bug: array constructor not expanded");
3143 if (mpz_cmp_si (c->n.offset, 0) != 0)
3144 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3148 if (mpz_cmp_si (c->repeat, 0) != 0)
3152 mpz_set (maxval, c->repeat);
3153 mpz_add (maxval, c->n.offset, maxval);
3154 mpz_sub_ui (maxval, maxval, 1);
3155 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3156 if (mpz_cmp_si (c->n.offset, 0) != 0)
3158 mpz_add_ui (maxval, c->n.offset, 1);
3159 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3162 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3164 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3170 gfc_init_se (&se, NULL);
3171 switch (c->expr->expr_type)
3174 gfc_conv_constant (&se, c->expr);
3175 if (range == NULL_TREE)
3176 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3179 if (index != NULL_TREE)
3180 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3181 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3185 case EXPR_STRUCTURE:
3186 gfc_conv_structure (&se, c->expr, 1);
3187 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3200 /* Create a constructor from the list of elements. */
3201 tmp = build_constructor (type, v);
3202 TREE_CONSTANT (tmp) = 1;
3203 TREE_INVARIANT (tmp) = 1;
3208 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3209 returns the size (in elements) of the array. */
3212 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3213 stmtblock_t * pblock)
3228 size = gfc_index_one_node;
3229 offset = gfc_index_zero_node;
3230 for (dim = 0; dim < as->rank; dim++)
3232 /* Evaluate non-constant array bound expressions. */
3233 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3234 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3236 gfc_init_se (&se, NULL);
3237 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3238 gfc_add_block_to_block (pblock, &se.pre);
3239 gfc_add_modify_expr (pblock, lbound, se.expr);
3241 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3242 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3244 gfc_init_se (&se, NULL);
3245 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3246 gfc_add_block_to_block (pblock, &se.pre);
3247 gfc_add_modify_expr (pblock, ubound, se.expr);
3249 /* The offset of this dimension. offset = offset - lbound * stride. */
3250 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3251 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3253 /* The size of this dimension, and the stride of the next. */
3254 if (dim + 1 < as->rank)
3255 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3259 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3261 /* Calculate stride = size * (ubound + 1 - lbound). */
3262 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3263 gfc_index_one_node, lbound);
3264 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3265 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3267 gfc_add_modify_expr (pblock, stride, tmp);
3269 stride = gfc_evaluate_now (tmp, pblock);
3280 /* Generate code to initialize/allocate an array variable. */
3283 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3293 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3295 /* Do nothing for USEd variables. */
3296 if (sym->attr.use_assoc)
3299 type = TREE_TYPE (decl);
3300 gcc_assert (GFC_ARRAY_TYPE_P (type));
3301 onstack = TREE_CODE (type) != POINTER_TYPE;
3303 gfc_start_block (&block);
3305 /* Evaluate character string length. */
3306 if (sym->ts.type == BT_CHARACTER
3307 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3309 gfc_trans_init_string_length (sym->ts.cl, &block);
3311 /* Emit a DECL_EXPR for this variable, which will cause the
3312 gimplifier to allocate storage, and all that good stuff. */
3313 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3314 gfc_add_expr_to_block (&block, tmp);
3319 gfc_add_expr_to_block (&block, fnbody);
3320 return gfc_finish_block (&block);
3323 type = TREE_TYPE (type);
3325 gcc_assert (!sym->attr.use_assoc);
3326 gcc_assert (!TREE_STATIC (decl));
3327 gcc_assert (!sym->module);
3329 if (sym->ts.type == BT_CHARACTER
3330 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3331 gfc_trans_init_string_length (sym->ts.cl, &block);
3333 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3335 /* Don't actually allocate space for Cray Pointees. */
3336 if (sym->attr.cray_pointee)
3338 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3339 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3340 gfc_add_expr_to_block (&block, fnbody);
3341 return gfc_finish_block (&block);
3344 /* The size is the number of elements in the array, so multiply by the
3345 size of an element to get the total size. */
3346 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3347 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3349 /* Allocate memory to hold the data. */
3350 tmp = gfc_chainon_list (NULL_TREE, size);
3352 if (gfc_index_integer_kind == 4)
3353 fndecl = gfor_fndecl_internal_malloc;
3354 else if (gfc_index_integer_kind == 8)
3355 fndecl = gfor_fndecl_internal_malloc64;
3358 tmp = gfc_build_function_call (fndecl, tmp);
3359 tmp = fold (convert (TREE_TYPE (decl), tmp));
3360 gfc_add_modify_expr (&block, decl, tmp);
3362 /* Set offset of the array. */
3363 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3364 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3367 /* Automatic arrays should not have initializers. */
3368 gcc_assert (!sym->value);
3370 gfc_add_expr_to_block (&block, fnbody);
3372 /* Free the temporary. */
3373 tmp = convert (pvoid_type_node, decl);
3374 tmp = gfc_chainon_list (NULL_TREE, tmp);
3375 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3376 gfc_add_expr_to_block (&block, tmp);
3378 return gfc_finish_block (&block);
3382 /* Generate entry and exit code for g77 calling convention arrays. */
3385 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3394 gfc_get_backend_locus (&loc);
3395 gfc_set_backend_locus (&sym->declared_at);
3397 /* Descriptor type. */
3398 parm = sym->backend_decl;
3399 type = TREE_TYPE (parm);
3400 gcc_assert (GFC_ARRAY_TYPE_P (type));
3402 gfc_start_block (&block);
3404 if (sym->ts.type == BT_CHARACTER
3405 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3406 gfc_trans_init_string_length (sym->ts.cl, &block);
3408 /* Evaluate the bounds of the array. */
3409 gfc_trans_array_bounds (type, sym, &offset, &block);
3411 /* Set the offset. */
3412 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3413 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3415 /* Set the pointer itself if we aren't using the parameter directly. */
3416 if (TREE_CODE (parm) != PARM_DECL)
3418 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3419 gfc_add_modify_expr (&block, parm, tmp);
3421 tmp = gfc_finish_block (&block);
3423 gfc_set_backend_locus (&loc);
3425 gfc_start_block (&block);
3426 /* Add the initialization code to the start of the function. */
3427 gfc_add_expr_to_block (&block, tmp);
3428 gfc_add_expr_to_block (&block, body);
3430 return gfc_finish_block (&block);
3434 /* Modify the descriptor of an array parameter so that it has the
3435 correct lower bound. Also move the upper bound accordingly.
3436 If the array is not packed, it will be copied into a temporary.
3437 For each dimension we set the new lower and upper bounds. Then we copy the
3438 stride and calculate the offset for this dimension. We also work out
3439 what the stride of a packed array would be, and see it the two match.
3440 If the array need repacking, we set the stride to the values we just
3441 calculated, recalculate the offset and copy the array data.
3442 Code is also added to copy the data back at the end of the function.
3446 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3453 stmtblock_t cleanup;
3471 /* Do nothing for pointer and allocatable arrays. */
3472 if (sym->attr.pointer || sym->attr.allocatable)
3475 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3476 return gfc_trans_g77_array (sym, body);
3478 gfc_get_backend_locus (&loc);
3479 gfc_set_backend_locus (&sym->declared_at);
3481 /* Descriptor type. */
3482 type = TREE_TYPE (tmpdesc);
3483 gcc_assert (GFC_ARRAY_TYPE_P (type));
3484 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3485 dumdesc = gfc_build_indirect_ref (dumdesc);
3486 gfc_start_block (&block);
3488 if (sym->ts.type == BT_CHARACTER
3489 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3490 gfc_trans_init_string_length (sym->ts.cl, &block);
3492 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3494 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3495 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3497 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3499 /* For non-constant shape arrays we only check if the first dimension
3500 is contiguous. Repacking higher dimensions wouldn't gain us
3501 anything as we still don't know the array stride. */
3502 partial = gfc_create_var (boolean_type_node, "partial");
3503 TREE_USED (partial) = 1;
3504 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3505 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3506 gfc_add_modify_expr (&block, partial, tmp);
3510 partial = NULL_TREE;
3513 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3514 here, however I think it does the right thing. */
3517 /* Set the first stride. */
3518 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3519 stride = gfc_evaluate_now (stride, &block);
3521 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3522 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3523 gfc_index_one_node, stride);
3524 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3525 gfc_add_modify_expr (&block, stride, tmp);
3527 /* Allow the user to disable array repacking. */
3528 stmt_unpacked = NULL_TREE;
3532 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3533 /* A library call to repack the array if necessary. */
3534 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3535 tmp = gfc_chainon_list (NULL_TREE, tmp);
3536 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3538 stride = gfc_index_one_node;
3541 /* This is for the case where the array data is used directly without
3542 calling the repack function. */
3543 if (no_repack || partial != NULL_TREE)
3544 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3546 stmt_packed = NULL_TREE;
3548 /* Assign the data pointer. */
3549 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3551 /* Don't repack unknown shape arrays when the first stride is 1. */
3552 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3553 stmt_packed, stmt_unpacked);
3556 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3557 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3559 offset = gfc_index_zero_node;
3560 size = gfc_index_one_node;
3562 /* Evaluate the bounds of the array. */
3563 for (n = 0; n < sym->as->rank; n++)
3565 if (checkparm || !sym->as->upper[n])
3567 /* Get the bounds of the actual parameter. */
3568 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3569 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3573 dubound = NULL_TREE;
3574 dlbound = NULL_TREE;
3577 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3578 if (!INTEGER_CST_P (lbound))
3580 gfc_init_se (&se, NULL);
3581 gfc_conv_expr_type (&se, sym->as->lower[n],
3582 gfc_array_index_type);
3583 gfc_add_block_to_block (&block, &se.pre);
3584 gfc_add_modify_expr (&block, lbound, se.expr);
3587 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3588 /* Set the desired upper bound. */
3589 if (sym->as->upper[n])
3591 /* We know what we want the upper bound to be. */
3592 if (!INTEGER_CST_P (ubound))
3594 gfc_init_se (&se, NULL);
3595 gfc_conv_expr_type (&se, sym->as->upper[n],
3596 gfc_array_index_type);
3597 gfc_add_block_to_block (&block, &se.pre);
3598 gfc_add_modify_expr (&block, ubound, se.expr);
3601 /* Check the sizes match. */
3604 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3606 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3608 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3610 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3611 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3616 /* For assumed shape arrays move the upper bound by the same amount
3617 as the lower bound. */
3618 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3619 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3620 gfc_add_modify_expr (&block, ubound, tmp);
3622 /* The offset of this dimension. offset = offset - lbound * stride. */
3623 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3624 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3626 /* The size of this dimension, and the stride of the next. */
3627 if (n + 1 < sym->as->rank)
3629 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3631 if (no_repack || partial != NULL_TREE)
3634 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3637 /* Figure out the stride if not a known constant. */
3638 if (!INTEGER_CST_P (stride))
3641 stmt_packed = NULL_TREE;
3644 /* Calculate stride = size * (ubound + 1 - lbound). */
3645 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3646 gfc_index_one_node, lbound);
3647 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3649 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3654 /* Assign the stride. */
3655 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3656 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3657 stmt_unpacked, stmt_packed);
3659 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3660 gfc_add_modify_expr (&block, stride, tmp);
3665 /* Set the offset. */
3666 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3667 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3669 stmt = gfc_finish_block (&block);
3671 gfc_start_block (&block);
3673 /* Only do the entry/initialization code if the arg is present. */
3674 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3675 optional_arg = (sym->attr.optional
3676 || (sym->ns->proc_name->attr.entry_master
3677 && sym->attr.dummy));
3680 tmp = gfc_conv_expr_present (sym);
3681 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3683 gfc_add_expr_to_block (&block, stmt);
3685 /* Add the main function body. */
3686 gfc_add_expr_to_block (&block, body);
3691 gfc_start_block (&cleanup);
3693 if (sym->attr.intent != INTENT_IN)
3695 /* Copy the data back. */
3696 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3697 tmp = gfc_chainon_list (tmp, tmpdesc);
3698 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3699 gfc_add_expr_to_block (&cleanup, tmp);
3702 /* Free the temporary. */
3703 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3704 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3705 gfc_add_expr_to_block (&cleanup, tmp);
3707 stmt = gfc_finish_block (&cleanup);
3709 /* Only do the cleanup if the array was repacked. */
3710 tmp = gfc_build_indirect_ref (dumdesc);
3711 tmp = gfc_conv_descriptor_data_get (tmp);
3712 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3713 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3717 tmp = gfc_conv_expr_present (sym);
3718 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3720 gfc_add_expr_to_block (&block, stmt);
3722 /* We don't need to free any memory allocated by internal_pack as it will
3723 be freed at the end of the function by pop_context. */
3724 return gfc_finish_block (&block);
3728 /* Convert an array for passing as an actual argument. Expressions and
3729 vector subscripts are evaluated and stored in a temporary, which is then
3730 passed. For whole arrays the descriptor is passed. For array sections
3731 a modified copy of the descriptor is passed, but using the original data.
3733 This function is also used for array pointer assignments, and there
3736 - want_pointer && !se->direct_byref
3737 EXPR is an actual argument. On exit, se->expr contains a
3738 pointer to the array descriptor.
3740 - !want_pointer && !se->direct_byref
3741 EXPR is an actual argument to an intrinsic function or the
3742 left-hand side of a pointer assignment. On exit, se->expr
3743 contains the descriptor for EXPR.
3745 - !want_pointer && se->direct_byref
3746 EXPR is the right-hand side of a pointer assignment and
3747 se->expr is the descriptor for the previously-evaluated
3748 left-hand side. The function creates an assignment from
3749 EXPR to se->expr. */
3752 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3767 gcc_assert (ss != gfc_ss_terminator);
3769 /* TODO: Pass constant array constructors without a temporary. */
3770 /* Special case things we know we can pass easily. */
3771 switch (expr->expr_type)
3774 /* If we have a linear array section, we can pass it directly.
3775 Otherwise we need to copy it into a temporary. */
3777 /* Find the SS for the array section. */
3779 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3780 secss = secss->next;
3782 gcc_assert (secss != gfc_ss_terminator);
3783 info = &secss->data.info;
3785 /* Get the descriptor for the array. */
3786 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3787 desc = info->descriptor;
3789 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
3792 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3794 /* Create a new descriptor if the array doesn't have one. */
3797 else if (info->ref->u.ar.type == AR_FULL)
3799 else if (se->direct_byref)
3804 gcc_assert (ref->u.ar.type == AR_SECTION);
3807 for (n = 0; n < ref->u.ar.dimen; n++)
3809 /* Detect passing the full array as a section. This could do
3810 even more checking, but it doesn't seem worth it. */
3811 if (ref->u.ar.start[n]
3813 || (ref->u.ar.stride[n]
3814 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3824 if (se->direct_byref)
3826 /* Copy the descriptor for pointer assignments. */
3827 gfc_add_modify_expr (&se->pre, se->expr, desc);
3829 else if (se->want_pointer)
3831 /* We pass full arrays directly. This means that pointers and
3832 allocatable arrays should also work. */
3833 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3840 if (expr->ts.type == BT_CHARACTER)
3841 se->string_length = gfc_get_expr_charlen (expr);
3848 /* A transformational function return value will be a temporary
3849 array descriptor. We still need to go through the scalarizer
3850 to create the descriptor. Elemental functions ar handled as
3851 arbitrary expressions, i.e. copy to a temporary. */
3853 /* Look for the SS for this function. */
3854 while (secss != gfc_ss_terminator
3855 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3856 secss = secss->next;
3858 if (se->direct_byref)
3860 gcc_assert (secss != gfc_ss_terminator);
3862 /* For pointer assignments pass the descriptor directly. */
3864 se->expr = gfc_build_addr_expr (NULL, se->expr);
3865 gfc_conv_expr (se, expr);
3869 if (secss == gfc_ss_terminator)
3871 /* Elemental function. */
3877 /* Transformational function. */
3878 info = &secss->data.info;
3884 /* Something complicated. Copy it into a temporary. */
3892 gfc_init_loopinfo (&loop);
3894 /* Associate the SS with the loop. */
3895 gfc_add_ss_to_loop (&loop, ss);
3897 /* Tell the scalarizer not to bother creating loop variables, etc. */
3899 loop.array_parameter = 1;
3901 /* The right-hand side of a pointer assignment mustn't use a temporary. */
3902 gcc_assert (!se->direct_byref);
3904 /* Setup the scalarizing loops and bounds. */
3905 gfc_conv_ss_startstride (&loop);
3909 /* Tell the scalarizer to make a temporary. */
3910 loop.temp_ss = gfc_get_ss ();
3911 loop.temp_ss->type = GFC_SS_TEMP;
3912 loop.temp_ss->next = gfc_ss_terminator;
3913 if (expr->ts.type == BT_CHARACTER)
3915 gcc_assert (expr->ts.cl && expr->ts.cl->length
3916 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3917 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3918 (expr->ts.cl->length->value.integer,
3919 expr->ts.cl->length->ts.kind);
3920 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3922 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3924 /* ... which can hold our string, if present. */
3925 if (expr->ts.type == BT_CHARACTER)
3927 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3928 se->string_length = loop.temp_ss->string_length;
3931 loop.temp_ss->string_length = NULL;
3932 loop.temp_ss->data.temp.dimen = loop.dimen;
3933 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3936 gfc_conv_loop_setup (&loop);
3940 /* Copy into a temporary and pass that. We don't need to copy the data
3941 back because expressions and vector subscripts must be INTENT_IN. */
3942 /* TODO: Optimize passing function return values. */
3946 /* Start the copying loops. */
3947 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3948 gfc_mark_ss_chain_used (ss, 1);
3949 gfc_start_scalarized_body (&loop, &block);
3951 /* Copy each data element. */
3952 gfc_init_se (&lse, NULL);
3953 gfc_copy_loopinfo_to_se (&lse, &loop);
3954 gfc_init_se (&rse, NULL);
3955 gfc_copy_loopinfo_to_se (&rse, &loop);
3957 lse.ss = loop.temp_ss;
3960 gfc_conv_scalarized_array_ref (&lse, NULL);
3961 if (expr->ts.type == BT_CHARACTER)
3963 gfc_conv_expr (&rse, expr);
3964 rse.expr = gfc_build_indirect_ref (rse.expr);
3967 gfc_conv_expr_val (&rse, expr);
3969 gfc_add_block_to_block (&block, &rse.pre);
3970 gfc_add_block_to_block (&block, &lse.pre);
3972 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3974 /* Finish the copying loops. */
3975 gfc_trans_scalarizing_loops (&loop, &block);
3977 /* Set the first stride component to zero to indicate a temporary. */
3978 desc = loop.temp_ss->data.info.descriptor;
3979 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3980 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3982 gcc_assert (is_gimple_lvalue (desc));
3984 else if (expr->expr_type == EXPR_FUNCTION)
3986 desc = info->descriptor;
3987 se->string_length = ss->string_length;
3991 /* We pass sections without copying to a temporary. Make a new
3992 descriptor and point it at the section we want. The loop variable
3993 limits will be the limits of the section.
3994 A function may decide to repack the array to speed up access, but
3995 we're not bothered about that here. */
4004 /* Set the string_length for a character array. */
4005 if (expr->ts.type == BT_CHARACTER)
4006 se->string_length = gfc_get_expr_charlen (expr);
4008 desc = info->descriptor;
4009 gcc_assert (secss && secss != gfc_ss_terminator);
4010 if (se->direct_byref)
4012 /* For pointer assignments we fill in the destination. */
4014 parmtype = TREE_TYPE (parm);
4018 /* Otherwise make a new one. */
4019 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4020 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4021 loop.from, loop.to, 0);
4022 parm = gfc_create_var (parmtype, "parm");
4025 offset = gfc_index_zero_node;
4028 /* The following can be somewhat confusing. We have two
4029 descriptors, a new one and the original array.
4030 {parm, parmtype, dim} refer to the new one.
4031 {desc, type, n, secss, loop} refer to the original, which maybe
4032 a descriptorless array.
4033 The bounds of the scalarization are the bounds of the section.
4034 We don't have to worry about numeric overflows when calculating
4035 the offsets because all elements are within the array data. */
4037 /* Set the dtype. */
4038 tmp = gfc_conv_descriptor_dtype (parm);
4039 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4041 if (se->direct_byref)
4042 base = gfc_index_zero_node;
4046 for (n = 0; n < info->ref->u.ar.dimen; n++)
4048 stride = gfc_conv_array_stride (desc, n);
4050 /* Work out the offset. */
4051 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4053 gcc_assert (info->subscript[n]
4054 && info->subscript[n]->type == GFC_SS_SCALAR);
4055 start = info->subscript[n]->data.scalar.expr;
4059 /* Check we haven't somehow got out of sync. */
4060 gcc_assert (info->dim[dim] == n);
4062 /* Evaluate and remember the start of the section. */
4063 start = info->start[dim];
4064 stride = gfc_evaluate_now (stride, &loop.pre);
4067 tmp = gfc_conv_array_lbound (desc, n);
4068 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4070 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4071 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4073 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4075 /* For elemental dimensions, we only need the offset. */
4079 /* Vector subscripts need copying and are handled elsewhere. */
4080 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4082 /* Set the new lower bound. */
4083 from = loop.from[dim];
4086 /* If we have an array section or are assigning to a pointer,
4087 make sure that the lower bound is 1. References to the full
4088 array should otherwise keep the original bounds. */
4089 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4090 && !integer_onep (from))
4092 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4093 gfc_index_one_node, from);
4094 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4095 from = gfc_index_one_node;
4097 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4098 gfc_add_modify_expr (&loop.pre, tmp, from);
4100 /* Set the new upper bound. */
4101 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4102 gfc_add_modify_expr (&loop.pre, tmp, to);
4104 /* Multiply the stride by the section stride to get the
4106 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4107 stride, info->stride[dim]);
4109 if (se->direct_byref)
4110 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4113 /* Store the new stride. */
4114 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4115 gfc_add_modify_expr (&loop.pre, tmp, stride);
4120 /* Point the data pointer at the first element in the section. */
4121 tmp = gfc_conv_array_data (desc);
4122 tmp = gfc_build_indirect_ref (tmp);
4123 tmp = gfc_build_array_ref (tmp, offset);
4124 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4125 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4127 if (se->direct_byref)
4129 /* Set the offset. */
4130 tmp = gfc_conv_descriptor_offset (parm);
4131 gfc_add_modify_expr (&loop.pre, tmp, base);
4135 /* Only the callee knows what the correct offset it, so just set
4137 tmp = gfc_conv_descriptor_offset (parm);
4138 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4143 if (!se->direct_byref)
4145 /* Get a pointer to the new descriptor. */
4146 if (se->want_pointer)
4147 se->expr = gfc_build_addr_expr (NULL, desc);
4152 gfc_add_block_to_block (&se->pre, &loop.pre);
4153 gfc_add_block_to_block (&se->post, &loop.post);
4155 /* Cleanup the scalarizer. */
4156 gfc_cleanup_loop (&loop);
4160 /* Convert an array for passing as an actual parameter. */
4161 /* TODO: Optimize passing g77 arrays. */
4164 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4173 /* Passing address of the array if it is not pointer or assumed-shape. */
4174 if (expr->expr_type == EXPR_VARIABLE
4175 && expr->ref->u.ar.type == AR_FULL && g77)
4177 sym = expr->symtree->n.sym;
4178 tmp = gfc_get_symbol_decl (sym);
4180 if (sym->ts.type == BT_CHARACTER)
4181 se->string_length = sym->ts.cl->backend_decl;
4182 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4183 && !sym->attr.allocatable)
4185 /* Some variables are declared directly, others are declared as
4186 pointers and allocated on the heap. */
4187 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4190 se->expr = gfc_build_addr_expr (NULL, tmp);
4193 if (sym->attr.allocatable)
4195 se->expr = gfc_conv_array_data (tmp);
4200 se->want_pointer = 1;
4201 gfc_conv_expr_descriptor (se, expr, ss);
4206 /* Repack the array. */
4207 tmp = gfc_chainon_list (NULL_TREE, desc);
4208 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
4209 ptr = gfc_evaluate_now (ptr, &se->pre);
4212 gfc_start_block (&block);
4214 /* Copy the data back. */
4215 tmp = gfc_chainon_list (NULL_TREE, desc);
4216 tmp = gfc_chainon_list (tmp, ptr);
4217 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
4218 gfc_add_expr_to_block (&block, tmp);
4220 /* Free the temporary. */
4221 tmp = convert (pvoid_type_node, ptr);
4222 tmp = gfc_chainon_list (NULL_TREE, tmp);
4223 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
4224 gfc_add_expr_to_block (&block, tmp);
4226 stmt = gfc_finish_block (&block);
4228 gfc_init_block (&block);
4229 /* Only if it was repacked. This code needs to be executed before the
4230 loop cleanup code. */
4231 tmp = gfc_build_indirect_ref (desc);
4232 tmp = gfc_conv_array_data (tmp);
4233 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4234 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4236 gfc_add_expr_to_block (&block, tmp);
4237 gfc_add_block_to_block (&block, &se->post);
4239 gfc_init_block (&se->post);
4240 gfc_add_block_to_block (&se->post, &block);
4245 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4248 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4255 stmtblock_t fnblock;
4258 /* Make sure the frontend gets these right. */
4259 if (!(sym->attr.pointer || sym->attr.allocatable))
4261 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4263 gfc_init_block (&fnblock);
4265 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4266 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4268 if (sym->ts.type == BT_CHARACTER
4269 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4270 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4272 /* Dummy and use associated variables don't need anything special. */
4273 if (sym->attr.dummy || sym->attr.use_assoc)
4275 gfc_add_expr_to_block (&fnblock, body);
4277 return gfc_finish_block (&fnblock);
4280 gfc_get_backend_locus (&loc);
4281 gfc_set_backend_locus (&sym->declared_at);
4282 descriptor = sym->backend_decl;
4284 if (TREE_STATIC (descriptor))
4286 /* SAVEd variables are not freed on exit. */
4287 gfc_trans_static_array_pointer (sym);
4291 /* Get the descriptor type. */
4292 type = TREE_TYPE (sym->backend_decl);
4293 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4295 /* NULLIFY the data pointer. */
4296 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4298 gfc_add_expr_to_block (&fnblock, body);
4300 gfc_set_backend_locus (&loc);
4301 /* Allocatable arrays need to be freed when they go out of scope. */
4302 if (sym->attr.allocatable)
4304 gfc_start_block (&block);
4306 /* Deallocate if still allocated at the end of the procedure. */
4307 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4309 tmp = gfc_conv_descriptor_data_get (descriptor);
4310 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4311 build_int_cst (TREE_TYPE (tmp), 0));
4312 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4313 gfc_add_expr_to_block (&block, tmp);
4315 tmp = gfc_finish_block (&block);
4316 gfc_add_expr_to_block (&fnblock, tmp);
4319 return gfc_finish_block (&fnblock);
4322 /************ Expression Walking Functions ******************/
4324 /* Walk a variable reference.
4326 Possible extension - multiple component subscripts.
4327 x(:,:) = foo%a(:)%b(:)
4329 forall (i=..., j=...)
4330 x(i,j) = foo%a(j)%b(i)
4332 This adds a fair amout of complexity because you need to deal with more
4333 than one ref. Maybe handle in a similar manner to vector subscripts.
4334 Maybe not worth the effort. */
4338 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4346 for (ref = expr->ref; ref; ref = ref->next)
4347 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4350 for (; ref; ref = ref->next)
4352 if (ref->type == REF_SUBSTRING)
4354 newss = gfc_get_ss ();
4355 newss->type = GFC_SS_SCALAR;
4356 newss->expr = ref->u.ss.start;
4360 newss = gfc_get_ss ();
4361 newss->type = GFC_SS_SCALAR;
4362 newss->expr = ref->u.ss.end;
4367 /* We're only interested in array sections from now on. */
4368 if (ref->type != REF_ARRAY)
4375 for (n = 0; n < ar->dimen; n++)
4377 newss = gfc_get_ss ();
4378 newss->type = GFC_SS_SCALAR;
4379 newss->expr = ar->start[n];
4386 newss = gfc_get_ss ();
4387 newss->type = GFC_SS_SECTION;
4390 newss->data.info.dimen = ar->as->rank;
4391 newss->data.info.ref = ref;
4393 /* Make sure array is the same as array(:,:), this way
4394 we don't need to special case all the time. */
4395 ar->dimen = ar->as->rank;
4396 for (n = 0; n < ar->dimen; n++)
4398 newss->data.info.dim[n] = n;
4399 ar->dimen_type[n] = DIMEN_RANGE;
4401 gcc_assert (ar->start[n] == NULL);
4402 gcc_assert (ar->end[n] == NULL);
4403 gcc_assert (ar->stride[n] == NULL);
4409 newss = gfc_get_ss ();
4410 newss->type = GFC_SS_SECTION;
4413 newss->data.info.dimen = 0;
4414 newss->data.info.ref = ref;
4418 /* We add SS chains for all the subscripts in the section. */
4419 for (n = 0; n < ar->dimen; n++)
4423 switch (ar->dimen_type[n])
4426 /* Add SS for elemental (scalar) subscripts. */
4427 gcc_assert (ar->start[n]);
4428 indexss = gfc_get_ss ();
4429 indexss->type = GFC_SS_SCALAR;
4430 indexss->expr = ar->start[n];
4431 indexss->next = gfc_ss_terminator;
4432 indexss->loop_chain = gfc_ss_terminator;
4433 newss->data.info.subscript[n] = indexss;
4437 /* We don't add anything for sections, just remember this
4438 dimension for later. */
4439 newss->data.info.dim[newss->data.info.dimen] = n;
4440 newss->data.info.dimen++;
4444 /* Create a GFC_SS_VECTOR index in which we can store
4445 the vector's descriptor. */
4446 indexss = gfc_get_ss ();
4447 indexss->type = GFC_SS_VECTOR;
4448 indexss->expr = ar->start[n];
4449 indexss->next = gfc_ss_terminator;
4450 indexss->loop_chain = gfc_ss_terminator;
4451 newss->data.info.subscript[n] = indexss;
4452 newss->data.info.dim[newss->data.info.dimen] = n;
4453 newss->data.info.dimen++;
4457 /* We should know what sort of section it is by now. */
4461 /* We should have at least one non-elemental dimension. */
4462 gcc_assert (newss->data.info.dimen > 0);
4467 /* We should know what sort of section it is by now. */
4476 /* Walk an expression operator. If only one operand of a binary expression is
4477 scalar, we must also add the scalar term to the SS chain. */
4480 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4486 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4487 if (expr->value.op.op2 == NULL)
4490 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4492 /* All operands are scalar. Pass back and let the caller deal with it. */
4496 /* All operands require scalarization. */
4497 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4500 /* One of the operands needs scalarization, the other is scalar.
4501 Create a gfc_ss for the scalar expression. */
4502 newss = gfc_get_ss ();
4503 newss->type = GFC_SS_SCALAR;
4506 /* First operand is scalar. We build the chain in reverse order, so
4507 add the scarar SS after the second operand. */
4509 while (head && head->next != ss)
4511 /* Check we haven't somehow broken the chain. */
4515 newss->expr = expr->value.op.op1;
4517 else /* head2 == head */
4519 gcc_assert (head2 == head);
4520 /* Second operand is scalar. */
4521 newss->next = head2;
4523 newss->expr = expr->value.op.op2;
4530 /* Reverse a SS chain. */
4533 gfc_reverse_ss (gfc_ss * ss)
4538 gcc_assert (ss != NULL);
4540 head = gfc_ss_terminator;
4541 while (ss != gfc_ss_terminator)
4544 /* Check we didn't somehow break the chain. */
4545 gcc_assert (next != NULL);
4555 /* Walk the arguments of an elemental function. */
4558 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4561 gfc_actual_arglist *arg;
4567 head = gfc_ss_terminator;
4570 for (arg = expr->value.function.actual; arg; arg = arg->next)
4575 newss = gfc_walk_subexpr (head, arg->expr);
4578 /* Scalar argument. */
4579 newss = gfc_get_ss ();
4581 newss->expr = arg->expr;
4591 while (tail->next != gfc_ss_terminator)
4598 /* If all the arguments are scalar we don't need the argument SS. */
4599 gfc_free_ss_chain (head);
4604 /* Add it onto the existing chain. */
4610 /* Walk a function call. Scalar functions are passed back, and taken out of
4611 scalarization loops. For elemental functions we walk their arguments.
4612 The result of functions returning arrays is stored in a temporary outside
4613 the loop, so that the function is only called once. Hence we do not need
4614 to walk their arguments. */
4617 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4620 gfc_intrinsic_sym *isym;
4623 isym = expr->value.function.isym;
4625 /* Handle intrinsic functions separately. */
4627 return gfc_walk_intrinsic_function (ss, expr, isym);
4629 sym = expr->value.function.esym;
4631 sym = expr->symtree->n.sym;
4633 /* A function that returns arrays. */
4634 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4636 newss = gfc_get_ss ();
4637 newss->type = GFC_SS_FUNCTION;
4640 newss->data.info.dimen = expr->rank;
4644 /* Walk the parameters of an elemental function. For now we always pass
4646 if (sym->attr.elemental)
4647 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4649 /* Scalar functions are OK as these are evaluated outside the scalarization
4650 loop. Pass back and let the caller deal with it. */
4655 /* An array temporary is constructed for array constructors. */
4658 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4663 newss = gfc_get_ss ();
4664 newss->type = GFC_SS_CONSTRUCTOR;
4667 newss->data.info.dimen = expr->rank;
4668 for (n = 0; n < expr->rank; n++)
4669 newss->data.info.dim[n] = n;
4675 /* Walk an expression. Add walked expressions to the head of the SS chain.
4676 A wholly scalar expression will not be added. */
4679 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4683 switch (expr->expr_type)
4686 head = gfc_walk_variable_expr (ss, expr);
4690 head = gfc_walk_op_expr (ss, expr);
4694 head = gfc_walk_function_expr (ss, expr);
4699 case EXPR_STRUCTURE:
4700 /* Pass back and let the caller deal with it. */
4704 head = gfc_walk_array_constructor (ss, expr);
4707 case EXPR_SUBSTRING:
4708 /* Pass back and let the caller deal with it. */
4712 internal_error ("bad expression type during walk (%d)",
4719 /* Entry point for expression walking.
4720 A return value equal to the passed chain means this is
4721 a scalar expression. It is up to the caller to take whatever action is
4722 necessary to translate these. */
4725 gfc_walk_expr (gfc_expr * expr)
4729 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4730 return gfc_reverse_ss (res);