1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subecripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "tree-gimple.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
106 gfc_array_dataptr_type (tree desc)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc)
147 type = TREE_TYPE (desc);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
150 field = TYPE_FIELDS (type);
151 gcc_assert (DATA_FIELD == 0);
153 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field. */
162 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
166 type = TREE_TYPE (desc);
167 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
169 field = TYPE_FIELDS (type);
170 gcc_assert (DATA_FIELD == 0);
172 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
173 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
177 /* This provides address access to the data field. This should only be
178 used by array allocation, passing this on to the runtime. */
181 gfc_conv_descriptor_data_addr (tree desc)
185 type = TREE_TYPE (desc);
186 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
188 field = TYPE_FIELDS (type);
189 gcc_assert (DATA_FIELD == 0);
191 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
192 return build_fold_addr_expr (t);
196 gfc_conv_descriptor_offset (tree desc)
201 type = TREE_TYPE (desc);
202 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
204 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
205 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
207 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
211 gfc_conv_descriptor_dtype (tree desc)
216 type = TREE_TYPE (desc);
217 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
219 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
220 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
222 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
226 gfc_conv_descriptor_dimension (tree desc, tree dim)
232 type = TREE_TYPE (desc);
233 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
235 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
236 gcc_assert (field != NULL_TREE
237 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
238 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
240 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
241 tmp = gfc_build_array_ref (tmp, dim);
246 gfc_conv_descriptor_stride (tree desc, tree dim)
251 tmp = gfc_conv_descriptor_dimension (desc, dim);
252 field = TYPE_FIELDS (TREE_TYPE (tmp));
253 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
254 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
256 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
261 gfc_conv_descriptor_lbound (tree desc, tree dim)
266 tmp = gfc_conv_descriptor_dimension (desc, dim);
267 field = TYPE_FIELDS (TREE_TYPE (tmp));
268 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
269 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
271 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
276 gfc_conv_descriptor_ubound (tree desc, tree dim)
281 tmp = gfc_conv_descriptor_dimension (desc, dim);
282 field = TYPE_FIELDS (TREE_TYPE (tmp));
283 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
284 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
286 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
291 /* Build a null array descriptor constructor. */
294 gfc_build_null_descriptor (tree type)
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
300 gcc_assert (DATA_FIELD == 0);
301 field = TYPE_FIELDS (type);
303 /* Set a NULL data pointer. */
304 tmp = build_constructor_single (type, field, null_pointer_node);
305 TREE_CONSTANT (tmp) = 1;
306 TREE_INVARIANT (tmp) = 1;
307 /* All other fields are ignored. */
313 /* Cleanup those #defines. */
318 #undef DIMENSION_FIELD
319 #undef STRIDE_SUBFIELD
320 #undef LBOUND_SUBFIELD
321 #undef UBOUND_SUBFIELD
324 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
325 flags & 1 = Main loop body.
326 flags & 2 = temp copy loop. */
329 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
331 for (; ss != gfc_ss_terminator; ss = ss->next)
332 ss->useflags = flags;
335 static void gfc_free_ss (gfc_ss *);
338 /* Free a gfc_ss chain. */
341 gfc_free_ss_chain (gfc_ss * ss)
345 while (ss != gfc_ss_terminator)
347 gcc_assert (ss != NULL);
358 gfc_free_ss (gfc_ss * ss)
365 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
367 if (ss->data.info.subscript[n])
368 gfc_free_ss_chain (ss->data.info.subscript[n]);
380 /* Free all the SS associated with a loop. */
383 gfc_cleanup_loop (gfc_loopinfo * loop)
389 while (ss != gfc_ss_terminator)
391 gcc_assert (ss != NULL);
392 next = ss->loop_chain;
399 /* Associate a SS chain with a loop. */
402 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
406 if (head == gfc_ss_terminator)
410 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
412 if (ss->next == gfc_ss_terminator)
413 ss->loop_chain = loop->ss;
415 ss->loop_chain = ss->next;
417 gcc_assert (ss == gfc_ss_terminator);
422 /* Generate an initializer for a static pointer or allocatable array. */
425 gfc_trans_static_array_pointer (gfc_symbol * sym)
429 gcc_assert (TREE_STATIC (sym->backend_decl));
430 /* Just zero the data member. */
431 type = TREE_TYPE (sym->backend_decl);
432 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
436 /* If the bounds of SE's loop have not yet been set, see if they can be
437 determined from array spec AS, which is the array spec of a called
438 function. MAPPING maps the callee's dummy arguments to the values
439 that the caller is passing. Add any initialization and finalization
443 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
444 gfc_se * se, gfc_array_spec * as)
452 if (as && as->type == AS_EXPLICIT)
453 for (dim = 0; dim < se->loop->dimen; dim++)
455 n = se->loop->order[dim];
456 if (se->loop->to[n] == NULL_TREE)
458 /* Evaluate the lower bound. */
459 gfc_init_se (&tmpse, NULL);
460 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
461 gfc_add_block_to_block (&se->pre, &tmpse.pre);
462 gfc_add_block_to_block (&se->post, &tmpse.post);
465 /* ...and the upper bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* Set the upper bound of the loop to UPPER - LOWER. */
473 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
474 tmp = gfc_evaluate_now (tmp, &se->pre);
475 se->loop->to[n] = tmp;
481 /* Generate code to allocate an array temporary, or create a variable to
482 hold the data. If size is NULL, zero the descriptor so that the
483 callee will allocate the array. If DEALLOC is true, also generate code to
484 free the array afterwards.
486 Initialization code is added to PRE and finalization code to POST.
487 DYNAMIC is true if the caller may want to extend the array later
488 using realloc. This prevents us from putting the array on the stack. */
491 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
492 gfc_ss_info * info, tree size, tree nelem,
493 bool dynamic, bool dealloc)
500 desc = info->descriptor;
501 info->offset = gfc_index_zero_node;
502 if (size == NULL_TREE || integer_zerop (size))
504 /* A callee allocated array. */
505 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
510 /* Allocate the temporary. */
511 onstack = !dynamic && gfc_can_put_var_on_stack (size);
515 /* Make a temporary variable to hold the data. */
516 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
518 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
520 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
522 tmp = gfc_create_var (tmp, "A");
523 tmp = build_fold_addr_expr (tmp);
524 gfc_conv_descriptor_data_set (pre, desc, tmp);
528 /* Allocate memory to hold the data. */
529 args = gfc_chainon_list (NULL_TREE, size);
531 if (gfc_index_integer_kind == 4)
532 tmp = gfor_fndecl_internal_malloc;
533 else if (gfc_index_integer_kind == 8)
534 tmp = gfor_fndecl_internal_malloc64;
537 tmp = build_function_call_expr (tmp, args);
538 tmp = gfc_evaluate_now (tmp, pre);
539 gfc_conv_descriptor_data_set (pre, desc, tmp);
542 info->data = gfc_conv_descriptor_data_get (desc);
544 /* The offset is zero because we create temporaries with a zero
546 tmp = gfc_conv_descriptor_offset (desc);
547 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
549 if (dealloc && !onstack)
551 /* Free the temporary. */
552 tmp = gfc_conv_descriptor_data_get (desc);
553 tmp = fold_convert (pvoid_type_node, tmp);
554 tmp = gfc_chainon_list (NULL_TREE, tmp);
555 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
556 gfc_add_expr_to_block (post, tmp);
561 /* Generate code to allocate and initialize the descriptor for a temporary
562 array. This is used for both temporaries needed by the scalarizer, and
563 functions returning arrays. Adjusts the loop variables to be zero-based,
564 and calculates the loop bounds for callee allocated arrays.
565 Also fills in the descriptor, data and offset fields of info if known.
566 Returns the size of the array, or NULL for a callee allocated array.
568 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
572 gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
573 gfc_loopinfo * loop, gfc_ss_info * info,
574 tree eltype, bool dynamic, bool dealloc)
584 gcc_assert (info->dimen > 0);
585 /* Set the lower bound to zero. */
586 for (dim = 0; dim < info->dimen; dim++)
588 n = loop->order[dim];
589 if (n < loop->temp_dim)
590 gcc_assert (integer_zerop (loop->from[n]));
593 /* Callee allocated arrays may not have a known bound yet. */
595 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
596 loop->to[n], loop->from[n]);
597 loop->from[n] = gfc_index_zero_node;
600 info->delta[dim] = gfc_index_zero_node;
601 info->start[dim] = gfc_index_zero_node;
602 info->stride[dim] = gfc_index_one_node;
603 info->dim[dim] = dim;
606 /* Initialize the descriptor. */
608 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
609 desc = gfc_create_var (type, "atmp");
610 GFC_DECL_PACKED_ARRAY (desc) = 1;
612 info->descriptor = desc;
613 size = gfc_index_one_node;
615 /* Fill in the array dtype. */
616 tmp = gfc_conv_descriptor_dtype (desc);
617 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
620 Fill in the bounds and stride. This is a packed array, so:
623 for (n = 0; n < rank; n++)
626 delta = ubound[n] + 1 - lbound[n];
629 size = size * sizeof(element);
632 for (n = 0; n < info->dimen; n++)
634 if (loop->to[n] == NULL_TREE)
636 /* For a callee allocated array express the loop bounds in terms
637 of the descriptor fields. */
638 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
639 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
640 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
646 /* Store the stride and bound components in the descriptor. */
647 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
648 gfc_add_modify_expr (pre, tmp, size);
650 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
651 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
653 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
654 gfc_add_modify_expr (pre, tmp, loop->to[n]);
656 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
657 loop->to[n], gfc_index_one_node);
659 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
660 size = gfc_evaluate_now (size, pre);
663 /* Get the size of the array. */
666 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
667 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
669 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
672 if (info->dimen > loop->temp_dim)
673 loop->temp_dim = info->dimen;
679 /* Generate code to transpose array EXPR by creating a new descriptor
680 in which the dimension specifications have been reversed. */
683 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
685 tree dest, src, dest_index, src_index;
687 gfc_ss_info *dest_info, *src_info;
688 gfc_ss *dest_ss, *src_ss;
694 src_ss = gfc_walk_expr (expr);
697 src_info = &src_ss->data.info;
698 dest_info = &dest_ss->data.info;
700 /* Get a descriptor for EXPR. */
701 gfc_init_se (&src_se, NULL);
702 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
703 gfc_add_block_to_block (&se->pre, &src_se.pre);
704 gfc_add_block_to_block (&se->post, &src_se.post);
707 /* Allocate a new descriptor for the return value. */
708 dest = gfc_create_var (TREE_TYPE (src), "atmp");
709 dest_info->descriptor = dest;
712 /* Copy across the dtype field. */
713 gfc_add_modify_expr (&se->pre,
714 gfc_conv_descriptor_dtype (dest),
715 gfc_conv_descriptor_dtype (src));
717 /* Copy the dimension information, renumbering dimension 1 to 0 and
719 gcc_assert (dest_info->dimen == 2);
720 gcc_assert (src_info->dimen == 2);
721 for (n = 0; n < 2; n++)
723 dest_info->delta[n] = integer_zero_node;
724 dest_info->start[n] = integer_zero_node;
725 dest_info->stride[n] = integer_one_node;
726 dest_info->dim[n] = n;
728 dest_index = gfc_rank_cst[n];
729 src_index = gfc_rank_cst[1 - n];
731 gfc_add_modify_expr (&se->pre,
732 gfc_conv_descriptor_stride (dest, dest_index),
733 gfc_conv_descriptor_stride (src, src_index));
735 gfc_add_modify_expr (&se->pre,
736 gfc_conv_descriptor_lbound (dest, dest_index),
737 gfc_conv_descriptor_lbound (src, src_index));
739 gfc_add_modify_expr (&se->pre,
740 gfc_conv_descriptor_ubound (dest, dest_index),
741 gfc_conv_descriptor_ubound (src, src_index));
745 gcc_assert (integer_zerop (loop->from[n]));
746 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
747 gfc_conv_descriptor_ubound (dest, dest_index),
748 gfc_conv_descriptor_lbound (dest, dest_index));
752 /* Copy the data pointer. */
753 dest_info->data = gfc_conv_descriptor_data_get (src);
754 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
756 /* Copy the offset. This is not changed by transposition: the top-left
757 element is still at the same offset as before. */
758 dest_info->offset = gfc_conv_descriptor_offset (src);
759 gfc_add_modify_expr (&se->pre,
760 gfc_conv_descriptor_offset (dest),
763 if (dest_info->dimen > loop->temp_dim)
764 loop->temp_dim = dest_info->dimen;
768 /* Return the number of iterations in a loop that starts at START,
769 ends at END, and has step STEP. */
772 gfc_get_iteration_count (tree start, tree end, tree step)
777 type = TREE_TYPE (step);
778 tmp = fold_build2 (MINUS_EXPR, type, end, start);
779 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
780 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
781 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
782 return fold_convert (gfc_array_index_type, tmp);
786 /* Extend the data in array DESC by EXTRA elements. */
789 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
796 if (integer_zerop (extra))
799 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
801 /* Add EXTRA to the upper bound. */
802 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
803 gfc_add_modify_expr (pblock, ubound, tmp);
805 /* Get the value of the current data pointer. */
806 tmp = gfc_conv_descriptor_data_get (desc);
807 args = gfc_chainon_list (NULL_TREE, tmp);
809 /* Calculate the new array size. */
810 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
811 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
812 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
813 args = gfc_chainon_list (args, tmp);
815 /* Pick the appropriate realloc function. */
816 if (gfc_index_integer_kind == 4)
817 tmp = gfor_fndecl_internal_realloc;
818 else if (gfc_index_integer_kind == 8)
819 tmp = gfor_fndecl_internal_realloc64;
823 /* Set the new data pointer. */
824 tmp = build_function_call_expr (tmp, args);
825 gfc_conv_descriptor_data_set (pblock, desc, tmp);
829 /* Return true if the bounds of iterator I can only be determined
833 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
835 return (i->start->expr_type != EXPR_CONSTANT
836 || i->end->expr_type != EXPR_CONSTANT
837 || i->step->expr_type != EXPR_CONSTANT);
841 /* Split the size of constructor element EXPR into the sum of two terms,
842 one of which can be determined at compile time and one of which must
843 be calculated at run time. Set *SIZE to the former and return true
844 if the latter might be nonzero. */
847 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
849 if (expr->expr_type == EXPR_ARRAY)
850 return gfc_get_array_constructor_size (size, expr->value.constructor);
851 else if (expr->rank > 0)
853 /* Calculate everything at run time. */
854 mpz_set_ui (*size, 0);
859 /* A single element. */
860 mpz_set_ui (*size, 1);
866 /* Like gfc_get_array_constructor_element_size, but applied to the whole
867 of array constructor C. */
870 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
877 mpz_set_ui (*size, 0);
882 for (; c; c = c->next)
885 if (i && gfc_iterator_has_dynamic_bounds (i))
889 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
892 /* Multiply the static part of the element size by the
893 number of iterations. */
894 mpz_sub (val, i->end->value.integer, i->start->value.integer);
895 mpz_fdiv_q (val, val, i->step->value.integer);
896 mpz_add_ui (val, val, 1);
897 if (mpz_sgn (val) > 0)
898 mpz_mul (len, len, val);
902 mpz_add (*size, *size, len);
911 /* Make sure offset is a variable. */
914 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
917 /* We should have already created the offset variable. We cannot
918 create it here because we may be in an inner scope. */
919 gcc_assert (*offsetvar != NULL_TREE);
920 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
921 *poffset = *offsetvar;
922 TREE_USED (*offsetvar) = 1;
926 /* Assign an element of an array constructor. */
929 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
930 tree offset, gfc_se * se, gfc_expr * expr)
935 gfc_conv_expr (se, expr);
937 /* Store the value. */
938 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
939 tmp = gfc_build_array_ref (tmp, offset);
940 if (expr->ts.type == BT_CHARACTER)
942 gfc_conv_string_parameter (se);
943 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
945 /* The temporary is an array of pointers. */
946 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
947 gfc_add_modify_expr (&se->pre, tmp, se->expr);
951 /* The temporary is an array of string values. */
952 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
953 /* We know the temporary and the value will be the same length,
954 so can use memcpy. */
955 args = gfc_chainon_list (NULL_TREE, tmp);
956 args = gfc_chainon_list (args, se->expr);
957 args = gfc_chainon_list (args, se->string_length);
958 tmp = built_in_decls[BUILT_IN_MEMCPY];
959 tmp = build_function_call_expr (tmp, args);
960 gfc_add_expr_to_block (&se->pre, tmp);
965 /* TODO: Should the frontend already have done this conversion? */
966 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
967 gfc_add_modify_expr (&se->pre, tmp, se->expr);
970 gfc_add_block_to_block (pblock, &se->pre);
971 gfc_add_block_to_block (pblock, &se->post);
975 /* Add the contents of an array to the constructor. DYNAMIC is as for
976 gfc_trans_array_constructor_value. */
979 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
980 tree type ATTRIBUTE_UNUSED,
981 tree desc, gfc_expr * expr,
982 tree * poffset, tree * offsetvar,
993 /* We need this to be a variable so we can increment it. */
994 gfc_put_offset_into_var (pblock, poffset, offsetvar);
996 gfc_init_se (&se, NULL);
998 /* Walk the array expression. */
999 ss = gfc_walk_expr (expr);
1000 gcc_assert (ss != gfc_ss_terminator);
1002 /* Initialize the scalarizer. */
1003 gfc_init_loopinfo (&loop);
1004 gfc_add_ss_to_loop (&loop, ss);
1006 /* Initialize the loop. */
1007 gfc_conv_ss_startstride (&loop);
1008 gfc_conv_loop_setup (&loop);
1010 /* Make sure the constructed array has room for the new data. */
1013 /* Set SIZE to the total number of elements in the subarray. */
1014 size = gfc_index_one_node;
1015 for (n = 0; n < loop.dimen; n++)
1017 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1018 gfc_index_one_node);
1019 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1022 /* Grow the constructed array by SIZE elements. */
1023 gfc_grow_array (&loop.pre, desc, size);
1026 /* Make the loop body. */
1027 gfc_mark_ss_chain_used (ss, 1);
1028 gfc_start_scalarized_body (&loop, &body);
1029 gfc_copy_loopinfo_to_se (&se, &loop);
1032 if (expr->ts.type == BT_CHARACTER)
1033 gfc_todo_error ("character arrays in constructors");
1035 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1036 gcc_assert (se.ss == gfc_ss_terminator);
1038 /* Increment the offset. */
1039 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1040 gfc_add_modify_expr (&body, *poffset, tmp);
1042 /* Finish the loop. */
1043 gfc_trans_scalarizing_loops (&loop, &body);
1044 gfc_add_block_to_block (&loop.pre, &loop.post);
1045 tmp = gfc_finish_block (&loop.pre);
1046 gfc_add_expr_to_block (pblock, tmp);
1048 gfc_cleanup_loop (&loop);
1052 /* Assign the values to the elements of an array constructor. DYNAMIC
1053 is true if descriptor DESC only contains enough data for the static
1054 size calculated by gfc_get_array_constructor_size. When true, memory
1055 for the dynamic parts must be allocated using realloc. */
1058 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1059 tree desc, gfc_constructor * c,
1060 tree * poffset, tree * offsetvar,
1069 for (; c; c = c->next)
1071 /* If this is an iterator or an array, the offset must be a variable. */
1072 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1073 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1075 gfc_start_block (&body);
1077 if (c->expr->expr_type == EXPR_ARRAY)
1079 /* Array constructors can be nested. */
1080 gfc_trans_array_constructor_value (&body, type, desc,
1081 c->expr->value.constructor,
1082 poffset, offsetvar, dynamic);
1084 else if (c->expr->rank > 0)
1086 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1087 poffset, offsetvar, dynamic);
1091 /* This code really upsets the gimplifier so don't bother for now. */
1098 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1105 /* Scalar values. */
1106 gfc_init_se (&se, NULL);
1107 gfc_trans_array_ctor_element (&body, desc, *poffset,
1110 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1111 *poffset, gfc_index_one_node);
1115 /* Collect multiple scalar constants into a constructor. */
1123 /* Count the number of consecutive scalar constants. */
1124 while (p && !(p->iterator
1125 || p->expr->expr_type != EXPR_CONSTANT))
1127 gfc_init_se (&se, NULL);
1128 gfc_conv_constant (&se, p->expr);
1129 if (p->expr->ts.type == BT_CHARACTER
1130 && POINTER_TYPE_P (type))
1132 /* For constant character array constructors we build
1133 an array of pointers. */
1134 se.expr = gfc_build_addr_expr (pchar_type_node,
1138 list = tree_cons (NULL_TREE, se.expr, list);
1143 bound = build_int_cst (NULL_TREE, n - 1);
1144 /* Create an array type to hold them. */
1145 tmptype = build_range_type (gfc_array_index_type,
1146 gfc_index_zero_node, bound);
1147 tmptype = build_array_type (type, tmptype);
1149 init = build_constructor_from_list (tmptype, nreverse (list));
1150 TREE_CONSTANT (init) = 1;
1151 TREE_INVARIANT (init) = 1;
1152 TREE_STATIC (init) = 1;
1153 /* Create a static variable to hold the data. */
1154 tmp = gfc_create_var (tmptype, "data");
1155 TREE_STATIC (tmp) = 1;
1156 TREE_CONSTANT (tmp) = 1;
1157 TREE_INVARIANT (tmp) = 1;
1158 DECL_INITIAL (tmp) = init;
1161 /* Use BUILTIN_MEMCPY to assign the values. */
1162 tmp = gfc_conv_descriptor_data_get (desc);
1163 tmp = build_fold_indirect_ref (tmp);
1164 tmp = gfc_build_array_ref (tmp, *poffset);
1165 tmp = build_fold_addr_expr (tmp);
1166 init = build_fold_addr_expr (init);
1168 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1169 bound = build_int_cst (NULL_TREE, n * size);
1170 tmp = gfc_chainon_list (NULL_TREE, tmp);
1171 tmp = gfc_chainon_list (tmp, init);
1172 tmp = gfc_chainon_list (tmp, bound);
1173 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
1175 gfc_add_expr_to_block (&body, tmp);
1177 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1178 *poffset, build_int_cst (NULL_TREE, n));
1180 if (!INTEGER_CST_P (*poffset))
1182 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1183 *poffset = *offsetvar;
1187 /* The frontend should already have done any expansions possible
1191 /* Pass the code as is. */
1192 tmp = gfc_finish_block (&body);
1193 gfc_add_expr_to_block (pblock, tmp);
1197 /* Build the implied do-loop. */
1206 loopbody = gfc_finish_block (&body);
1208 gfc_init_se (&se, NULL);
1209 gfc_conv_expr (&se, c->iterator->var);
1210 gfc_add_block_to_block (pblock, &se.pre);
1213 /* Initialize the loop. */
1214 gfc_init_se (&se, NULL);
1215 gfc_conv_expr_val (&se, c->iterator->start);
1216 gfc_add_block_to_block (pblock, &se.pre);
1217 gfc_add_modify_expr (pblock, loopvar, se.expr);
1219 gfc_init_se (&se, NULL);
1220 gfc_conv_expr_val (&se, c->iterator->end);
1221 gfc_add_block_to_block (pblock, &se.pre);
1222 end = gfc_evaluate_now (se.expr, pblock);
1224 gfc_init_se (&se, NULL);
1225 gfc_conv_expr_val (&se, c->iterator->step);
1226 gfc_add_block_to_block (pblock, &se.pre);
1227 step = gfc_evaluate_now (se.expr, pblock);
1229 /* If this array expands dynamically, and the number of iterations
1230 is not constant, we won't have allocated space for the static
1231 part of C->EXPR's size. Do that now. */
1232 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1234 /* Get the number of iterations. */
1235 tmp = gfc_get_iteration_count (loopvar, end, step);
1237 /* Get the static part of C->EXPR's size. */
1238 gfc_get_array_constructor_element_size (&size, c->expr);
1239 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1241 /* Grow the array by TMP * TMP2 elements. */
1242 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1243 gfc_grow_array (pblock, desc, tmp);
1246 /* Generate the loop body. */
1247 exit_label = gfc_build_label_decl (NULL_TREE);
1248 gfc_start_block (&body);
1250 /* Generate the exit condition. Depending on the sign of
1251 the step variable we have to generate the correct
1253 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1254 build_int_cst (TREE_TYPE (step), 0));
1255 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1256 build2 (GT_EXPR, boolean_type_node,
1258 build2 (LT_EXPR, boolean_type_node,
1260 tmp = build1_v (GOTO_EXPR, exit_label);
1261 TREE_USED (exit_label) = 1;
1262 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1263 gfc_add_expr_to_block (&body, tmp);
1265 /* The main loop body. */
1266 gfc_add_expr_to_block (&body, loopbody);
1268 /* Increase loop variable by step. */
1269 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1270 gfc_add_modify_expr (&body, loopvar, tmp);
1272 /* Finish the loop. */
1273 tmp = gfc_finish_block (&body);
1274 tmp = build1_v (LOOP_EXPR, tmp);
1275 gfc_add_expr_to_block (pblock, tmp);
1277 /* Add the exit label. */
1278 tmp = build1_v (LABEL_EXPR, exit_label);
1279 gfc_add_expr_to_block (pblock, tmp);
1286 /* Figure out the string length of a variable reference expression.
1287 Used by get_array_ctor_strlen. */
1290 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1295 /* Don't bother if we already know the length is a constant. */
1296 if (*len && INTEGER_CST_P (*len))
1299 ts = &expr->symtree->n.sym->ts;
1300 for (ref = expr->ref; ref; ref = ref->next)
1305 /* Array references don't change the string length. */
1309 /* Use the length of the component. */
1310 ts = &ref->u.c.component->ts;
1314 /* TODO: Substrings are tricky because we can't evaluate the
1315 expression more than once. For now we just give up, and hope
1316 we can figure it out elsewhere. */
1321 *len = ts->cl->backend_decl;
1325 /* Figure out the string length of a character array constructor.
1326 Returns TRUE if all elements are character constants. */
1329 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1334 for (; c; c = c->next)
1336 switch (c->expr->expr_type)
1339 if (!(*len && INTEGER_CST_P (*len)))
1340 *len = build_int_cstu (gfc_charlen_type_node,
1341 c->expr->value.character.length);
1345 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1351 get_array_ctor_var_strlen (c->expr, len);
1356 /* TODO: For now we just ignore anything we don't know how to
1357 handle, and hope we can figure it out a different way. */
1366 /* Array constructors are handled by constructing a temporary, then using that
1367 within the scalarization loop. This is not optimal, but seems by far the
1371 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1381 ss->data.info.dimen = loop->dimen;
1383 c = ss->expr->value.constructor;
1384 if (ss->expr->ts.type == BT_CHARACTER)
1386 const_string = get_array_ctor_strlen (c, &ss->string_length);
1387 if (!ss->string_length)
1388 gfc_todo_error ("complex character array constructors");
1390 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1392 type = build_pointer_type (type);
1396 const_string = TRUE;
1397 type = gfc_typenode_for_spec (&ss->expr->ts);
1400 /* See if the constructor determines the loop bounds. */
1402 if (loop->to[0] == NULL_TREE)
1406 /* We should have a 1-dimensional, zero-based loop. */
1407 gcc_assert (loop->dimen == 1);
1408 gcc_assert (integer_zerop (loop->from[0]));
1410 /* Split the constructor size into a static part and a dynamic part.
1411 Allocate the static size up-front and record whether the dynamic
1412 size might be nonzero. */
1414 dynamic = gfc_get_array_constructor_size (&size, c);
1415 mpz_sub_ui (size, size, 1);
1416 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1420 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
1421 &ss->data.info, type, dynamic, true);
1423 desc = ss->data.info.descriptor;
1424 offset = gfc_index_zero_node;
1425 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1426 TREE_USED (offsetvar) = 0;
1427 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1428 &offset, &offsetvar, dynamic);
1430 /* If the array grows dynamically, the upper bound of the loop variable
1431 is determined by the array's final upper bound. */
1433 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1435 if (TREE_USED (offsetvar))
1436 pushdecl (offsetvar);
1438 gcc_assert (INTEGER_CST_P (offset));
1440 /* Disable bound checking for now because it's probably broken. */
1441 if (flag_bounds_check)
1449 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1450 called after evaluating all of INFO's vector dimensions. Go through
1451 each such vector dimension and see if we can now fill in any missing
1455 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1464 for (n = 0; n < loop->dimen; n++)
1467 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1468 && loop->to[n] == NULL)
1470 /* Loop variable N indexes vector dimension DIM, and we don't
1471 yet know the upper bound of loop variable N. Set it to the
1472 difference between the vector's upper and lower bounds. */
1473 gcc_assert (loop->from[n] == gfc_index_zero_node);
1474 gcc_assert (info->subscript[dim]
1475 && info->subscript[dim]->type == GFC_SS_VECTOR);
1477 gfc_init_se (&se, NULL);
1478 desc = info->subscript[dim]->data.info.descriptor;
1479 zero = gfc_rank_cst[0];
1480 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1481 gfc_conv_descriptor_ubound (desc, zero),
1482 gfc_conv_descriptor_lbound (desc, zero));
1483 tmp = gfc_evaluate_now (tmp, &loop->pre);
1490 /* Add the pre and post chains for all the scalar expressions in a SS chain
1491 to loop. This is called after the loop parameters have been calculated,
1492 but before the actual scalarizing loops. */
1495 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1500 /* TODO: This can generate bad code if there are ordering dependencies.
1501 eg. a callee allocated function and an unknown size constructor. */
1502 gcc_assert (ss != NULL);
1504 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1511 /* Scalar expression. Evaluate this now. This includes elemental
1512 dimension indices, but not array section bounds. */
1513 gfc_init_se (&se, NULL);
1514 gfc_conv_expr (&se, ss->expr);
1515 gfc_add_block_to_block (&loop->pre, &se.pre);
1517 if (ss->expr->ts.type != BT_CHARACTER)
1519 /* Move the evaluation of scalar expressions outside the
1520 scalarization loop. */
1522 se.expr = convert(gfc_array_index_type, se.expr);
1523 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1524 gfc_add_block_to_block (&loop->pre, &se.post);
1527 gfc_add_block_to_block (&loop->post, &se.post);
1529 ss->data.scalar.expr = se.expr;
1530 ss->string_length = se.string_length;
1533 case GFC_SS_REFERENCE:
1534 /* Scalar reference. Evaluate this now. */
1535 gfc_init_se (&se, NULL);
1536 gfc_conv_expr_reference (&se, ss->expr);
1537 gfc_add_block_to_block (&loop->pre, &se.pre);
1538 gfc_add_block_to_block (&loop->post, &se.post);
1540 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1541 ss->string_length = se.string_length;
1544 case GFC_SS_SECTION:
1545 /* Add the expressions for scalar and vector subscripts. */
1546 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1547 if (ss->data.info.subscript[n])
1548 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1550 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1554 /* Get the vector's descriptor and store it in SS. */
1555 gfc_init_se (&se, NULL);
1556 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1557 gfc_add_block_to_block (&loop->pre, &se.pre);
1558 gfc_add_block_to_block (&loop->post, &se.post);
1559 ss->data.info.descriptor = se.expr;
1562 case GFC_SS_INTRINSIC:
1563 gfc_add_intrinsic_ss_code (loop, ss);
1566 case GFC_SS_FUNCTION:
1567 /* Array function return value. We call the function and save its
1568 result in a temporary for use inside the loop. */
1569 gfc_init_se (&se, NULL);
1572 gfc_conv_expr (&se, ss->expr);
1573 gfc_add_block_to_block (&loop->pre, &se.pre);
1574 gfc_add_block_to_block (&loop->post, &se.post);
1575 ss->string_length = se.string_length;
1578 case GFC_SS_CONSTRUCTOR:
1579 gfc_trans_array_constructor (loop, ss);
1583 case GFC_SS_COMPONENT:
1584 /* Do nothing. These are handled elsewhere. */
1594 /* Translate expressions for the descriptor and data pointer of a SS. */
1598 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1603 /* Get the descriptor for the array to be scalarized. */
1604 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1605 gfc_init_se (&se, NULL);
1606 se.descriptor_only = 1;
1607 gfc_conv_expr_lhs (&se, ss->expr);
1608 gfc_add_block_to_block (block, &se.pre);
1609 ss->data.info.descriptor = se.expr;
1610 ss->string_length = se.string_length;
1614 /* Also the data pointer. */
1615 tmp = gfc_conv_array_data (se.expr);
1616 /* If this is a variable or address of a variable we use it directly.
1617 Otherwise we must evaluate it now to avoid breaking dependency
1618 analysis by pulling the expressions for elemental array indices
1621 || (TREE_CODE (tmp) == ADDR_EXPR
1622 && DECL_P (TREE_OPERAND (tmp, 0)))))
1623 tmp = gfc_evaluate_now (tmp, block);
1624 ss->data.info.data = tmp;
1626 tmp = gfc_conv_array_offset (se.expr);
1627 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1632 /* Initialize a gfc_loopinfo structure. */
1635 gfc_init_loopinfo (gfc_loopinfo * loop)
1639 memset (loop, 0, sizeof (gfc_loopinfo));
1640 gfc_init_block (&loop->pre);
1641 gfc_init_block (&loop->post);
1643 /* Initially scalarize in order. */
1644 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1647 loop->ss = gfc_ss_terminator;
1651 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1655 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1661 /* Return an expression for the data pointer of an array. */
1664 gfc_conv_array_data (tree descriptor)
1668 type = TREE_TYPE (descriptor);
1669 if (GFC_ARRAY_TYPE_P (type))
1671 if (TREE_CODE (type) == POINTER_TYPE)
1675 /* Descriptorless arrays. */
1676 return build_fold_addr_expr (descriptor);
1680 return gfc_conv_descriptor_data_get (descriptor);
1684 /* Return an expression for the base offset of an array. */
1687 gfc_conv_array_offset (tree descriptor)
1691 type = TREE_TYPE (descriptor);
1692 if (GFC_ARRAY_TYPE_P (type))
1693 return GFC_TYPE_ARRAY_OFFSET (type);
1695 return gfc_conv_descriptor_offset (descriptor);
1699 /* Get an expression for the array stride. */
1702 gfc_conv_array_stride (tree descriptor, int dim)
1707 type = TREE_TYPE (descriptor);
1709 /* For descriptorless arrays use the array size. */
1710 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1711 if (tmp != NULL_TREE)
1714 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1719 /* Like gfc_conv_array_stride, but for the lower bound. */
1722 gfc_conv_array_lbound (tree descriptor, int dim)
1727 type = TREE_TYPE (descriptor);
1729 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1730 if (tmp != NULL_TREE)
1733 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1738 /* Like gfc_conv_array_stride, but for the upper bound. */
1741 gfc_conv_array_ubound (tree descriptor, int dim)
1746 type = TREE_TYPE (descriptor);
1748 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1749 if (tmp != NULL_TREE)
1752 /* This should only ever happen when passing an assumed shape array
1753 as an actual parameter. The value will never be used. */
1754 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1755 return gfc_index_zero_node;
1757 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1762 /* Generate code to perform an array index bound check. */
1765 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1771 if (!flag_bounds_check)
1774 index = gfc_evaluate_now (index, &se->pre);
1775 /* Check lower bound. */
1776 tmp = gfc_conv_array_lbound (descriptor, n);
1777 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1778 /* Check upper bound. */
1779 tmp = gfc_conv_array_ubound (descriptor, n);
1780 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1781 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1783 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1789 /* Return the offset for an index. Performs bound checking for elemental
1790 dimensions. Single element references are processed separately. */
1793 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1794 gfc_array_ref * ar, tree stride)
1800 /* Get the index into the array for this dimension. */
1803 gcc_assert (ar->type != AR_ELEMENT);
1804 switch (ar->dimen_type[dim])
1807 gcc_assert (i == -1);
1808 /* Elemental dimension. */
1809 gcc_assert (info->subscript[dim]
1810 && info->subscript[dim]->type == GFC_SS_SCALAR);
1811 /* We've already translated this value outside the loop. */
1812 index = info->subscript[dim]->data.scalar.expr;
1815 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1819 gcc_assert (info && se->loop);
1820 gcc_assert (info->subscript[dim]
1821 && info->subscript[dim]->type == GFC_SS_VECTOR);
1822 desc = info->subscript[dim]->data.info.descriptor;
1824 /* Get a zero-based index into the vector. */
1825 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1826 se->loop->loopvar[i], se->loop->from[i]);
1828 /* Multiply the index by the stride. */
1829 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1830 index, gfc_conv_array_stride (desc, 0));
1832 /* Read the vector to get an index into info->descriptor. */
1833 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
1834 index = gfc_build_array_ref (data, index);
1835 index = gfc_evaluate_now (index, &se->pre);
1837 /* Do any bounds checking on the final info->descriptor index. */
1838 index = gfc_trans_array_bound_check (se, info->descriptor,
1843 /* Scalarized dimension. */
1844 gcc_assert (info && se->loop);
1846 /* Multiply the loop variable by the stride and delta. */
1847 index = se->loop->loopvar[i];
1848 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1850 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1860 /* Temporary array or derived type component. */
1861 gcc_assert (se->loop);
1862 index = se->loop->loopvar[se->loop->order[i]];
1863 if (!integer_zerop (info->delta[i]))
1864 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1865 index, info->delta[i]);
1868 /* Multiply by the stride. */
1869 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1875 /* Build a scalarized reference to an array. */
1878 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1885 info = &se->ss->data.info;
1887 n = se->loop->order[0];
1891 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1893 /* Add the offset for this dimension to the stored offset for all other
1895 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1897 tmp = build_fold_indirect_ref (info->data);
1898 se->expr = gfc_build_array_ref (tmp, index);
1902 /* Translate access of temporary array. */
1905 gfc_conv_tmp_array_ref (gfc_se * se)
1907 se->string_length = se->ss->string_length;
1908 gfc_conv_scalarized_array_ref (se, NULL);
1912 /* Build an array reference. se->expr already holds the array descriptor.
1913 This should be either a variable, indirect variable reference or component
1914 reference. For arrays which do not have a descriptor, se->expr will be
1916 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1919 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1928 /* Handle scalarized references separately. */
1929 if (ar->type != AR_ELEMENT)
1931 gfc_conv_scalarized_array_ref (se, ar);
1932 gfc_advance_se_ss_chain (se);
1936 index = gfc_index_zero_node;
1938 fault = gfc_index_zero_node;
1940 /* Calculate the offsets from all the dimensions. */
1941 for (n = 0; n < ar->dimen; n++)
1943 /* Calculate the index for this dimension. */
1944 gfc_init_se (&indexse, se);
1945 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1946 gfc_add_block_to_block (&se->pre, &indexse.pre);
1948 if (flag_bounds_check)
1950 /* Check array bounds. */
1953 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1955 tmp = gfc_conv_array_lbound (se->expr, n);
1956 cond = fold_build2 (LT_EXPR, boolean_type_node,
1959 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1961 tmp = gfc_conv_array_ubound (se->expr, n);
1962 cond = fold_build2 (GT_EXPR, boolean_type_node,
1965 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1968 /* Multiply the index by the stride. */
1969 stride = gfc_conv_array_stride (se->expr, n);
1970 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1973 /* And add it to the total. */
1974 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1977 if (flag_bounds_check)
1978 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1980 tmp = gfc_conv_array_offset (se->expr);
1981 if (!integer_zerop (tmp))
1982 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1984 /* Access the calculated element. */
1985 tmp = gfc_conv_array_data (se->expr);
1986 tmp = build_fold_indirect_ref (tmp);
1987 se->expr = gfc_build_array_ref (tmp, index);
1991 /* Generate the code to be executed immediately before entering a
1992 scalarization loop. */
1995 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1996 stmtblock_t * pblock)
2005 /* This code will be executed before entering the scalarization loop
2006 for this dimension. */
2007 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2009 if ((ss->useflags & flag) == 0)
2012 if (ss->type != GFC_SS_SECTION
2013 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2014 && ss->type != GFC_SS_COMPONENT)
2017 info = &ss->data.info;
2019 if (dim >= info->dimen)
2022 if (dim == info->dimen - 1)
2024 /* For the outermost loop calculate the offset due to any
2025 elemental dimensions. It will have been initialized with the
2026 base offset of the array. */
2029 for (i = 0; i < info->ref->u.ar.dimen; i++)
2031 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2034 gfc_init_se (&se, NULL);
2036 se.expr = info->descriptor;
2037 stride = gfc_conv_array_stride (info->descriptor, i);
2038 index = gfc_conv_array_index_offset (&se, info, i, -1,
2041 gfc_add_block_to_block (pblock, &se.pre);
2043 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2044 info->offset, index);
2045 info->offset = gfc_evaluate_now (info->offset, pblock);
2049 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2052 stride = gfc_conv_array_stride (info->descriptor, 0);
2054 /* Calculate the stride of the innermost loop. Hopefully this will
2055 allow the backend optimizers to do their stuff more effectively.
2057 info->stride0 = gfc_evaluate_now (stride, pblock);
2061 /* Add the offset for the previous loop dimension. */
2066 ar = &info->ref->u.ar;
2067 i = loop->order[dim + 1];
2075 gfc_init_se (&se, NULL);
2077 se.expr = info->descriptor;
2078 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2079 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2081 gfc_add_block_to_block (pblock, &se.pre);
2082 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2083 info->offset, index);
2084 info->offset = gfc_evaluate_now (info->offset, pblock);
2087 /* Remember this offset for the second loop. */
2088 if (dim == loop->temp_dim - 1)
2089 info->saved_offset = info->offset;
2094 /* Start a scalarized expression. Creates a scope and declares loop
2098 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2104 gcc_assert (!loop->array_parameter);
2106 for (dim = loop->dimen - 1; dim >= 0; dim--)
2108 n = loop->order[dim];
2110 gfc_start_block (&loop->code[n]);
2112 /* Create the loop variable. */
2113 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2115 if (dim < loop->temp_dim)
2119 /* Calculate values that will be constant within this loop. */
2120 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2122 gfc_start_block (pbody);
2126 /* Generates the actual loop code for a scalarization loop. */
2129 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2130 stmtblock_t * pbody)
2138 loopbody = gfc_finish_block (pbody);
2140 /* Initialize the loopvar. */
2141 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2143 exit_label = gfc_build_label_decl (NULL_TREE);
2145 /* Generate the loop body. */
2146 gfc_init_block (&block);
2148 /* The exit condition. */
2149 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2150 tmp = build1_v (GOTO_EXPR, exit_label);
2151 TREE_USED (exit_label) = 1;
2152 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2153 gfc_add_expr_to_block (&block, tmp);
2155 /* The main body. */
2156 gfc_add_expr_to_block (&block, loopbody);
2158 /* Increment the loopvar. */
2159 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2160 loop->loopvar[n], gfc_index_one_node);
2161 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2163 /* Build the loop. */
2164 tmp = gfc_finish_block (&block);
2165 tmp = build1_v (LOOP_EXPR, tmp);
2166 gfc_add_expr_to_block (&loop->code[n], tmp);
2168 /* Add the exit label. */
2169 tmp = build1_v (LABEL_EXPR, exit_label);
2170 gfc_add_expr_to_block (&loop->code[n], tmp);
2174 /* Finishes and generates the loops for a scalarized expression. */
2177 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2182 stmtblock_t *pblock;
2186 /* Generate the loops. */
2187 for (dim = 0; dim < loop->dimen; dim++)
2189 n = loop->order[dim];
2190 gfc_trans_scalarized_loop_end (loop, n, pblock);
2191 loop->loopvar[n] = NULL_TREE;
2192 pblock = &loop->code[n];
2195 tmp = gfc_finish_block (pblock);
2196 gfc_add_expr_to_block (&loop->pre, tmp);
2198 /* Clear all the used flags. */
2199 for (ss = loop->ss; ss; ss = ss->loop_chain)
2204 /* Finish the main body of a scalarized expression, and start the secondary
2208 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2212 stmtblock_t *pblock;
2216 /* We finish as many loops as are used by the temporary. */
2217 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2219 n = loop->order[dim];
2220 gfc_trans_scalarized_loop_end (loop, n, pblock);
2221 loop->loopvar[n] = NULL_TREE;
2222 pblock = &loop->code[n];
2225 /* We don't want to finish the outermost loop entirely. */
2226 n = loop->order[loop->temp_dim - 1];
2227 gfc_trans_scalarized_loop_end (loop, n, pblock);
2229 /* Restore the initial offsets. */
2230 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2232 if ((ss->useflags & 2) == 0)
2235 if (ss->type != GFC_SS_SECTION
2236 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2237 && ss->type != GFC_SS_COMPONENT)
2240 ss->data.info.offset = ss->data.info.saved_offset;
2243 /* Restart all the inner loops we just finished. */
2244 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2246 n = loop->order[dim];
2248 gfc_start_block (&loop->code[n]);
2250 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2252 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2255 /* Start a block for the secondary copying code. */
2256 gfc_start_block (body);
2260 /* Calculate the upper bound of an array section. */
2263 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2272 gcc_assert (ss->type == GFC_SS_SECTION);
2274 info = &ss->data.info;
2277 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2278 /* We'll calculate the upper bound once we have access to the
2279 vector's descriptor. */
2282 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2283 desc = info->descriptor;
2284 end = info->ref->u.ar.end[dim];
2288 /* The upper bound was specified. */
2289 gfc_init_se (&se, NULL);
2290 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2291 gfc_add_block_to_block (pblock, &se.pre);
2296 /* No upper bound was specified, so use the bound of the array. */
2297 bound = gfc_conv_array_ubound (desc, dim);
2304 /* Calculate the lower bound of an array section. */
2307 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2316 gcc_assert (ss->type == GFC_SS_SECTION);
2318 info = &ss->data.info;
2321 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2323 /* We use a zero-based index to access the vector. */
2324 info->start[n] = gfc_index_zero_node;
2325 info->stride[n] = gfc_index_one_node;
2329 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2330 desc = info->descriptor;
2331 start = info->ref->u.ar.start[dim];
2332 stride = info->ref->u.ar.stride[dim];
2334 /* Calculate the start of the range. For vector subscripts this will
2335 be the range of the vector. */
2338 /* Specified section start. */
2339 gfc_init_se (&se, NULL);
2340 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2341 gfc_add_block_to_block (&loop->pre, &se.pre);
2342 info->start[n] = se.expr;
2346 /* No lower bound specified so use the bound of the array. */
2347 info->start[n] = gfc_conv_array_lbound (desc, dim);
2349 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2351 /* Calculate the stride. */
2353 info->stride[n] = gfc_index_one_node;
2356 gfc_init_se (&se, NULL);
2357 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2358 gfc_add_block_to_block (&loop->pre, &se.pre);
2359 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2364 /* Calculates the range start and stride for a SS chain. Also gets the
2365 descriptor and data pointer. The range of vector subscripts is the size
2366 of the vector. Array bounds are also checked. */
2369 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2377 /* Determine the rank of the loop. */
2379 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2383 case GFC_SS_SECTION:
2384 case GFC_SS_CONSTRUCTOR:
2385 case GFC_SS_FUNCTION:
2386 case GFC_SS_COMPONENT:
2387 loop->dimen = ss->data.info.dimen;
2395 if (loop->dimen == 0)
2396 gfc_todo_error ("Unable to determine rank of expression");
2399 /* Loop over all the SS in the chain. */
2400 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2402 if (ss->expr && ss->expr->shape && !ss->shape)
2403 ss->shape = ss->expr->shape;
2407 case GFC_SS_SECTION:
2408 /* Get the descriptor for the array. */
2409 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2411 for (n = 0; n < ss->data.info.dimen; n++)
2412 gfc_conv_section_startstride (loop, ss, n);
2415 case GFC_SS_CONSTRUCTOR:
2416 case GFC_SS_FUNCTION:
2417 for (n = 0; n < ss->data.info.dimen; n++)
2419 ss->data.info.start[n] = gfc_index_zero_node;
2420 ss->data.info.stride[n] = gfc_index_one_node;
2429 /* The rest is just runtime bound checking. */
2430 if (flag_bounds_check)
2436 tree size[GFC_MAX_DIMENSIONS];
2440 gfc_start_block (&block);
2442 fault = integer_zero_node;
2443 for (n = 0; n < loop->dimen; n++)
2444 size[n] = NULL_TREE;
2446 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2448 if (ss->type != GFC_SS_SECTION)
2451 /* TODO: range checking for mapped dimensions. */
2452 info = &ss->data.info;
2454 /* This code only checks ranges. Elemental and vector
2455 dimensions are checked later. */
2456 for (n = 0; n < loop->dimen; n++)
2459 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2462 desc = ss->data.info.descriptor;
2464 /* Check lower bound. */
2465 bound = gfc_conv_array_lbound (desc, dim);
2466 tmp = info->start[n];
2467 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2468 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2471 /* Check the upper bound. */
2472 bound = gfc_conv_array_ubound (desc, dim);
2473 end = gfc_conv_section_upper_bound (ss, n, &block);
2474 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2475 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2478 /* Check the section sizes match. */
2479 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2481 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2483 /* We remember the size of the first section, and check all the
2484 others against this. */
2488 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2490 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2493 size[n] = gfc_evaluate_now (tmp, &block);
2496 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2498 tmp = gfc_finish_block (&block);
2499 gfc_add_expr_to_block (&loop->pre, tmp);
2504 /* Return true if the two SS could be aliased, i.e. both point to the same data
2506 /* TODO: resolve aliases based on frontend expressions. */
2509 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2516 lsym = lss->expr->symtree->n.sym;
2517 rsym = rss->expr->symtree->n.sym;
2518 if (gfc_symbols_could_alias (lsym, rsym))
2521 if (rsym->ts.type != BT_DERIVED
2522 && lsym->ts.type != BT_DERIVED)
2525 /* For derived types we must check all the component types. We can ignore
2526 array references as these will have the same base type as the previous
2528 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2530 if (lref->type != REF_COMPONENT)
2533 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2536 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2539 if (rref->type != REF_COMPONENT)
2542 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2547 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2549 if (rref->type != REF_COMPONENT)
2552 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2560 /* Resolve array data dependencies. Creates a temporary if required. */
2561 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2565 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2575 loop->temp_ss = NULL;
2576 aref = dest->data.info.ref;
2579 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2581 if (ss->type != GFC_SS_SECTION)
2584 if (gfc_could_be_alias (dest, ss)
2585 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2591 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2593 lref = dest->expr->ref;
2594 rref = ss->expr->ref;
2596 nDepend = gfc_dep_resolver (lref, rref);
2598 /* TODO : loop shifting. */
2601 /* Mark the dimensions for LOOP SHIFTING */
2602 for (n = 0; n < loop->dimen; n++)
2604 int dim = dest->data.info.dim[n];
2606 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2608 else if (! gfc_is_same_range (&lref->u.ar,
2609 &rref->u.ar, dim, 0))
2613 /* Put all the dimensions with dependencies in the
2616 for (n = 0; n < loop->dimen; n++)
2618 gcc_assert (loop->order[n] == n);
2620 loop->order[dim++] = n;
2623 for (n = 0; n < loop->dimen; n++)
2626 loop->order[dim++] = n;
2629 gcc_assert (dim == loop->dimen);
2638 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2639 if (GFC_ARRAY_TYPE_P (base_type)
2640 || GFC_DESCRIPTOR_TYPE_P (base_type))
2641 base_type = gfc_get_element_type (base_type);
2642 loop->temp_ss = gfc_get_ss ();
2643 loop->temp_ss->type = GFC_SS_TEMP;
2644 loop->temp_ss->data.temp.type = base_type;
2645 loop->temp_ss->string_length = dest->string_length;
2646 loop->temp_ss->data.temp.dimen = loop->dimen;
2647 loop->temp_ss->next = gfc_ss_terminator;
2648 gfc_add_ss_to_loop (loop, loop->temp_ss);
2651 loop->temp_ss = NULL;
2655 /* Initialize the scalarization loop. Creates the loop variables. Determines
2656 the range of the loop variables. Creates a temporary if required.
2657 Calculates how to transform from loop variables to array indices for each
2658 expression. Also generates code for scalar expressions which have been
2659 moved outside the loop. */
2662 gfc_conv_loop_setup (gfc_loopinfo * loop)
2667 gfc_ss_info *specinfo;
2671 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2672 bool dynamic[GFC_MAX_DIMENSIONS];
2678 for (n = 0; n < loop->dimen; n++)
2682 /* We use one SS term, and use that to determine the bounds of the
2683 loop for this dimension. We try to pick the simplest term. */
2684 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2688 /* The frontend has worked out the size for us. */
2693 if (ss->type == GFC_SS_CONSTRUCTOR)
2695 /* An unknown size constructor will always be rank one.
2696 Higher rank constructors will either have known shape,
2697 or still be wrapped in a call to reshape. */
2698 gcc_assert (loop->dimen == 1);
2700 /* Always prefer to use the constructor bounds if the size
2701 can be determined at compile time. Prefer not to otherwise,
2702 since the general case involves realloc, and it's better to
2703 avoid that overhead if possible. */
2704 c = ss->expr->value.constructor;
2705 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2706 if (!dynamic[n] || !loopspec[n])
2711 /* TODO: Pick the best bound if we have a choice between a
2712 function and something else. */
2713 if (ss->type == GFC_SS_FUNCTION)
2719 if (ss->type != GFC_SS_SECTION)
2723 specinfo = &loopspec[n]->data.info;
2726 info = &ss->data.info;
2730 /* Criteria for choosing a loop specifier (most important first):
2731 doesn't need realloc
2737 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2739 else if (integer_onep (info->stride[n])
2740 && !integer_onep (specinfo->stride[n]))
2742 else if (INTEGER_CST_P (info->stride[n])
2743 && !INTEGER_CST_P (specinfo->stride[n]))
2745 else if (INTEGER_CST_P (info->start[n])
2746 && !INTEGER_CST_P (specinfo->start[n]))
2748 /* We don't work out the upper bound.
2749 else if (INTEGER_CST_P (info->finish[n])
2750 && ! INTEGER_CST_P (specinfo->finish[n]))
2751 loopspec[n] = ss; */
2755 gfc_todo_error ("Unable to find scalarization loop specifier");
2757 info = &loopspec[n]->data.info;
2759 /* Set the extents of this range. */
2760 cshape = loopspec[n]->shape;
2761 if (cshape && INTEGER_CST_P (info->start[n])
2762 && INTEGER_CST_P (info->stride[n]))
2764 loop->from[n] = info->start[n];
2765 mpz_set (i, cshape[n]);
2766 mpz_sub_ui (i, i, 1);
2767 /* To = from + (size - 1) * stride. */
2768 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2769 if (!integer_onep (info->stride[n]))
2770 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2771 tmp, info->stride[n]);
2772 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2773 loop->from[n], tmp);
2777 loop->from[n] = info->start[n];
2778 switch (loopspec[n]->type)
2780 case GFC_SS_CONSTRUCTOR:
2781 /* The upper bound is calculated when we expand the
2783 gcc_assert (loop->to[n] == NULL_TREE);
2786 case GFC_SS_SECTION:
2787 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2791 case GFC_SS_FUNCTION:
2792 /* The loop bound will be set when we generate the call. */
2793 gcc_assert (loop->to[n] == NULL_TREE);
2801 /* Transform everything so we have a simple incrementing variable. */
2802 if (integer_onep (info->stride[n]))
2803 info->delta[n] = gfc_index_zero_node;
2806 /* Set the delta for this section. */
2807 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2808 /* Number of iterations is (end - start + step) / step.
2809 with start = 0, this simplifies to
2811 for (i = 0; i<=last; i++){...}; */
2812 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2813 loop->to[n], loop->from[n]);
2814 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2815 tmp, info->stride[n]);
2816 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2817 /* Make the loop variable start at 0. */
2818 loop->from[n] = gfc_index_zero_node;
2822 /* Add all the scalar code that can be taken out of the loops.
2823 This may include calculating the loop bounds, so do it before
2824 allocating the temporary. */
2825 gfc_add_loop_ss_code (loop, loop->ss, false);
2827 /* If we want a temporary then create it. */
2828 if (loop->temp_ss != NULL)
2830 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2831 tmp = loop->temp_ss->data.temp.type;
2832 len = loop->temp_ss->string_length;
2833 n = loop->temp_ss->data.temp.dimen;
2834 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2835 loop->temp_ss->type = GFC_SS_SECTION;
2836 loop->temp_ss->data.info.dimen = n;
2837 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
2838 &loop->temp_ss->data.info, tmp, false,
2842 for (n = 0; n < loop->temp_dim; n++)
2843 loopspec[loop->order[n]] = NULL;
2847 /* For array parameters we don't have loop variables, so don't calculate the
2849 if (loop->array_parameter)
2852 /* Calculate the translation from loop variables to array indices. */
2853 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2855 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2858 info = &ss->data.info;
2860 for (n = 0; n < info->dimen; n++)
2864 /* If we are specifying the range the delta is already set. */
2865 if (loopspec[n] != ss)
2867 /* Calculate the offset relative to the loop variable.
2868 First multiply by the stride. */
2869 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2870 loop->from[n], info->stride[n]);
2872 /* Then subtract this from our starting value. */
2873 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2874 info->start[n], tmp);
2876 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2883 /* Fills in an array descriptor, and returns the size of the array. The size
2884 will be a simple_val, ie a variable or a constant. Also calculates the
2885 offset of the base. Returns the size of the array.
2889 for (n = 0; n < rank; n++)
2891 a.lbound[n] = specified_lower_bound;
2892 offset = offset + a.lbond[n] * stride;
2894 a.ubound[n] = specified_upper_bound;
2895 a.stride[n] = stride;
2896 size = ubound + size; //size = ubound + 1 - lbound
2897 stride = stride * size;
2904 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2905 gfc_expr ** lower, gfc_expr ** upper,
2906 stmtblock_t * pblock)
2917 type = TREE_TYPE (descriptor);
2919 stride = gfc_index_one_node;
2920 offset = gfc_index_zero_node;
2922 /* Set the dtype. */
2923 tmp = gfc_conv_descriptor_dtype (descriptor);
2924 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2926 for (n = 0; n < rank; n++)
2928 /* We have 3 possibilities for determining the size of the array:
2929 lower == NULL => lbound = 1, ubound = upper[n]
2930 upper[n] = NULL => lbound = 1, ubound = lower[n]
2931 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2934 /* Set lower bound. */
2935 gfc_init_se (&se, NULL);
2937 se.expr = gfc_index_one_node;
2940 gcc_assert (lower[n]);
2943 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2944 gfc_add_block_to_block (pblock, &se.pre);
2948 se.expr = gfc_index_one_node;
2952 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2953 gfc_add_modify_expr (pblock, tmp, se.expr);
2955 /* Work out the offset for this component. */
2956 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2957 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2959 /* Start the calculation for the size of this dimension. */
2960 size = build2 (MINUS_EXPR, gfc_array_index_type,
2961 gfc_index_one_node, se.expr);
2963 /* Set upper bound. */
2964 gfc_init_se (&se, NULL);
2965 gcc_assert (ubound);
2966 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2967 gfc_add_block_to_block (pblock, &se.pre);
2969 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2970 gfc_add_modify_expr (pblock, tmp, se.expr);
2972 /* Store the stride. */
2973 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2974 gfc_add_modify_expr (pblock, tmp, stride);
2976 /* Calculate the size of this dimension. */
2977 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2979 /* Multiply the stride by the number of elements in this dimension. */
2980 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2981 stride = gfc_evaluate_now (stride, pblock);
2984 /* The stride is the number of elements in the array, so multiply by the
2985 size of an element to get the total size. */
2986 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2987 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2989 if (poffset != NULL)
2991 offset = gfc_evaluate_now (offset, pblock);
2995 size = gfc_evaluate_now (size, pblock);
3000 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3001 the work for an ALLOCATE statement. */
3005 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3015 int allocatable_array;
3019 /* Find the last reference in the chain. */
3020 while (ref && ref->next != NULL)
3022 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3026 if (ref == NULL || ref->type != REF_ARRAY)
3029 /* Figure out the size of the array. */
3030 switch (ref->u.ar.type)
3034 upper = ref->u.ar.start;
3038 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3040 lower = ref->u.ar.as->lower;
3041 upper = ref->u.ar.as->upper;
3045 lower = ref->u.ar.start;
3046 upper = ref->u.ar.end;
3054 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3055 lower, upper, &se->pre);
3057 /* Allocate memory to store the data. */
3058 tmp = gfc_conv_descriptor_data_addr (se->expr);
3059 pointer = gfc_evaluate_now (tmp, &se->pre);
3061 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3063 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3065 if (allocatable_array)
3066 allocate = gfor_fndecl_allocate_array;
3068 allocate = gfor_fndecl_allocate;
3070 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3072 if (allocatable_array)
3073 allocate = gfor_fndecl_allocate64_array;
3075 allocate = gfor_fndecl_allocate64;
3080 tmp = gfc_chainon_list (NULL_TREE, pointer);
3081 tmp = gfc_chainon_list (tmp, size);
3082 tmp = gfc_chainon_list (tmp, pstat);
3083 tmp = build_function_call_expr (allocate, tmp);
3084 gfc_add_expr_to_block (&se->pre, tmp);
3086 tmp = gfc_conv_descriptor_offset (se->expr);
3087 gfc_add_modify_expr (&se->pre, tmp, offset);
3093 /* Deallocate an array variable. Also used when an allocated variable goes
3098 gfc_array_deallocate (tree descriptor, tree pstat)
3104 gfc_start_block (&block);
3105 /* Get a pointer to the data. */
3106 tmp = gfc_conv_descriptor_data_addr (descriptor);
3107 var = gfc_evaluate_now (tmp, &block);
3109 /* Parameter is the address of the data component. */
3110 tmp = gfc_chainon_list (NULL_TREE, var);
3111 tmp = gfc_chainon_list (tmp, pstat);
3112 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3113 gfc_add_expr_to_block (&block, tmp);
3115 return gfc_finish_block (&block);
3119 /* Create an array constructor from an initialization expression.
3120 We assume the frontend already did any expansions and conversions. */
3123 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3130 unsigned HOST_WIDE_INT lo;
3132 VEC(constructor_elt,gc) *v = NULL;
3134 switch (expr->expr_type)
3137 case EXPR_STRUCTURE:
3138 /* A single scalar or derived type value. Create an array with all
3139 elements equal to that value. */
3140 gfc_init_se (&se, NULL);
3142 if (expr->expr_type == EXPR_CONSTANT)
3143 gfc_conv_constant (&se, expr);
3145 gfc_conv_structure (&se, expr, 1);
3147 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3148 gcc_assert (tmp && INTEGER_CST_P (tmp));
3149 hi = TREE_INT_CST_HIGH (tmp);
3150 lo = TREE_INT_CST_LOW (tmp);
3154 /* This will probably eat buckets of memory for large arrays. */
3155 while (hi != 0 || lo != 0)
3157 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3165 /* Create a vector of all the elements. */
3166 for (c = expr->value.constructor; c; c = c->next)
3170 /* Problems occur when we get something like
3171 integer :: a(lots) = (/(i, i=1,lots)/) */
3172 /* TODO: Unexpanded array initializers. */
3174 ("Possible frontend bug: array constructor not expanded");
3176 if (mpz_cmp_si (c->n.offset, 0) != 0)
3177 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3181 if (mpz_cmp_si (c->repeat, 0) != 0)
3185 mpz_set (maxval, c->repeat);
3186 mpz_add (maxval, c->n.offset, maxval);
3187 mpz_sub_ui (maxval, maxval, 1);
3188 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3189 if (mpz_cmp_si (c->n.offset, 0) != 0)
3191 mpz_add_ui (maxval, c->n.offset, 1);
3192 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3195 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3197 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3203 gfc_init_se (&se, NULL);
3204 switch (c->expr->expr_type)
3207 gfc_conv_constant (&se, c->expr);
3208 if (range == NULL_TREE)
3209 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3212 if (index != NULL_TREE)
3213 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3214 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3218 case EXPR_STRUCTURE:
3219 gfc_conv_structure (&se, c->expr, 1);
3220 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3233 /* Create a constructor from the list of elements. */
3234 tmp = build_constructor (type, v);
3235 TREE_CONSTANT (tmp) = 1;
3236 TREE_INVARIANT (tmp) = 1;
3241 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3242 returns the size (in elements) of the array. */
3245 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3246 stmtblock_t * pblock)
3261 size = gfc_index_one_node;
3262 offset = gfc_index_zero_node;
3263 for (dim = 0; dim < as->rank; dim++)
3265 /* Evaluate non-constant array bound expressions. */
3266 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3267 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3269 gfc_init_se (&se, NULL);
3270 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3271 gfc_add_block_to_block (pblock, &se.pre);
3272 gfc_add_modify_expr (pblock, lbound, se.expr);
3274 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3275 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3277 gfc_init_se (&se, NULL);
3278 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3279 gfc_add_block_to_block (pblock, &se.pre);
3280 gfc_add_modify_expr (pblock, ubound, se.expr);
3282 /* The offset of this dimension. offset = offset - lbound * stride. */
3283 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3284 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3286 /* The size of this dimension, and the stride of the next. */
3287 if (dim + 1 < as->rank)
3288 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3290 stride = GFC_TYPE_ARRAY_SIZE (type);
3292 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3294 /* Calculate stride = size * (ubound + 1 - lbound). */
3295 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3296 gfc_index_one_node, lbound);
3297 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3298 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3300 gfc_add_modify_expr (pblock, stride, tmp);
3302 stride = gfc_evaluate_now (tmp, pblock);
3308 gfc_trans_vla_type_sizes (sym, pblock);
3315 /* Generate code to initialize/allocate an array variable. */
3318 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3328 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3330 /* Do nothing for USEd variables. */
3331 if (sym->attr.use_assoc)
3334 type = TREE_TYPE (decl);
3335 gcc_assert (GFC_ARRAY_TYPE_P (type));
3336 onstack = TREE_CODE (type) != POINTER_TYPE;
3338 gfc_start_block (&block);
3340 /* Evaluate character string length. */
3341 if (sym->ts.type == BT_CHARACTER
3342 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3344 gfc_trans_init_string_length (sym->ts.cl, &block);
3346 gfc_trans_vla_type_sizes (sym, &block);
3348 /* Emit a DECL_EXPR for this variable, which will cause the
3349 gimplifier to allocate storage, and all that good stuff. */
3350 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3351 gfc_add_expr_to_block (&block, tmp);
3356 gfc_add_expr_to_block (&block, fnbody);
3357 return gfc_finish_block (&block);
3360 type = TREE_TYPE (type);
3362 gcc_assert (!sym->attr.use_assoc);
3363 gcc_assert (!TREE_STATIC (decl));
3364 gcc_assert (!sym->module);
3366 if (sym->ts.type == BT_CHARACTER
3367 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3368 gfc_trans_init_string_length (sym->ts.cl, &block);
3370 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3372 /* Don't actually allocate space for Cray Pointees. */
3373 if (sym->attr.cray_pointee)
3375 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3376 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3377 gfc_add_expr_to_block (&block, fnbody);
3378 return gfc_finish_block (&block);
3381 /* The size is the number of elements in the array, so multiply by the
3382 size of an element to get the total size. */
3383 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3384 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3386 /* Allocate memory to hold the data. */
3387 tmp = gfc_chainon_list (NULL_TREE, size);
3389 if (gfc_index_integer_kind == 4)
3390 fndecl = gfor_fndecl_internal_malloc;
3391 else if (gfc_index_integer_kind == 8)
3392 fndecl = gfor_fndecl_internal_malloc64;
3395 tmp = build_function_call_expr (fndecl, tmp);
3396 tmp = fold (convert (TREE_TYPE (decl), tmp));
3397 gfc_add_modify_expr (&block, decl, tmp);
3399 /* Set offset of the array. */
3400 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3401 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3404 /* Automatic arrays should not have initializers. */
3405 gcc_assert (!sym->value);
3407 gfc_add_expr_to_block (&block, fnbody);
3409 /* Free the temporary. */
3410 tmp = convert (pvoid_type_node, decl);
3411 tmp = gfc_chainon_list (NULL_TREE, tmp);
3412 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3413 gfc_add_expr_to_block (&block, tmp);
3415 return gfc_finish_block (&block);
3419 /* Generate entry and exit code for g77 calling convention arrays. */
3422 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3431 gfc_get_backend_locus (&loc);
3432 gfc_set_backend_locus (&sym->declared_at);
3434 /* Descriptor type. */
3435 parm = sym->backend_decl;
3436 type = TREE_TYPE (parm);
3437 gcc_assert (GFC_ARRAY_TYPE_P (type));
3439 gfc_start_block (&block);
3441 if (sym->ts.type == BT_CHARACTER
3442 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3443 gfc_trans_init_string_length (sym->ts.cl, &block);
3445 /* Evaluate the bounds of the array. */
3446 gfc_trans_array_bounds (type, sym, &offset, &block);
3448 /* Set the offset. */
3449 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3450 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3452 /* Set the pointer itself if we aren't using the parameter directly. */
3453 if (TREE_CODE (parm) != PARM_DECL)
3455 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3456 gfc_add_modify_expr (&block, parm, tmp);
3458 tmp = gfc_finish_block (&block);
3460 gfc_set_backend_locus (&loc);
3462 gfc_start_block (&block);
3463 /* Add the initialization code to the start of the function. */
3464 gfc_add_expr_to_block (&block, tmp);
3465 gfc_add_expr_to_block (&block, body);
3467 return gfc_finish_block (&block);
3471 /* Modify the descriptor of an array parameter so that it has the
3472 correct lower bound. Also move the upper bound accordingly.
3473 If the array is not packed, it will be copied into a temporary.
3474 For each dimension we set the new lower and upper bounds. Then we copy the
3475 stride and calculate the offset for this dimension. We also work out
3476 what the stride of a packed array would be, and see it the two match.
3477 If the array need repacking, we set the stride to the values we just
3478 calculated, recalculate the offset and copy the array data.
3479 Code is also added to copy the data back at the end of the function.
3483 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3490 stmtblock_t cleanup;
3508 /* Do nothing for pointer and allocatable arrays. */
3509 if (sym->attr.pointer || sym->attr.allocatable)
3512 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3513 return gfc_trans_g77_array (sym, body);
3515 gfc_get_backend_locus (&loc);
3516 gfc_set_backend_locus (&sym->declared_at);
3518 /* Descriptor type. */
3519 type = TREE_TYPE (tmpdesc);
3520 gcc_assert (GFC_ARRAY_TYPE_P (type));
3521 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3522 dumdesc = build_fold_indirect_ref (dumdesc);
3523 gfc_start_block (&block);
3525 if (sym->ts.type == BT_CHARACTER
3526 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3527 gfc_trans_init_string_length (sym->ts.cl, &block);
3529 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3531 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3532 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3534 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3536 /* For non-constant shape arrays we only check if the first dimension
3537 is contiguous. Repacking higher dimensions wouldn't gain us
3538 anything as we still don't know the array stride. */
3539 partial = gfc_create_var (boolean_type_node, "partial");
3540 TREE_USED (partial) = 1;
3541 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3542 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3543 gfc_add_modify_expr (&block, partial, tmp);
3547 partial = NULL_TREE;
3550 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3551 here, however I think it does the right thing. */
3554 /* Set the first stride. */
3555 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3556 stride = gfc_evaluate_now (stride, &block);
3558 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3559 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3560 gfc_index_one_node, stride);
3561 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3562 gfc_add_modify_expr (&block, stride, tmp);
3564 /* Allow the user to disable array repacking. */
3565 stmt_unpacked = NULL_TREE;
3569 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3570 /* A library call to repack the array if necessary. */
3571 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3572 tmp = gfc_chainon_list (NULL_TREE, tmp);
3573 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
3575 stride = gfc_index_one_node;
3578 /* This is for the case where the array data is used directly without
3579 calling the repack function. */
3580 if (no_repack || partial != NULL_TREE)
3581 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3583 stmt_packed = NULL_TREE;
3585 /* Assign the data pointer. */
3586 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3588 /* Don't repack unknown shape arrays when the first stride is 1. */
3589 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3590 stmt_packed, stmt_unpacked);
3593 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3594 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3596 offset = gfc_index_zero_node;
3597 size = gfc_index_one_node;
3599 /* Evaluate the bounds of the array. */
3600 for (n = 0; n < sym->as->rank; n++)
3602 if (checkparm || !sym->as->upper[n])
3604 /* Get the bounds of the actual parameter. */
3605 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3606 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3610 dubound = NULL_TREE;
3611 dlbound = NULL_TREE;
3614 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3615 if (!INTEGER_CST_P (lbound))
3617 gfc_init_se (&se, NULL);
3618 gfc_conv_expr_type (&se, sym->as->lower[n],
3619 gfc_array_index_type);
3620 gfc_add_block_to_block (&block, &se.pre);
3621 gfc_add_modify_expr (&block, lbound, se.expr);
3624 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3625 /* Set the desired upper bound. */
3626 if (sym->as->upper[n])
3628 /* We know what we want the upper bound to be. */
3629 if (!INTEGER_CST_P (ubound))
3631 gfc_init_se (&se, NULL);
3632 gfc_conv_expr_type (&se, sym->as->upper[n],
3633 gfc_array_index_type);
3634 gfc_add_block_to_block (&block, &se.pre);
3635 gfc_add_modify_expr (&block, ubound, se.expr);
3638 /* Check the sizes match. */
3641 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3643 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3645 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3647 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3648 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3653 /* For assumed shape arrays move the upper bound by the same amount
3654 as the lower bound. */
3655 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3656 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3657 gfc_add_modify_expr (&block, ubound, tmp);
3659 /* The offset of this dimension. offset = offset - lbound * stride. */
3660 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3661 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3663 /* The size of this dimension, and the stride of the next. */
3664 if (n + 1 < sym->as->rank)
3666 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3668 if (no_repack || partial != NULL_TREE)
3671 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3674 /* Figure out the stride if not a known constant. */
3675 if (!INTEGER_CST_P (stride))
3678 stmt_packed = NULL_TREE;
3681 /* Calculate stride = size * (ubound + 1 - lbound). */
3682 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3683 gfc_index_one_node, lbound);
3684 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3686 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3691 /* Assign the stride. */
3692 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3693 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3694 stmt_unpacked, stmt_packed);
3696 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3697 gfc_add_modify_expr (&block, stride, tmp);
3702 stride = GFC_TYPE_ARRAY_SIZE (type);
3704 if (stride && !INTEGER_CST_P (stride))
3706 /* Calculate size = stride * (ubound + 1 - lbound). */
3707 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3708 gfc_index_one_node, lbound);
3709 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3711 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3712 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
3713 gfc_add_modify_expr (&block, stride, tmp);
3718 /* Set the offset. */
3719 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3720 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3722 gfc_trans_vla_type_sizes (sym, &block);
3724 stmt = gfc_finish_block (&block);
3726 gfc_start_block (&block);
3728 /* Only do the entry/initialization code if the arg is present. */
3729 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3730 optional_arg = (sym->attr.optional
3731 || (sym->ns->proc_name->attr.entry_master
3732 && sym->attr.dummy));
3735 tmp = gfc_conv_expr_present (sym);
3736 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3738 gfc_add_expr_to_block (&block, stmt);
3740 /* Add the main function body. */
3741 gfc_add_expr_to_block (&block, body);
3746 gfc_start_block (&cleanup);
3748 if (sym->attr.intent != INTENT_IN)
3750 /* Copy the data back. */
3751 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3752 tmp = gfc_chainon_list (tmp, tmpdesc);
3753 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
3754 gfc_add_expr_to_block (&cleanup, tmp);
3757 /* Free the temporary. */
3758 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3759 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3760 gfc_add_expr_to_block (&cleanup, tmp);
3762 stmt = gfc_finish_block (&cleanup);
3764 /* Only do the cleanup if the array was repacked. */
3765 tmp = build_fold_indirect_ref (dumdesc);
3766 tmp = gfc_conv_descriptor_data_get (tmp);
3767 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3768 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3772 tmp = gfc_conv_expr_present (sym);
3773 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3775 gfc_add_expr_to_block (&block, stmt);
3777 /* We don't need to free any memory allocated by internal_pack as it will
3778 be freed at the end of the function by pop_context. */
3779 return gfc_finish_block (&block);
3783 /* Convert an array for passing as an actual argument. Expressions and
3784 vector subscripts are evaluated and stored in a temporary, which is then
3785 passed. For whole arrays the descriptor is passed. For array sections
3786 a modified copy of the descriptor is passed, but using the original data.
3788 This function is also used for array pointer assignments, and there
3791 - want_pointer && !se->direct_byref
3792 EXPR is an actual argument. On exit, se->expr contains a
3793 pointer to the array descriptor.
3795 - !want_pointer && !se->direct_byref
3796 EXPR is an actual argument to an intrinsic function or the
3797 left-hand side of a pointer assignment. On exit, se->expr
3798 contains the descriptor for EXPR.
3800 - !want_pointer && se->direct_byref
3801 EXPR is the right-hand side of a pointer assignment and
3802 se->expr is the descriptor for the previously-evaluated
3803 left-hand side. The function creates an assignment from
3804 EXPR to se->expr. */
3807 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3822 gcc_assert (ss != gfc_ss_terminator);
3824 /* TODO: Pass constant array constructors without a temporary. */
3825 /* Special case things we know we can pass easily. */
3826 switch (expr->expr_type)
3829 /* If we have a linear array section, we can pass it directly.
3830 Otherwise we need to copy it into a temporary. */
3832 /* Find the SS for the array section. */
3834 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3835 secss = secss->next;
3837 gcc_assert (secss != gfc_ss_terminator);
3838 info = &secss->data.info;
3840 /* Get the descriptor for the array. */
3841 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3842 desc = info->descriptor;
3844 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
3847 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3849 /* Create a new descriptor if the array doesn't have one. */
3852 else if (info->ref->u.ar.type == AR_FULL)
3854 else if (se->direct_byref)
3859 gcc_assert (ref->u.ar.type == AR_SECTION);
3862 for (n = 0; n < ref->u.ar.dimen; n++)
3864 /* Detect passing the full array as a section. This could do
3865 even more checking, but it doesn't seem worth it. */
3866 if (ref->u.ar.start[n]
3868 || (ref->u.ar.stride[n]
3869 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3879 if (se->direct_byref)
3881 /* Copy the descriptor for pointer assignments. */
3882 gfc_add_modify_expr (&se->pre, se->expr, desc);
3884 else if (se->want_pointer)
3886 /* We pass full arrays directly. This means that pointers and
3887 allocatable arrays should also work. */
3888 se->expr = build_fold_addr_expr (desc);
3895 if (expr->ts.type == BT_CHARACTER)
3896 se->string_length = gfc_get_expr_charlen (expr);
3903 /* A transformational function return value will be a temporary
3904 array descriptor. We still need to go through the scalarizer
3905 to create the descriptor. Elemental functions ar handled as
3906 arbitrary expressions, i.e. copy to a temporary. */
3908 /* Look for the SS for this function. */
3909 while (secss != gfc_ss_terminator
3910 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3911 secss = secss->next;
3913 if (se->direct_byref)
3915 gcc_assert (secss != gfc_ss_terminator);
3917 /* For pointer assignments pass the descriptor directly. */
3919 se->expr = build_fold_addr_expr (se->expr);
3920 gfc_conv_expr (se, expr);
3924 if (secss == gfc_ss_terminator)
3926 /* Elemental function. */
3932 /* Transformational function. */
3933 info = &secss->data.info;
3939 /* Something complicated. Copy it into a temporary. */
3947 gfc_init_loopinfo (&loop);
3949 /* Associate the SS with the loop. */
3950 gfc_add_ss_to_loop (&loop, ss);
3952 /* Tell the scalarizer not to bother creating loop variables, etc. */
3954 loop.array_parameter = 1;
3956 /* The right-hand side of a pointer assignment mustn't use a temporary. */
3957 gcc_assert (!se->direct_byref);
3959 /* Setup the scalarizing loops and bounds. */
3960 gfc_conv_ss_startstride (&loop);
3964 /* Tell the scalarizer to make a temporary. */
3965 loop.temp_ss = gfc_get_ss ();
3966 loop.temp_ss->type = GFC_SS_TEMP;
3967 loop.temp_ss->next = gfc_ss_terminator;
3968 if (expr->ts.type == BT_CHARACTER)
3970 gcc_assert (expr->ts.cl && expr->ts.cl->length
3971 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3972 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3973 (expr->ts.cl->length->value.integer,
3974 expr->ts.cl->length->ts.kind);
3975 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3977 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3979 /* ... which can hold our string, if present. */
3980 if (expr->ts.type == BT_CHARACTER)
3982 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3983 se->string_length = loop.temp_ss->string_length;
3986 loop.temp_ss->string_length = NULL;
3987 loop.temp_ss->data.temp.dimen = loop.dimen;
3988 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3991 gfc_conv_loop_setup (&loop);
3995 /* Copy into a temporary and pass that. We don't need to copy the data
3996 back because expressions and vector subscripts must be INTENT_IN. */
3997 /* TODO: Optimize passing function return values. */
4001 /* Start the copying loops. */
4002 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4003 gfc_mark_ss_chain_used (ss, 1);
4004 gfc_start_scalarized_body (&loop, &block);
4006 /* Copy each data element. */
4007 gfc_init_se (&lse, NULL);
4008 gfc_copy_loopinfo_to_se (&lse, &loop);
4009 gfc_init_se (&rse, NULL);
4010 gfc_copy_loopinfo_to_se (&rse, &loop);
4012 lse.ss = loop.temp_ss;
4015 gfc_conv_scalarized_array_ref (&lse, NULL);
4016 if (expr->ts.type == BT_CHARACTER)
4018 gfc_conv_expr (&rse, expr);
4019 rse.expr = build_fold_indirect_ref (rse.expr);
4022 gfc_conv_expr_val (&rse, expr);
4024 gfc_add_block_to_block (&block, &rse.pre);
4025 gfc_add_block_to_block (&block, &lse.pre);
4027 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4029 /* Finish the copying loops. */
4030 gfc_trans_scalarizing_loops (&loop, &block);
4032 /* Set the first stride component to zero to indicate a temporary. */
4033 desc = loop.temp_ss->data.info.descriptor;
4034 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
4035 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4037 gcc_assert (is_gimple_lvalue (desc));
4039 else if (expr->expr_type == EXPR_FUNCTION)
4041 desc = info->descriptor;
4042 se->string_length = ss->string_length;
4046 /* We pass sections without copying to a temporary. Make a new
4047 descriptor and point it at the section we want. The loop variable
4048 limits will be the limits of the section.
4049 A function may decide to repack the array to speed up access, but
4050 we're not bothered about that here. */
4059 /* Set the string_length for a character array. */
4060 if (expr->ts.type == BT_CHARACTER)
4061 se->string_length = gfc_get_expr_charlen (expr);
4063 desc = info->descriptor;
4064 gcc_assert (secss && secss != gfc_ss_terminator);
4065 if (se->direct_byref)
4067 /* For pointer assignments we fill in the destination. */
4069 parmtype = TREE_TYPE (parm);
4073 /* Otherwise make a new one. */
4074 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4075 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4076 loop.from, loop.to, 0);
4077 parm = gfc_create_var (parmtype, "parm");
4080 offset = gfc_index_zero_node;
4083 /* The following can be somewhat confusing. We have two
4084 descriptors, a new one and the original array.
4085 {parm, parmtype, dim} refer to the new one.
4086 {desc, type, n, secss, loop} refer to the original, which maybe
4087 a descriptorless array.
4088 The bounds of the scalarization are the bounds of the section.
4089 We don't have to worry about numeric overflows when calculating
4090 the offsets because all elements are within the array data. */
4092 /* Set the dtype. */
4093 tmp = gfc_conv_descriptor_dtype (parm);
4094 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4096 if (se->direct_byref)
4097 base = gfc_index_zero_node;
4101 for (n = 0; n < info->ref->u.ar.dimen; n++)
4103 stride = gfc_conv_array_stride (desc, n);
4105 /* Work out the offset. */
4106 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4108 gcc_assert (info->subscript[n]
4109 && info->subscript[n]->type == GFC_SS_SCALAR);
4110 start = info->subscript[n]->data.scalar.expr;
4114 /* Check we haven't somehow got out of sync. */
4115 gcc_assert (info->dim[dim] == n);
4117 /* Evaluate and remember the start of the section. */
4118 start = info->start[dim];
4119 stride = gfc_evaluate_now (stride, &loop.pre);
4122 tmp = gfc_conv_array_lbound (desc, n);
4123 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4125 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4126 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4128 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4130 /* For elemental dimensions, we only need the offset. */
4134 /* Vector subscripts need copying and are handled elsewhere. */
4135 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4137 /* Set the new lower bound. */
4138 from = loop.from[dim];
4141 /* If we have an array section or are assigning to a pointer,
4142 make sure that the lower bound is 1. References to the full
4143 array should otherwise keep the original bounds. */
4144 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4145 && !integer_onep (from))
4147 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4148 gfc_index_one_node, from);
4149 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4150 from = gfc_index_one_node;
4152 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4153 gfc_add_modify_expr (&loop.pre, tmp, from);
4155 /* Set the new upper bound. */
4156 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4157 gfc_add_modify_expr (&loop.pre, tmp, to);
4159 /* Multiply the stride by the section stride to get the
4161 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4162 stride, info->stride[dim]);
4164 if (se->direct_byref)
4165 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4168 /* Store the new stride. */
4169 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4170 gfc_add_modify_expr (&loop.pre, tmp, stride);
4175 /* Point the data pointer at the first element in the section. */
4176 tmp = gfc_conv_array_data (desc);
4177 tmp = build_fold_indirect_ref (tmp);
4178 tmp = gfc_build_array_ref (tmp, offset);
4179 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4180 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4182 if (se->direct_byref)
4184 /* Set the offset. */
4185 tmp = gfc_conv_descriptor_offset (parm);
4186 gfc_add_modify_expr (&loop.pre, tmp, base);
4190 /* Only the callee knows what the correct offset it, so just set
4192 tmp = gfc_conv_descriptor_offset (parm);
4193 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4198 if (!se->direct_byref)
4200 /* Get a pointer to the new descriptor. */
4201 if (se->want_pointer)
4202 se->expr = build_fold_addr_expr (desc);
4207 gfc_add_block_to_block (&se->pre, &loop.pre);
4208 gfc_add_block_to_block (&se->post, &loop.post);
4210 /* Cleanup the scalarizer. */
4211 gfc_cleanup_loop (&loop);
4215 /* Convert an array for passing as an actual parameter. */
4216 /* TODO: Optimize passing g77 arrays. */
4219 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4228 /* Passing address of the array if it is not pointer or assumed-shape. */
4229 if (expr->expr_type == EXPR_VARIABLE
4230 && expr->ref->u.ar.type == AR_FULL && g77)
4232 sym = expr->symtree->n.sym;
4233 tmp = gfc_get_symbol_decl (sym);
4235 if (sym->ts.type == BT_CHARACTER)
4236 se->string_length = sym->ts.cl->backend_decl;
4237 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4238 && !sym->attr.allocatable)
4240 /* Some variables are declared directly, others are declared as
4241 pointers and allocated on the heap. */
4242 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4245 se->expr = build_fold_addr_expr (tmp);
4248 if (sym->attr.allocatable)
4250 se->expr = gfc_conv_array_data (tmp);
4255 se->want_pointer = 1;
4256 gfc_conv_expr_descriptor (se, expr, ss);
4261 /* Repack the array. */
4262 tmp = gfc_chainon_list (NULL_TREE, desc);
4263 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4264 ptr = gfc_evaluate_now (ptr, &se->pre);
4267 gfc_start_block (&block);
4269 /* Copy the data back. */
4270 tmp = gfc_chainon_list (NULL_TREE, desc);
4271 tmp = gfc_chainon_list (tmp, ptr);
4272 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4273 gfc_add_expr_to_block (&block, tmp);
4275 /* Free the temporary. */
4276 tmp = convert (pvoid_type_node, ptr);
4277 tmp = gfc_chainon_list (NULL_TREE, tmp);
4278 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4279 gfc_add_expr_to_block (&block, tmp);
4281 stmt = gfc_finish_block (&block);
4283 gfc_init_block (&block);
4284 /* Only if it was repacked. This code needs to be executed before the
4285 loop cleanup code. */
4286 tmp = build_fold_indirect_ref (desc);
4287 tmp = gfc_conv_array_data (tmp);
4288 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4289 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4291 gfc_add_expr_to_block (&block, tmp);
4292 gfc_add_block_to_block (&block, &se->post);
4294 gfc_init_block (&se->post);
4295 gfc_add_block_to_block (&se->post, &block);
4300 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4303 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4310 stmtblock_t fnblock;
4313 /* Make sure the frontend gets these right. */
4314 if (!(sym->attr.pointer || sym->attr.allocatable))
4316 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4318 gfc_init_block (&fnblock);
4320 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4321 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4323 if (sym->ts.type == BT_CHARACTER
4324 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4326 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4327 gfc_trans_vla_type_sizes (sym, &fnblock);
4330 /* Dummy and use associated variables don't need anything special. */
4331 if (sym->attr.dummy || sym->attr.use_assoc)
4333 gfc_add_expr_to_block (&fnblock, body);
4335 return gfc_finish_block (&fnblock);
4338 gfc_get_backend_locus (&loc);
4339 gfc_set_backend_locus (&sym->declared_at);
4340 descriptor = sym->backend_decl;
4342 if (TREE_STATIC (descriptor))
4344 /* SAVEd variables are not freed on exit. */
4345 gfc_trans_static_array_pointer (sym);
4349 /* Get the descriptor type. */
4350 type = TREE_TYPE (sym->backend_decl);
4351 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4353 /* NULLIFY the data pointer. */
4354 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4356 gfc_add_expr_to_block (&fnblock, body);
4358 gfc_set_backend_locus (&loc);
4359 /* Allocatable arrays need to be freed when they go out of scope. */
4360 if (sym->attr.allocatable)
4362 gfc_start_block (&block);
4364 /* Deallocate if still allocated at the end of the procedure. */
4365 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4367 tmp = gfc_conv_descriptor_data_get (descriptor);
4368 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4369 build_int_cst (TREE_TYPE (tmp), 0));
4370 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4371 gfc_add_expr_to_block (&block, tmp);
4373 tmp = gfc_finish_block (&block);
4374 gfc_add_expr_to_block (&fnblock, tmp);
4377 return gfc_finish_block (&fnblock);
4380 /************ Expression Walking Functions ******************/
4382 /* Walk a variable reference.
4384 Possible extension - multiple component subscripts.
4385 x(:,:) = foo%a(:)%b(:)
4387 forall (i=..., j=...)
4388 x(i,j) = foo%a(j)%b(i)
4390 This adds a fair amout of complexity because you need to deal with more
4391 than one ref. Maybe handle in a similar manner to vector subscripts.
4392 Maybe not worth the effort. */
4396 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4404 for (ref = expr->ref; ref; ref = ref->next)
4405 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4408 for (; ref; ref = ref->next)
4410 if (ref->type == REF_SUBSTRING)
4412 newss = gfc_get_ss ();
4413 newss->type = GFC_SS_SCALAR;
4414 newss->expr = ref->u.ss.start;
4418 newss = gfc_get_ss ();
4419 newss->type = GFC_SS_SCALAR;
4420 newss->expr = ref->u.ss.end;
4425 /* We're only interested in array sections from now on. */
4426 if (ref->type != REF_ARRAY)
4433 for (n = 0; n < ar->dimen; n++)
4435 newss = gfc_get_ss ();
4436 newss->type = GFC_SS_SCALAR;
4437 newss->expr = ar->start[n];
4444 newss = gfc_get_ss ();
4445 newss->type = GFC_SS_SECTION;
4448 newss->data.info.dimen = ar->as->rank;
4449 newss->data.info.ref = ref;
4451 /* Make sure array is the same as array(:,:), this way
4452 we don't need to special case all the time. */
4453 ar->dimen = ar->as->rank;
4454 for (n = 0; n < ar->dimen; n++)
4456 newss->data.info.dim[n] = n;
4457 ar->dimen_type[n] = DIMEN_RANGE;
4459 gcc_assert (ar->start[n] == NULL);
4460 gcc_assert (ar->end[n] == NULL);
4461 gcc_assert (ar->stride[n] == NULL);
4467 newss = gfc_get_ss ();
4468 newss->type = GFC_SS_SECTION;
4471 newss->data.info.dimen = 0;
4472 newss->data.info.ref = ref;
4476 /* We add SS chains for all the subscripts in the section. */
4477 for (n = 0; n < ar->dimen; n++)
4481 switch (ar->dimen_type[n])
4484 /* Add SS for elemental (scalar) subscripts. */
4485 gcc_assert (ar->start[n]);
4486 indexss = gfc_get_ss ();
4487 indexss->type = GFC_SS_SCALAR;
4488 indexss->expr = ar->start[n];
4489 indexss->next = gfc_ss_terminator;
4490 indexss->loop_chain = gfc_ss_terminator;
4491 newss->data.info.subscript[n] = indexss;
4495 /* We don't add anything for sections, just remember this
4496 dimension for later. */
4497 newss->data.info.dim[newss->data.info.dimen] = n;
4498 newss->data.info.dimen++;
4502 /* Create a GFC_SS_VECTOR index in which we can store
4503 the vector's descriptor. */
4504 indexss = gfc_get_ss ();
4505 indexss->type = GFC_SS_VECTOR;
4506 indexss->expr = ar->start[n];
4507 indexss->next = gfc_ss_terminator;
4508 indexss->loop_chain = gfc_ss_terminator;
4509 newss->data.info.subscript[n] = indexss;
4510 newss->data.info.dim[newss->data.info.dimen] = n;
4511 newss->data.info.dimen++;
4515 /* We should know what sort of section it is by now. */
4519 /* We should have at least one non-elemental dimension. */
4520 gcc_assert (newss->data.info.dimen > 0);
4525 /* We should know what sort of section it is by now. */
4534 /* Walk an expression operator. If only one operand of a binary expression is
4535 scalar, we must also add the scalar term to the SS chain. */
4538 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4544 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4545 if (expr->value.op.op2 == NULL)
4548 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4550 /* All operands are scalar. Pass back and let the caller deal with it. */
4554 /* All operands require scalarization. */
4555 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4558 /* One of the operands needs scalarization, the other is scalar.
4559 Create a gfc_ss for the scalar expression. */
4560 newss = gfc_get_ss ();
4561 newss->type = GFC_SS_SCALAR;
4564 /* First operand is scalar. We build the chain in reverse order, so
4565 add the scarar SS after the second operand. */
4567 while (head && head->next != ss)
4569 /* Check we haven't somehow broken the chain. */
4573 newss->expr = expr->value.op.op1;
4575 else /* head2 == head */
4577 gcc_assert (head2 == head);
4578 /* Second operand is scalar. */
4579 newss->next = head2;
4581 newss->expr = expr->value.op.op2;
4588 /* Reverse a SS chain. */
4591 gfc_reverse_ss (gfc_ss * ss)
4596 gcc_assert (ss != NULL);
4598 head = gfc_ss_terminator;
4599 while (ss != gfc_ss_terminator)
4602 /* Check we didn't somehow break the chain. */
4603 gcc_assert (next != NULL);
4613 /* Walk the arguments of an elemental function. */
4616 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
4624 head = gfc_ss_terminator;
4627 for (; arg; arg = arg->next)
4632 newss = gfc_walk_subexpr (head, arg->expr);
4635 /* Scalar argument. */
4636 newss = gfc_get_ss ();
4638 newss->expr = arg->expr;
4648 while (tail->next != gfc_ss_terminator)
4655 /* If all the arguments are scalar we don't need the argument SS. */
4656 gfc_free_ss_chain (head);
4661 /* Add it onto the existing chain. */
4667 /* Walk a function call. Scalar functions are passed back, and taken out of
4668 scalarization loops. For elemental functions we walk their arguments.
4669 The result of functions returning arrays is stored in a temporary outside
4670 the loop, so that the function is only called once. Hence we do not need
4671 to walk their arguments. */
4674 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4677 gfc_intrinsic_sym *isym;
4680 isym = expr->value.function.isym;
4682 /* Handle intrinsic functions separately. */
4684 return gfc_walk_intrinsic_function (ss, expr, isym);
4686 sym = expr->value.function.esym;
4688 sym = expr->symtree->n.sym;
4690 /* A function that returns arrays. */
4691 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4693 newss = gfc_get_ss ();
4694 newss->type = GFC_SS_FUNCTION;
4697 newss->data.info.dimen = expr->rank;
4701 /* Walk the parameters of an elemental function. For now we always pass
4703 if (sym->attr.elemental)
4704 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
4707 /* Scalar functions are OK as these are evaluated outside the scalarization
4708 loop. Pass back and let the caller deal with it. */
4713 /* An array temporary is constructed for array constructors. */
4716 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4721 newss = gfc_get_ss ();
4722 newss->type = GFC_SS_CONSTRUCTOR;
4725 newss->data.info.dimen = expr->rank;
4726 for (n = 0; n < expr->rank; n++)
4727 newss->data.info.dim[n] = n;
4733 /* Walk an expression. Add walked expressions to the head of the SS chain.
4734 A wholly scalar expression will not be added. */
4737 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4741 switch (expr->expr_type)
4744 head = gfc_walk_variable_expr (ss, expr);
4748 head = gfc_walk_op_expr (ss, expr);
4752 head = gfc_walk_function_expr (ss, expr);
4757 case EXPR_STRUCTURE:
4758 /* Pass back and let the caller deal with it. */
4762 head = gfc_walk_array_constructor (ss, expr);
4765 case EXPR_SUBSTRING:
4766 /* Pass back and let the caller deal with it. */
4770 internal_error ("bad expression type during walk (%d)",
4777 /* Entry point for expression walking.
4778 A return value equal to the passed chain means this is
4779 a scalar expression. It is up to the caller to take whatever action is
4780 necessary to translate these. */
4783 gfc_walk_expr (gfc_expr * expr)
4787 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4788 return gfc_reverse_ss (res);