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 so that the
483 callee will allocate the array. Also generates code to free the array
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,
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);
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 and DYNAMIC are as for gfc_trans_allocate_array_storage. */
571 gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
572 gfc_loopinfo * loop, gfc_ss_info * info,
573 tree eltype, bool dynamic)
583 gcc_assert (info->dimen > 0);
584 /* Set the lower bound to zero. */
585 for (dim = 0; dim < info->dimen; dim++)
587 n = loop->order[dim];
588 if (n < loop->temp_dim)
589 gcc_assert (integer_zerop (loop->from[n]));
592 /* Callee allocated arrays may not have a known bound yet. */
594 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
595 loop->to[n], loop->from[n]);
596 loop->from[n] = gfc_index_zero_node;
599 info->delta[dim] = gfc_index_zero_node;
600 info->start[dim] = gfc_index_zero_node;
601 info->stride[dim] = gfc_index_one_node;
602 info->dim[dim] = dim;
605 /* Initialize the descriptor. */
607 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
608 desc = gfc_create_var (type, "atmp");
609 GFC_DECL_PACKED_ARRAY (desc) = 1;
611 info->descriptor = desc;
612 size = gfc_index_one_node;
614 /* Fill in the array dtype. */
615 tmp = gfc_conv_descriptor_dtype (desc);
616 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
619 Fill in the bounds and stride. This is a packed array, so:
622 for (n = 0; n < rank; n++)
625 delta = ubound[n] + 1 - lbound[n];
628 size = size * sizeof(element);
631 for (n = 0; n < info->dimen; n++)
633 if (loop->to[n] == NULL_TREE)
635 /* For a callee allocated array express the loop bounds in terms
636 of the descriptor fields. */
637 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
638 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
639 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
645 /* Store the stride and bound components in the descriptor. */
646 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
647 gfc_add_modify_expr (pre, tmp, size);
649 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
650 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
652 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
653 gfc_add_modify_expr (pre, tmp, loop->to[n]);
655 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
656 loop->to[n], gfc_index_one_node);
658 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
659 size = gfc_evaluate_now (size, pre);
662 /* Get the size of the array. */
665 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
666 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
668 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
670 if (info->dimen > loop->temp_dim)
671 loop->temp_dim = info->dimen;
677 /* Generate code to transpose array EXPR by creating a new descriptor
678 in which the dimension specifications have been reversed. */
681 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
683 tree dest, src, dest_index, src_index;
685 gfc_ss_info *dest_info, *src_info;
686 gfc_ss *dest_ss, *src_ss;
692 src_ss = gfc_walk_expr (expr);
695 src_info = &src_ss->data.info;
696 dest_info = &dest_ss->data.info;
698 /* Get a descriptor for EXPR. */
699 gfc_init_se (&src_se, NULL);
700 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
701 gfc_add_block_to_block (&se->pre, &src_se.pre);
702 gfc_add_block_to_block (&se->post, &src_se.post);
705 /* Allocate a new descriptor for the return value. */
706 dest = gfc_create_var (TREE_TYPE (src), "atmp");
707 dest_info->descriptor = dest;
710 /* Copy across the dtype field. */
711 gfc_add_modify_expr (&se->pre,
712 gfc_conv_descriptor_dtype (dest),
713 gfc_conv_descriptor_dtype (src));
715 /* Copy the dimension information, renumbering dimension 1 to 0 and
717 gcc_assert (dest_info->dimen == 2);
718 gcc_assert (src_info->dimen == 2);
719 for (n = 0; n < 2; n++)
721 dest_info->delta[n] = integer_zero_node;
722 dest_info->start[n] = integer_zero_node;
723 dest_info->stride[n] = integer_one_node;
724 dest_info->dim[n] = n;
726 dest_index = gfc_rank_cst[n];
727 src_index = gfc_rank_cst[1 - n];
729 gfc_add_modify_expr (&se->pre,
730 gfc_conv_descriptor_stride (dest, dest_index),
731 gfc_conv_descriptor_stride (src, src_index));
733 gfc_add_modify_expr (&se->pre,
734 gfc_conv_descriptor_lbound (dest, dest_index),
735 gfc_conv_descriptor_lbound (src, src_index));
737 gfc_add_modify_expr (&se->pre,
738 gfc_conv_descriptor_ubound (dest, dest_index),
739 gfc_conv_descriptor_ubound (src, src_index));
743 gcc_assert (integer_zerop (loop->from[n]));
744 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
745 gfc_conv_descriptor_ubound (dest, dest_index),
746 gfc_conv_descriptor_lbound (dest, dest_index));
750 /* Copy the data pointer. */
751 dest_info->data = gfc_conv_descriptor_data_get (src);
752 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
754 /* Copy the offset. This is not changed by transposition: the top-left
755 element is still at the same offset as before. */
756 dest_info->offset = gfc_conv_descriptor_offset (src);
757 gfc_add_modify_expr (&se->pre,
758 gfc_conv_descriptor_offset (dest),
761 if (dest_info->dimen > loop->temp_dim)
762 loop->temp_dim = dest_info->dimen;
766 /* Return the number of iterations in a loop that starts at START,
767 ends at END, and has step STEP. */
770 gfc_get_iteration_count (tree start, tree end, tree step)
775 type = TREE_TYPE (step);
776 tmp = fold_build2 (MINUS_EXPR, type, end, start);
777 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
778 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
779 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
780 return fold_convert (gfc_array_index_type, tmp);
784 /* Extend the data in array DESC by EXTRA elements. */
787 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
794 if (integer_zerop (extra))
797 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
799 /* Add EXTRA to the upper bound. */
800 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
801 gfc_add_modify_expr (pblock, ubound, tmp);
803 /* Get the value of the current data pointer. */
804 tmp = gfc_conv_descriptor_data_get (desc);
805 args = gfc_chainon_list (NULL_TREE, tmp);
807 /* Calculate the new array size. */
808 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
809 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
810 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
811 args = gfc_chainon_list (args, tmp);
813 /* Pick the appropriate realloc function. */
814 if (gfc_index_integer_kind == 4)
815 tmp = gfor_fndecl_internal_realloc;
816 else if (gfc_index_integer_kind == 8)
817 tmp = gfor_fndecl_internal_realloc64;
821 /* Set the new data pointer. */
822 tmp = build_function_call_expr (tmp, args);
823 gfc_conv_descriptor_data_set (pblock, desc, tmp);
827 /* Return true if the bounds of iterator I can only be determined
831 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
833 return (i->start->expr_type != EXPR_CONSTANT
834 || i->end->expr_type != EXPR_CONSTANT
835 || i->step->expr_type != EXPR_CONSTANT);
839 /* Split the size of constructor element EXPR into the sum of two terms,
840 one of which can be determined at compile time and one of which must
841 be calculated at run time. Set *SIZE to the former and return true
842 if the latter might be nonzero. */
845 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
847 if (expr->expr_type == EXPR_ARRAY)
848 return gfc_get_array_constructor_size (size, expr->value.constructor);
849 else if (expr->rank > 0)
851 /* Calculate everything at run time. */
852 mpz_set_ui (*size, 0);
857 /* A single element. */
858 mpz_set_ui (*size, 1);
864 /* Like gfc_get_array_constructor_element_size, but applied to the whole
865 of array constructor C. */
868 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
875 mpz_set_ui (*size, 0);
880 for (; c; c = c->next)
883 if (i && gfc_iterator_has_dynamic_bounds (i))
887 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
890 /* Multiply the static part of the element size by the
891 number of iterations. */
892 mpz_sub (val, i->end->value.integer, i->start->value.integer);
893 mpz_fdiv_q (val, val, i->step->value.integer);
894 mpz_add_ui (val, val, 1);
895 if (mpz_sgn (val) > 0)
896 mpz_mul (len, len, val);
900 mpz_add (*size, *size, len);
909 /* Make sure offset is a variable. */
912 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
915 /* We should have already created the offset variable. We cannot
916 create it here because we may be in an inner scope. */
917 gcc_assert (*offsetvar != NULL_TREE);
918 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
919 *poffset = *offsetvar;
920 TREE_USED (*offsetvar) = 1;
924 /* Assign an element of an array constructor. */
927 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
928 tree offset, gfc_se * se, gfc_expr * expr)
933 gfc_conv_expr (se, expr);
935 /* Store the value. */
936 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
937 tmp = gfc_build_array_ref (tmp, offset);
938 if (expr->ts.type == BT_CHARACTER)
940 gfc_conv_string_parameter (se);
941 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
943 /* The temporary is an array of pointers. */
944 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
945 gfc_add_modify_expr (&se->pre, tmp, se->expr);
949 /* The temporary is an array of string values. */
950 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
951 /* We know the temporary and the value will be the same length,
952 so can use memcpy. */
953 args = gfc_chainon_list (NULL_TREE, tmp);
954 args = gfc_chainon_list (args, se->expr);
955 args = gfc_chainon_list (args, se->string_length);
956 tmp = built_in_decls[BUILT_IN_MEMCPY];
957 tmp = build_function_call_expr (tmp, args);
958 gfc_add_expr_to_block (&se->pre, tmp);
963 /* TODO: Should the frontend already have done this conversion? */
964 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
965 gfc_add_modify_expr (&se->pre, tmp, se->expr);
968 gfc_add_block_to_block (pblock, &se->pre);
969 gfc_add_block_to_block (pblock, &se->post);
973 /* Add the contents of an array to the constructor. DYNAMIC is as for
974 gfc_trans_array_constructor_value. */
977 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
978 tree type ATTRIBUTE_UNUSED,
979 tree desc, gfc_expr * expr,
980 tree * poffset, tree * offsetvar,
991 /* We need this to be a variable so we can increment it. */
992 gfc_put_offset_into_var (pblock, poffset, offsetvar);
994 gfc_init_se (&se, NULL);
996 /* Walk the array expression. */
997 ss = gfc_walk_expr (expr);
998 gcc_assert (ss != gfc_ss_terminator);
1000 /* Initialize the scalarizer. */
1001 gfc_init_loopinfo (&loop);
1002 gfc_add_ss_to_loop (&loop, ss);
1004 /* Initialize the loop. */
1005 gfc_conv_ss_startstride (&loop);
1006 gfc_conv_loop_setup (&loop);
1008 /* Make sure the constructed array has room for the new data. */
1011 /* Set SIZE to the total number of elements in the subarray. */
1012 size = gfc_index_one_node;
1013 for (n = 0; n < loop.dimen; n++)
1015 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1016 gfc_index_one_node);
1017 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1020 /* Grow the constructed array by SIZE elements. */
1021 gfc_grow_array (&loop.pre, desc, size);
1024 /* Make the loop body. */
1025 gfc_mark_ss_chain_used (ss, 1);
1026 gfc_start_scalarized_body (&loop, &body);
1027 gfc_copy_loopinfo_to_se (&se, &loop);
1030 if (expr->ts.type == BT_CHARACTER)
1031 gfc_todo_error ("character arrays in constructors");
1033 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1034 gcc_assert (se.ss == gfc_ss_terminator);
1036 /* Increment the offset. */
1037 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1038 gfc_add_modify_expr (&body, *poffset, tmp);
1040 /* Finish the loop. */
1041 gfc_trans_scalarizing_loops (&loop, &body);
1042 gfc_add_block_to_block (&loop.pre, &loop.post);
1043 tmp = gfc_finish_block (&loop.pre);
1044 gfc_add_expr_to_block (pblock, tmp);
1046 gfc_cleanup_loop (&loop);
1050 /* Assign the values to the elements of an array constructor. DYNAMIC
1051 is true if descriptor DESC only contains enough data for the static
1052 size calculated by gfc_get_array_constructor_size. When true, memory
1053 for the dynamic parts must be allocated using realloc. */
1056 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1057 tree desc, gfc_constructor * c,
1058 tree * poffset, tree * offsetvar,
1067 for (; c; c = c->next)
1069 /* If this is an iterator or an array, the offset must be a variable. */
1070 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1071 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1073 gfc_start_block (&body);
1075 if (c->expr->expr_type == EXPR_ARRAY)
1077 /* Array constructors can be nested. */
1078 gfc_trans_array_constructor_value (&body, type, desc,
1079 c->expr->value.constructor,
1080 poffset, offsetvar, dynamic);
1082 else if (c->expr->rank > 0)
1084 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1085 poffset, offsetvar, dynamic);
1089 /* This code really upsets the gimplifier so don't bother for now. */
1096 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1103 /* Scalar values. */
1104 gfc_init_se (&se, NULL);
1105 gfc_trans_array_ctor_element (&body, desc, *poffset,
1108 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1109 *poffset, gfc_index_one_node);
1113 /* Collect multiple scalar constants into a constructor. */
1121 /* Count the number of consecutive scalar constants. */
1122 while (p && !(p->iterator
1123 || p->expr->expr_type != EXPR_CONSTANT))
1125 gfc_init_se (&se, NULL);
1126 gfc_conv_constant (&se, p->expr);
1127 if (p->expr->ts.type == BT_CHARACTER
1128 && POINTER_TYPE_P (type))
1130 /* For constant character array constructors we build
1131 an array of pointers. */
1132 se.expr = gfc_build_addr_expr (pchar_type_node,
1136 list = tree_cons (NULL_TREE, se.expr, list);
1141 bound = build_int_cst (NULL_TREE, n - 1);
1142 /* Create an array type to hold them. */
1143 tmptype = build_range_type (gfc_array_index_type,
1144 gfc_index_zero_node, bound);
1145 tmptype = build_array_type (type, tmptype);
1147 init = build_constructor_from_list (tmptype, nreverse (list));
1148 TREE_CONSTANT (init) = 1;
1149 TREE_INVARIANT (init) = 1;
1150 TREE_STATIC (init) = 1;
1151 /* Create a static variable to hold the data. */
1152 tmp = gfc_create_var (tmptype, "data");
1153 TREE_STATIC (tmp) = 1;
1154 TREE_CONSTANT (tmp) = 1;
1155 TREE_INVARIANT (tmp) = 1;
1156 DECL_INITIAL (tmp) = init;
1159 /* Use BUILTIN_MEMCPY to assign the values. */
1160 tmp = gfc_conv_descriptor_data_get (desc);
1161 tmp = build_fold_indirect_ref (tmp);
1162 tmp = gfc_build_array_ref (tmp, *poffset);
1163 tmp = build_fold_addr_expr (tmp);
1164 init = build_fold_addr_expr (init);
1166 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1167 bound = build_int_cst (NULL_TREE, n * size);
1168 tmp = gfc_chainon_list (NULL_TREE, tmp);
1169 tmp = gfc_chainon_list (tmp, init);
1170 tmp = gfc_chainon_list (tmp, bound);
1171 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
1173 gfc_add_expr_to_block (&body, tmp);
1175 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1176 *poffset, build_int_cst (NULL_TREE, n));
1178 if (!INTEGER_CST_P (*poffset))
1180 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1181 *poffset = *offsetvar;
1185 /* The frontend should already have done any expansions possible
1189 /* Pass the code as is. */
1190 tmp = gfc_finish_block (&body);
1191 gfc_add_expr_to_block (pblock, tmp);
1195 /* Build the implied do-loop. */
1204 loopbody = gfc_finish_block (&body);
1206 gfc_init_se (&se, NULL);
1207 gfc_conv_expr (&se, c->iterator->var);
1208 gfc_add_block_to_block (pblock, &se.pre);
1211 /* Initialize the loop. */
1212 gfc_init_se (&se, NULL);
1213 gfc_conv_expr_val (&se, c->iterator->start);
1214 gfc_add_block_to_block (pblock, &se.pre);
1215 gfc_add_modify_expr (pblock, loopvar, se.expr);
1217 gfc_init_se (&se, NULL);
1218 gfc_conv_expr_val (&se, c->iterator->end);
1219 gfc_add_block_to_block (pblock, &se.pre);
1220 end = gfc_evaluate_now (se.expr, pblock);
1222 gfc_init_se (&se, NULL);
1223 gfc_conv_expr_val (&se, c->iterator->step);
1224 gfc_add_block_to_block (pblock, &se.pre);
1225 step = gfc_evaluate_now (se.expr, pblock);
1227 /* If this array expands dynamically, and the number of iterations
1228 is not constant, we won't have allocated space for the static
1229 part of C->EXPR's size. Do that now. */
1230 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1232 /* Get the number of iterations. */
1233 tmp = gfc_get_iteration_count (loopvar, end, step);
1235 /* Get the static part of C->EXPR's size. */
1236 gfc_get_array_constructor_element_size (&size, c->expr);
1237 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1239 /* Grow the array by TMP * TMP2 elements. */
1240 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1241 gfc_grow_array (pblock, desc, tmp);
1244 /* Generate the loop body. */
1245 exit_label = gfc_build_label_decl (NULL_TREE);
1246 gfc_start_block (&body);
1248 /* Generate the exit condition. Depending on the sign of
1249 the step variable we have to generate the correct
1251 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1252 build_int_cst (TREE_TYPE (step), 0));
1253 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1254 build2 (GT_EXPR, boolean_type_node,
1256 build2 (LT_EXPR, boolean_type_node,
1258 tmp = build1_v (GOTO_EXPR, exit_label);
1259 TREE_USED (exit_label) = 1;
1260 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1261 gfc_add_expr_to_block (&body, tmp);
1263 /* The main loop body. */
1264 gfc_add_expr_to_block (&body, loopbody);
1266 /* Increase loop variable by step. */
1267 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1268 gfc_add_modify_expr (&body, loopvar, tmp);
1270 /* Finish the loop. */
1271 tmp = gfc_finish_block (&body);
1272 tmp = build1_v (LOOP_EXPR, tmp);
1273 gfc_add_expr_to_block (pblock, tmp);
1275 /* Add the exit label. */
1276 tmp = build1_v (LABEL_EXPR, exit_label);
1277 gfc_add_expr_to_block (pblock, tmp);
1284 /* Figure out the string length of a variable reference expression.
1285 Used by get_array_ctor_strlen. */
1288 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1293 /* Don't bother if we already know the length is a constant. */
1294 if (*len && INTEGER_CST_P (*len))
1297 ts = &expr->symtree->n.sym->ts;
1298 for (ref = expr->ref; ref; ref = ref->next)
1303 /* Array references don't change the string length. */
1307 /* Use the length of the component. */
1308 ts = &ref->u.c.component->ts;
1312 /* TODO: Substrings are tricky because we can't evaluate the
1313 expression more than once. For now we just give up, and hope
1314 we can figure it out elsewhere. */
1319 *len = ts->cl->backend_decl;
1323 /* Figure out the string length of a character array constructor.
1324 Returns TRUE if all elements are character constants. */
1327 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1332 for (; c; c = c->next)
1334 switch (c->expr->expr_type)
1337 if (!(*len && INTEGER_CST_P (*len)))
1338 *len = build_int_cstu (gfc_charlen_type_node,
1339 c->expr->value.character.length);
1343 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1349 get_array_ctor_var_strlen (c->expr, len);
1354 /* TODO: For now we just ignore anything we don't know how to
1355 handle, and hope we can figure it out a different way. */
1364 /* Array constructors are handled by constructing a temporary, then using that
1365 within the scalarization loop. This is not optimal, but seems by far the
1369 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1379 ss->data.info.dimen = loop->dimen;
1381 c = ss->expr->value.constructor;
1382 if (ss->expr->ts.type == BT_CHARACTER)
1384 const_string = get_array_ctor_strlen (c, &ss->string_length);
1385 if (!ss->string_length)
1386 gfc_todo_error ("complex character array constructors");
1388 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1390 type = build_pointer_type (type);
1394 const_string = TRUE;
1395 type = gfc_typenode_for_spec (&ss->expr->ts);
1398 /* See if the constructor determines the loop bounds. */
1400 if (loop->to[0] == NULL_TREE)
1404 /* We should have a 1-dimensional, zero-based loop. */
1405 gcc_assert (loop->dimen == 1);
1406 gcc_assert (integer_zerop (loop->from[0]));
1408 /* Split the constructor size into a static part and a dynamic part.
1409 Allocate the static size up-front and record whether the dynamic
1410 size might be nonzero. */
1412 dynamic = gfc_get_array_constructor_size (&size, c);
1413 mpz_sub_ui (size, size, 1);
1414 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1418 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
1419 &ss->data.info, type, dynamic);
1421 desc = ss->data.info.descriptor;
1422 offset = gfc_index_zero_node;
1423 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1424 TREE_USED (offsetvar) = 0;
1425 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1426 &offset, &offsetvar, dynamic);
1428 /* If the array grows dynamically, the upper bound of the loop variable
1429 is determined by the array's final upper bound. */
1431 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1433 if (TREE_USED (offsetvar))
1434 pushdecl (offsetvar);
1436 gcc_assert (INTEGER_CST_P (offset));
1438 /* Disable bound checking for now because it's probably broken. */
1439 if (flag_bounds_check)
1447 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1448 called after evaluating all of INFO's vector dimensions. Go through
1449 each such vector dimension and see if we can now fill in any missing
1453 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1462 for (n = 0; n < loop->dimen; n++)
1465 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1466 && loop->to[n] == NULL)
1468 /* Loop variable N indexes vector dimension DIM, and we don't
1469 yet know the upper bound of loop variable N. Set it to the
1470 difference between the vector's upper and lower bounds. */
1471 gcc_assert (loop->from[n] == gfc_index_zero_node);
1472 gcc_assert (info->subscript[dim]
1473 && info->subscript[dim]->type == GFC_SS_VECTOR);
1475 gfc_init_se (&se, NULL);
1476 desc = info->subscript[dim]->data.info.descriptor;
1477 zero = gfc_rank_cst[0];
1478 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1479 gfc_conv_descriptor_ubound (desc, zero),
1480 gfc_conv_descriptor_lbound (desc, zero));
1481 tmp = gfc_evaluate_now (tmp, &loop->pre);
1488 /* Add the pre and post chains for all the scalar expressions in a SS chain
1489 to loop. This is called after the loop parameters have been calculated,
1490 but before the actual scalarizing loops. */
1493 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1498 /* TODO: This can generate bad code if there are ordering dependencies.
1499 eg. a callee allocated function and an unknown size constructor. */
1500 gcc_assert (ss != NULL);
1502 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1509 /* Scalar expression. Evaluate this now. This includes elemental
1510 dimension indices, but not array section bounds. */
1511 gfc_init_se (&se, NULL);
1512 gfc_conv_expr (&se, ss->expr);
1513 gfc_add_block_to_block (&loop->pre, &se.pre);
1515 if (ss->expr->ts.type != BT_CHARACTER)
1517 /* Move the evaluation of scalar expressions outside the
1518 scalarization loop. */
1520 se.expr = convert(gfc_array_index_type, se.expr);
1521 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1522 gfc_add_block_to_block (&loop->pre, &se.post);
1525 gfc_add_block_to_block (&loop->post, &se.post);
1527 ss->data.scalar.expr = se.expr;
1528 ss->string_length = se.string_length;
1531 case GFC_SS_REFERENCE:
1532 /* Scalar reference. Evaluate this now. */
1533 gfc_init_se (&se, NULL);
1534 gfc_conv_expr_reference (&se, ss->expr);
1535 gfc_add_block_to_block (&loop->pre, &se.pre);
1536 gfc_add_block_to_block (&loop->post, &se.post);
1538 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1539 ss->string_length = se.string_length;
1542 case GFC_SS_SECTION:
1543 /* Add the expressions for scalar and vector subscripts. */
1544 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1545 if (ss->data.info.subscript[n])
1546 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1548 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1552 /* Get the vector's descriptor and store it in SS. */
1553 gfc_init_se (&se, NULL);
1554 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1555 gfc_add_block_to_block (&loop->pre, &se.pre);
1556 gfc_add_block_to_block (&loop->post, &se.post);
1557 ss->data.info.descriptor = se.expr;
1560 case GFC_SS_INTRINSIC:
1561 gfc_add_intrinsic_ss_code (loop, ss);
1564 case GFC_SS_FUNCTION:
1565 /* Array function return value. We call the function and save its
1566 result in a temporary for use inside the loop. */
1567 gfc_init_se (&se, NULL);
1570 gfc_conv_expr (&se, ss->expr);
1571 gfc_add_block_to_block (&loop->pre, &se.pre);
1572 gfc_add_block_to_block (&loop->post, &se.post);
1573 ss->string_length = se.string_length;
1576 case GFC_SS_CONSTRUCTOR:
1577 gfc_trans_array_constructor (loop, ss);
1581 case GFC_SS_COMPONENT:
1582 /* Do nothing. These are handled elsewhere. */
1592 /* Translate expressions for the descriptor and data pointer of a SS. */
1596 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1601 /* Get the descriptor for the array to be scalarized. */
1602 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1603 gfc_init_se (&se, NULL);
1604 se.descriptor_only = 1;
1605 gfc_conv_expr_lhs (&se, ss->expr);
1606 gfc_add_block_to_block (block, &se.pre);
1607 ss->data.info.descriptor = se.expr;
1608 ss->string_length = se.string_length;
1612 /* Also the data pointer. */
1613 tmp = gfc_conv_array_data (se.expr);
1614 /* If this is a variable or address of a variable we use it directly.
1615 Otherwise we must evaluate it now to avoid breaking dependency
1616 analysis by pulling the expressions for elemental array indices
1619 || (TREE_CODE (tmp) == ADDR_EXPR
1620 && DECL_P (TREE_OPERAND (tmp, 0)))))
1621 tmp = gfc_evaluate_now (tmp, block);
1622 ss->data.info.data = tmp;
1624 tmp = gfc_conv_array_offset (se.expr);
1625 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1630 /* Initialize a gfc_loopinfo structure. */
1633 gfc_init_loopinfo (gfc_loopinfo * loop)
1637 memset (loop, 0, sizeof (gfc_loopinfo));
1638 gfc_init_block (&loop->pre);
1639 gfc_init_block (&loop->post);
1641 /* Initially scalarize in order. */
1642 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1645 loop->ss = gfc_ss_terminator;
1649 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1653 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1659 /* Return an expression for the data pointer of an array. */
1662 gfc_conv_array_data (tree descriptor)
1666 type = TREE_TYPE (descriptor);
1667 if (GFC_ARRAY_TYPE_P (type))
1669 if (TREE_CODE (type) == POINTER_TYPE)
1673 /* Descriptorless arrays. */
1674 return build_fold_addr_expr (descriptor);
1678 return gfc_conv_descriptor_data_get (descriptor);
1682 /* Return an expression for the base offset of an array. */
1685 gfc_conv_array_offset (tree descriptor)
1689 type = TREE_TYPE (descriptor);
1690 if (GFC_ARRAY_TYPE_P (type))
1691 return GFC_TYPE_ARRAY_OFFSET (type);
1693 return gfc_conv_descriptor_offset (descriptor);
1697 /* Get an expression for the array stride. */
1700 gfc_conv_array_stride (tree descriptor, int dim)
1705 type = TREE_TYPE (descriptor);
1707 /* For descriptorless arrays use the array size. */
1708 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1709 if (tmp != NULL_TREE)
1712 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1717 /* Like gfc_conv_array_stride, but for the lower bound. */
1720 gfc_conv_array_lbound (tree descriptor, int dim)
1725 type = TREE_TYPE (descriptor);
1727 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1728 if (tmp != NULL_TREE)
1731 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1736 /* Like gfc_conv_array_stride, but for the upper bound. */
1739 gfc_conv_array_ubound (tree descriptor, int dim)
1744 type = TREE_TYPE (descriptor);
1746 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1747 if (tmp != NULL_TREE)
1750 /* This should only ever happen when passing an assumed shape array
1751 as an actual parameter. The value will never be used. */
1752 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1753 return gfc_index_zero_node;
1755 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1760 /* Generate code to perform an array index bound check. */
1763 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1769 if (!flag_bounds_check)
1772 index = gfc_evaluate_now (index, &se->pre);
1773 /* Check lower bound. */
1774 tmp = gfc_conv_array_lbound (descriptor, n);
1775 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1776 /* Check upper bound. */
1777 tmp = gfc_conv_array_ubound (descriptor, n);
1778 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1779 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1781 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1787 /* Return the offset for an index. Performs bound checking for elemental
1788 dimensions. Single element references are processed separately. */
1791 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1792 gfc_array_ref * ar, tree stride)
1798 /* Get the index into the array for this dimension. */
1801 gcc_assert (ar->type != AR_ELEMENT);
1802 switch (ar->dimen_type[dim])
1805 gcc_assert (i == -1);
1806 /* Elemental dimension. */
1807 gcc_assert (info->subscript[dim]
1808 && info->subscript[dim]->type == GFC_SS_SCALAR);
1809 /* We've already translated this value outside the loop. */
1810 index = info->subscript[dim]->data.scalar.expr;
1813 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1817 gcc_assert (info && se->loop);
1818 gcc_assert (info->subscript[dim]
1819 && info->subscript[dim]->type == GFC_SS_VECTOR);
1820 desc = info->subscript[dim]->data.info.descriptor;
1822 /* Get a zero-based index into the vector. */
1823 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1824 se->loop->loopvar[i], se->loop->from[i]);
1826 /* Multiply the index by the stride. */
1827 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1828 index, gfc_conv_array_stride (desc, 0));
1830 /* Read the vector to get an index into info->descriptor. */
1831 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
1832 index = gfc_build_array_ref (data, index);
1833 index = gfc_evaluate_now (index, &se->pre);
1835 /* Do any bounds checking on the final info->descriptor index. */
1836 index = gfc_trans_array_bound_check (se, info->descriptor,
1841 /* Scalarized dimension. */
1842 gcc_assert (info && se->loop);
1844 /* Multiply the loop variable by the stride and delta. */
1845 index = se->loop->loopvar[i];
1846 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1848 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1858 /* Temporary array or derived type component. */
1859 gcc_assert (se->loop);
1860 index = se->loop->loopvar[se->loop->order[i]];
1861 if (!integer_zerop (info->delta[i]))
1862 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1863 index, info->delta[i]);
1866 /* Multiply by the stride. */
1867 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1873 /* Build a scalarized reference to an array. */
1876 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1883 info = &se->ss->data.info;
1885 n = se->loop->order[0];
1889 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1891 /* Add the offset for this dimension to the stored offset for all other
1893 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1895 tmp = build_fold_indirect_ref (info->data);
1896 se->expr = gfc_build_array_ref (tmp, index);
1900 /* Translate access of temporary array. */
1903 gfc_conv_tmp_array_ref (gfc_se * se)
1905 se->string_length = se->ss->string_length;
1906 gfc_conv_scalarized_array_ref (se, NULL);
1910 /* Build an array reference. se->expr already holds the array descriptor.
1911 This should be either a variable, indirect variable reference or component
1912 reference. For arrays which do not have a descriptor, se->expr will be
1914 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1917 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1926 /* Handle scalarized references separately. */
1927 if (ar->type != AR_ELEMENT)
1929 gfc_conv_scalarized_array_ref (se, ar);
1930 gfc_advance_se_ss_chain (se);
1934 index = gfc_index_zero_node;
1936 fault = gfc_index_zero_node;
1938 /* Calculate the offsets from all the dimensions. */
1939 for (n = 0; n < ar->dimen; n++)
1941 /* Calculate the index for this dimension. */
1942 gfc_init_se (&indexse, se);
1943 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1944 gfc_add_block_to_block (&se->pre, &indexse.pre);
1946 if (flag_bounds_check)
1948 /* Check array bounds. */
1951 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1953 tmp = gfc_conv_array_lbound (se->expr, n);
1954 cond = fold_build2 (LT_EXPR, boolean_type_node,
1957 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1959 tmp = gfc_conv_array_ubound (se->expr, n);
1960 cond = fold_build2 (GT_EXPR, boolean_type_node,
1963 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1966 /* Multiply the index by the stride. */
1967 stride = gfc_conv_array_stride (se->expr, n);
1968 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1971 /* And add it to the total. */
1972 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1975 if (flag_bounds_check)
1976 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1978 tmp = gfc_conv_array_offset (se->expr);
1979 if (!integer_zerop (tmp))
1980 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1982 /* Access the calculated element. */
1983 tmp = gfc_conv_array_data (se->expr);
1984 tmp = build_fold_indirect_ref (tmp);
1985 se->expr = gfc_build_array_ref (tmp, index);
1989 /* Generate the code to be executed immediately before entering a
1990 scalarization loop. */
1993 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1994 stmtblock_t * pblock)
2003 /* This code will be executed before entering the scalarization loop
2004 for this dimension. */
2005 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2007 if ((ss->useflags & flag) == 0)
2010 if (ss->type != GFC_SS_SECTION
2011 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2012 && ss->type != GFC_SS_COMPONENT)
2015 info = &ss->data.info;
2017 if (dim >= info->dimen)
2020 if (dim == info->dimen - 1)
2022 /* For the outermost loop calculate the offset due to any
2023 elemental dimensions. It will have been initialized with the
2024 base offset of the array. */
2027 for (i = 0; i < info->ref->u.ar.dimen; i++)
2029 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2032 gfc_init_se (&se, NULL);
2034 se.expr = info->descriptor;
2035 stride = gfc_conv_array_stride (info->descriptor, i);
2036 index = gfc_conv_array_index_offset (&se, info, i, -1,
2039 gfc_add_block_to_block (pblock, &se.pre);
2041 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2042 info->offset, index);
2043 info->offset = gfc_evaluate_now (info->offset, pblock);
2047 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2050 stride = gfc_conv_array_stride (info->descriptor, 0);
2052 /* Calculate the stride of the innermost loop. Hopefully this will
2053 allow the backend optimizers to do their stuff more effectively.
2055 info->stride0 = gfc_evaluate_now (stride, pblock);
2059 /* Add the offset for the previous loop dimension. */
2064 ar = &info->ref->u.ar;
2065 i = loop->order[dim + 1];
2073 gfc_init_se (&se, NULL);
2075 se.expr = info->descriptor;
2076 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2077 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2079 gfc_add_block_to_block (pblock, &se.pre);
2080 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2081 info->offset, index);
2082 info->offset = gfc_evaluate_now (info->offset, pblock);
2085 /* Remember this offset for the second loop. */
2086 if (dim == loop->temp_dim - 1)
2087 info->saved_offset = info->offset;
2092 /* Start a scalarized expression. Creates a scope and declares loop
2096 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2102 gcc_assert (!loop->array_parameter);
2104 for (dim = loop->dimen - 1; dim >= 0; dim--)
2106 n = loop->order[dim];
2108 gfc_start_block (&loop->code[n]);
2110 /* Create the loop variable. */
2111 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2113 if (dim < loop->temp_dim)
2117 /* Calculate values that will be constant within this loop. */
2118 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2120 gfc_start_block (pbody);
2124 /* Generates the actual loop code for a scalarization loop. */
2127 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2128 stmtblock_t * pbody)
2136 loopbody = gfc_finish_block (pbody);
2138 /* Initialize the loopvar. */
2139 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2141 exit_label = gfc_build_label_decl (NULL_TREE);
2143 /* Generate the loop body. */
2144 gfc_init_block (&block);
2146 /* The exit condition. */
2147 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2148 tmp = build1_v (GOTO_EXPR, exit_label);
2149 TREE_USED (exit_label) = 1;
2150 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2151 gfc_add_expr_to_block (&block, tmp);
2153 /* The main body. */
2154 gfc_add_expr_to_block (&block, loopbody);
2156 /* Increment the loopvar. */
2157 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2158 loop->loopvar[n], gfc_index_one_node);
2159 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2161 /* Build the loop. */
2162 tmp = gfc_finish_block (&block);
2163 tmp = build1_v (LOOP_EXPR, tmp);
2164 gfc_add_expr_to_block (&loop->code[n], tmp);
2166 /* Add the exit label. */
2167 tmp = build1_v (LABEL_EXPR, exit_label);
2168 gfc_add_expr_to_block (&loop->code[n], tmp);
2172 /* Finishes and generates the loops for a scalarized expression. */
2175 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2180 stmtblock_t *pblock;
2184 /* Generate the loops. */
2185 for (dim = 0; dim < loop->dimen; dim++)
2187 n = loop->order[dim];
2188 gfc_trans_scalarized_loop_end (loop, n, pblock);
2189 loop->loopvar[n] = NULL_TREE;
2190 pblock = &loop->code[n];
2193 tmp = gfc_finish_block (pblock);
2194 gfc_add_expr_to_block (&loop->pre, tmp);
2196 /* Clear all the used flags. */
2197 for (ss = loop->ss; ss; ss = ss->loop_chain)
2202 /* Finish the main body of a scalarized expression, and start the secondary
2206 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2210 stmtblock_t *pblock;
2214 /* We finish as many loops as are used by the temporary. */
2215 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2217 n = loop->order[dim];
2218 gfc_trans_scalarized_loop_end (loop, n, pblock);
2219 loop->loopvar[n] = NULL_TREE;
2220 pblock = &loop->code[n];
2223 /* We don't want to finish the outermost loop entirely. */
2224 n = loop->order[loop->temp_dim - 1];
2225 gfc_trans_scalarized_loop_end (loop, n, pblock);
2227 /* Restore the initial offsets. */
2228 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2230 if ((ss->useflags & 2) == 0)
2233 if (ss->type != GFC_SS_SECTION
2234 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2235 && ss->type != GFC_SS_COMPONENT)
2238 ss->data.info.offset = ss->data.info.saved_offset;
2241 /* Restart all the inner loops we just finished. */
2242 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2244 n = loop->order[dim];
2246 gfc_start_block (&loop->code[n]);
2248 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2250 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2253 /* Start a block for the secondary copying code. */
2254 gfc_start_block (body);
2258 /* Calculate the upper bound of an array section. */
2261 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2270 gcc_assert (ss->type == GFC_SS_SECTION);
2272 info = &ss->data.info;
2275 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2276 /* We'll calculate the upper bound once we have access to the
2277 vector's descriptor. */
2280 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2281 desc = info->descriptor;
2282 end = info->ref->u.ar.end[dim];
2286 /* The upper bound was specified. */
2287 gfc_init_se (&se, NULL);
2288 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2289 gfc_add_block_to_block (pblock, &se.pre);
2294 /* No upper bound was specified, so use the bound of the array. */
2295 bound = gfc_conv_array_ubound (desc, dim);
2302 /* Calculate the lower bound of an array section. */
2305 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2314 gcc_assert (ss->type == GFC_SS_SECTION);
2316 info = &ss->data.info;
2319 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2321 /* We use a zero-based index to access the vector. */
2322 info->start[n] = gfc_index_zero_node;
2323 info->stride[n] = gfc_index_one_node;
2327 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2328 desc = info->descriptor;
2329 start = info->ref->u.ar.start[dim];
2330 stride = info->ref->u.ar.stride[dim];
2332 /* Calculate the start of the range. For vector subscripts this will
2333 be the range of the vector. */
2336 /* Specified section start. */
2337 gfc_init_se (&se, NULL);
2338 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2339 gfc_add_block_to_block (&loop->pre, &se.pre);
2340 info->start[n] = se.expr;
2344 /* No lower bound specified so use the bound of the array. */
2345 info->start[n] = gfc_conv_array_lbound (desc, dim);
2347 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2349 /* Calculate the stride. */
2351 info->stride[n] = gfc_index_one_node;
2354 gfc_init_se (&se, NULL);
2355 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2356 gfc_add_block_to_block (&loop->pre, &se.pre);
2357 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2362 /* Calculates the range start and stride for a SS chain. Also gets the
2363 descriptor and data pointer. The range of vector subscripts is the size
2364 of the vector. Array bounds are also checked. */
2367 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2375 /* Determine the rank of the loop. */
2377 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2381 case GFC_SS_SECTION:
2382 case GFC_SS_CONSTRUCTOR:
2383 case GFC_SS_FUNCTION:
2384 case GFC_SS_COMPONENT:
2385 loop->dimen = ss->data.info.dimen;
2393 if (loop->dimen == 0)
2394 gfc_todo_error ("Unable to determine rank of expression");
2397 /* Loop over all the SS in the chain. */
2398 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2400 if (ss->expr && ss->expr->shape && !ss->shape)
2401 ss->shape = ss->expr->shape;
2405 case GFC_SS_SECTION:
2406 /* Get the descriptor for the array. */
2407 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2409 for (n = 0; n < ss->data.info.dimen; n++)
2410 gfc_conv_section_startstride (loop, ss, n);
2413 case GFC_SS_CONSTRUCTOR:
2414 case GFC_SS_FUNCTION:
2415 for (n = 0; n < ss->data.info.dimen; n++)
2417 ss->data.info.start[n] = gfc_index_zero_node;
2418 ss->data.info.stride[n] = gfc_index_one_node;
2427 /* The rest is just runtime bound checking. */
2428 if (flag_bounds_check)
2434 tree size[GFC_MAX_DIMENSIONS];
2438 gfc_start_block (&block);
2440 fault = integer_zero_node;
2441 for (n = 0; n < loop->dimen; n++)
2442 size[n] = NULL_TREE;
2444 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2446 if (ss->type != GFC_SS_SECTION)
2449 /* TODO: range checking for mapped dimensions. */
2450 info = &ss->data.info;
2452 /* This code only checks ranges. Elemental and vector
2453 dimensions are checked later. */
2454 for (n = 0; n < loop->dimen; n++)
2457 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2460 desc = ss->data.info.descriptor;
2462 /* Check lower bound. */
2463 bound = gfc_conv_array_lbound (desc, dim);
2464 tmp = info->start[n];
2465 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2466 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2469 /* Check the upper bound. */
2470 bound = gfc_conv_array_ubound (desc, dim);
2471 end = gfc_conv_section_upper_bound (ss, n, &block);
2472 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2473 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2476 /* Check the section sizes match. */
2477 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2479 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2481 /* We remember the size of the first section, and check all the
2482 others against this. */
2486 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2488 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2491 size[n] = gfc_evaluate_now (tmp, &block);
2494 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2496 tmp = gfc_finish_block (&block);
2497 gfc_add_expr_to_block (&loop->pre, tmp);
2502 /* Return true if the two SS could be aliased, i.e. both point to the same data
2504 /* TODO: resolve aliases based on frontend expressions. */
2507 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2514 lsym = lss->expr->symtree->n.sym;
2515 rsym = rss->expr->symtree->n.sym;
2516 if (gfc_symbols_could_alias (lsym, rsym))
2519 if (rsym->ts.type != BT_DERIVED
2520 && lsym->ts.type != BT_DERIVED)
2523 /* For derived types we must check all the component types. We can ignore
2524 array references as these will have the same base type as the previous
2526 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2528 if (lref->type != REF_COMPONENT)
2531 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2534 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2537 if (rref->type != REF_COMPONENT)
2540 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2545 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2547 if (rref->type != REF_COMPONENT)
2550 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2558 /* Resolve array data dependencies. Creates a temporary if required. */
2559 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2563 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2573 loop->temp_ss = NULL;
2574 aref = dest->data.info.ref;
2577 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2579 if (ss->type != GFC_SS_SECTION)
2582 if (gfc_could_be_alias (dest, ss))
2588 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2590 lref = dest->expr->ref;
2591 rref = ss->expr->ref;
2593 nDepend = gfc_dep_resolver (lref, rref);
2595 /* TODO : loop shifting. */
2598 /* Mark the dimensions for LOOP SHIFTING */
2599 for (n = 0; n < loop->dimen; n++)
2601 int dim = dest->data.info.dim[n];
2603 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2605 else if (! gfc_is_same_range (&lref->u.ar,
2606 &rref->u.ar, dim, 0))
2610 /* Put all the dimensions with dependencies in the
2613 for (n = 0; n < loop->dimen; n++)
2615 gcc_assert (loop->order[n] == n);
2617 loop->order[dim++] = n;
2620 for (n = 0; n < loop->dimen; n++)
2623 loop->order[dim++] = n;
2626 gcc_assert (dim == loop->dimen);
2635 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2636 if (GFC_ARRAY_TYPE_P (base_type)
2637 || GFC_DESCRIPTOR_TYPE_P (base_type))
2638 base_type = gfc_get_element_type (base_type);
2639 loop->temp_ss = gfc_get_ss ();
2640 loop->temp_ss->type = GFC_SS_TEMP;
2641 loop->temp_ss->data.temp.type = base_type;
2642 loop->temp_ss->string_length = dest->string_length;
2643 loop->temp_ss->data.temp.dimen = loop->dimen;
2644 loop->temp_ss->next = gfc_ss_terminator;
2645 gfc_add_ss_to_loop (loop, loop->temp_ss);
2648 loop->temp_ss = NULL;
2652 /* Initialize the scalarization loop. Creates the loop variables. Determines
2653 the range of the loop variables. Creates a temporary if required.
2654 Calculates how to transform from loop variables to array indices for each
2655 expression. Also generates code for scalar expressions which have been
2656 moved outside the loop. */
2659 gfc_conv_loop_setup (gfc_loopinfo * loop)
2664 gfc_ss_info *specinfo;
2668 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2669 bool dynamic[GFC_MAX_DIMENSIONS];
2675 for (n = 0; n < loop->dimen; n++)
2679 /* We use one SS term, and use that to determine the bounds of the
2680 loop for this dimension. We try to pick the simplest term. */
2681 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2685 /* The frontend has worked out the size for us. */
2690 if (ss->type == GFC_SS_CONSTRUCTOR)
2692 /* An unknown size constructor will always be rank one.
2693 Higher rank constructors will either have known shape,
2694 or still be wrapped in a call to reshape. */
2695 gcc_assert (loop->dimen == 1);
2697 /* Always prefer to use the constructor bounds if the size
2698 can be determined at compile time. Prefer not to otherwise,
2699 since the general case involves realloc, and it's better to
2700 avoid that overhead if possible. */
2701 c = ss->expr->value.constructor;
2702 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2703 if (!dynamic[n] || !loopspec[n])
2708 /* TODO: Pick the best bound if we have a choice between a
2709 function and something else. */
2710 if (ss->type == GFC_SS_FUNCTION)
2716 if (ss->type != GFC_SS_SECTION)
2720 specinfo = &loopspec[n]->data.info;
2723 info = &ss->data.info;
2727 /* Criteria for choosing a loop specifier (most important first):
2728 doesn't need realloc
2734 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2736 else if (integer_onep (info->stride[n])
2737 && !integer_onep (specinfo->stride[n]))
2739 else if (INTEGER_CST_P (info->stride[n])
2740 && !INTEGER_CST_P (specinfo->stride[n]))
2742 else if (INTEGER_CST_P (info->start[n])
2743 && !INTEGER_CST_P (specinfo->start[n]))
2745 /* We don't work out the upper bound.
2746 else if (INTEGER_CST_P (info->finish[n])
2747 && ! INTEGER_CST_P (specinfo->finish[n]))
2748 loopspec[n] = ss; */
2752 gfc_todo_error ("Unable to find scalarization loop specifier");
2754 info = &loopspec[n]->data.info;
2756 /* Set the extents of this range. */
2757 cshape = loopspec[n]->shape;
2758 if (cshape && INTEGER_CST_P (info->start[n])
2759 && INTEGER_CST_P (info->stride[n]))
2761 loop->from[n] = info->start[n];
2762 mpz_set (i, cshape[n]);
2763 mpz_sub_ui (i, i, 1);
2764 /* To = from + (size - 1) * stride. */
2765 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2766 if (!integer_onep (info->stride[n]))
2767 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2768 tmp, info->stride[n]);
2769 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2770 loop->from[n], tmp);
2774 loop->from[n] = info->start[n];
2775 switch (loopspec[n]->type)
2777 case GFC_SS_CONSTRUCTOR:
2778 /* The upper bound is calculated when we expand the
2780 gcc_assert (loop->to[n] == NULL_TREE);
2783 case GFC_SS_SECTION:
2784 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2788 case GFC_SS_FUNCTION:
2789 /* The loop bound will be set when we generate the call. */
2790 gcc_assert (loop->to[n] == NULL_TREE);
2798 /* Transform everything so we have a simple incrementing variable. */
2799 if (integer_onep (info->stride[n]))
2800 info->delta[n] = gfc_index_zero_node;
2803 /* Set the delta for this section. */
2804 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2805 /* Number of iterations is (end - start + step) / step.
2806 with start = 0, this simplifies to
2808 for (i = 0; i<=last; i++){...}; */
2809 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2810 loop->to[n], loop->from[n]);
2811 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2812 tmp, info->stride[n]);
2813 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2814 /* Make the loop variable start at 0. */
2815 loop->from[n] = gfc_index_zero_node;
2819 /* Add all the scalar code that can be taken out of the loops.
2820 This may include calculating the loop bounds, so do it before
2821 allocating the temporary. */
2822 gfc_add_loop_ss_code (loop, loop->ss, false);
2824 /* If we want a temporary then create it. */
2825 if (loop->temp_ss != NULL)
2827 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2828 tmp = loop->temp_ss->data.temp.type;
2829 len = loop->temp_ss->string_length;
2830 n = loop->temp_ss->data.temp.dimen;
2831 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2832 loop->temp_ss->type = GFC_SS_SECTION;
2833 loop->temp_ss->data.info.dimen = n;
2834 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
2835 &loop->temp_ss->data.info, tmp, false);
2838 for (n = 0; n < loop->temp_dim; n++)
2839 loopspec[loop->order[n]] = NULL;
2843 /* For array parameters we don't have loop variables, so don't calculate the
2845 if (loop->array_parameter)
2848 /* Calculate the translation from loop variables to array indices. */
2849 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2851 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2854 info = &ss->data.info;
2856 for (n = 0; n < info->dimen; n++)
2860 /* If we are specifying the range the delta is already set. */
2861 if (loopspec[n] != ss)
2863 /* Calculate the offset relative to the loop variable.
2864 First multiply by the stride. */
2865 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2866 loop->from[n], info->stride[n]);
2868 /* Then subtract this from our starting value. */
2869 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2870 info->start[n], tmp);
2872 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2879 /* Fills in an array descriptor, and returns the size of the array. The size
2880 will be a simple_val, ie a variable or a constant. Also calculates the
2881 offset of the base. Returns the size of the array.
2885 for (n = 0; n < rank; n++)
2887 a.lbound[n] = specified_lower_bound;
2888 offset = offset + a.lbond[n] * stride;
2890 a.ubound[n] = specified_upper_bound;
2891 a.stride[n] = stride;
2892 size = ubound + size; //size = ubound + 1 - lbound
2893 stride = stride * size;
2900 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2901 gfc_expr ** lower, gfc_expr ** upper,
2902 stmtblock_t * pblock)
2913 type = TREE_TYPE (descriptor);
2915 stride = gfc_index_one_node;
2916 offset = gfc_index_zero_node;
2918 /* Set the dtype. */
2919 tmp = gfc_conv_descriptor_dtype (descriptor);
2920 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2922 for (n = 0; n < rank; n++)
2924 /* We have 3 possibilities for determining the size of the array:
2925 lower == NULL => lbound = 1, ubound = upper[n]
2926 upper[n] = NULL => lbound = 1, ubound = lower[n]
2927 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2930 /* Set lower bound. */
2931 gfc_init_se (&se, NULL);
2933 se.expr = gfc_index_one_node;
2936 gcc_assert (lower[n]);
2939 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2940 gfc_add_block_to_block (pblock, &se.pre);
2944 se.expr = gfc_index_one_node;
2948 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2949 gfc_add_modify_expr (pblock, tmp, se.expr);
2951 /* Work out the offset for this component. */
2952 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2953 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2955 /* Start the calculation for the size of this dimension. */
2956 size = build2 (MINUS_EXPR, gfc_array_index_type,
2957 gfc_index_one_node, se.expr);
2959 /* Set upper bound. */
2960 gfc_init_se (&se, NULL);
2961 gcc_assert (ubound);
2962 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2963 gfc_add_block_to_block (pblock, &se.pre);
2965 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2966 gfc_add_modify_expr (pblock, tmp, se.expr);
2968 /* Store the stride. */
2969 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2970 gfc_add_modify_expr (pblock, tmp, stride);
2972 /* Calculate the size of this dimension. */
2973 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2975 /* Multiply the stride by the number of elements in this dimension. */
2976 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2977 stride = gfc_evaluate_now (stride, pblock);
2980 /* The stride is the number of elements in the array, so multiply by the
2981 size of an element to get the total size. */
2982 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2983 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2985 if (poffset != NULL)
2987 offset = gfc_evaluate_now (offset, pblock);
2991 size = gfc_evaluate_now (size, pblock);
2996 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2997 the work for an ALLOCATE statement. */
3001 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
3011 /* Figure out the size of the array. */
3012 switch (ref->u.ar.type)
3016 upper = ref->u.ar.start;
3020 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3022 lower = ref->u.ar.as->lower;
3023 upper = ref->u.ar.as->upper;
3027 lower = ref->u.ar.start;
3028 upper = ref->u.ar.end;
3036 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3037 lower, upper, &se->pre);
3039 /* Allocate memory to store the data. */
3040 tmp = gfc_conv_descriptor_data_addr (se->expr);
3041 pointer = gfc_evaluate_now (tmp, &se->pre);
3043 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3044 allocate = gfor_fndecl_allocate;
3045 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3046 allocate = gfor_fndecl_allocate64;
3050 tmp = gfc_chainon_list (NULL_TREE, pointer);
3051 tmp = gfc_chainon_list (tmp, size);
3052 tmp = gfc_chainon_list (tmp, pstat);
3053 tmp = build_function_call_expr (allocate, tmp);
3054 gfc_add_expr_to_block (&se->pre, tmp);
3056 tmp = gfc_conv_descriptor_offset (se->expr);
3057 gfc_add_modify_expr (&se->pre, tmp, offset);
3061 /* Deallocate an array variable. Also used when an allocated variable goes
3066 gfc_array_deallocate (tree descriptor, tree pstat)
3072 gfc_start_block (&block);
3073 /* Get a pointer to the data. */
3074 tmp = gfc_conv_descriptor_data_addr (descriptor);
3075 var = gfc_evaluate_now (tmp, &block);
3077 /* Parameter is the address of the data component. */
3078 tmp = gfc_chainon_list (NULL_TREE, var);
3079 tmp = gfc_chainon_list (tmp, pstat);
3080 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3081 gfc_add_expr_to_block (&block, tmp);
3083 return gfc_finish_block (&block);
3087 /* Create an array constructor from an initialization expression.
3088 We assume the frontend already did any expansions and conversions. */
3091 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3098 unsigned HOST_WIDE_INT lo;
3100 VEC(constructor_elt,gc) *v = NULL;
3102 switch (expr->expr_type)
3105 case EXPR_STRUCTURE:
3106 /* A single scalar or derived type value. Create an array with all
3107 elements equal to that value. */
3108 gfc_init_se (&se, NULL);
3110 if (expr->expr_type == EXPR_CONSTANT)
3111 gfc_conv_constant (&se, expr);
3113 gfc_conv_structure (&se, expr, 1);
3115 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3116 gcc_assert (tmp && INTEGER_CST_P (tmp));
3117 hi = TREE_INT_CST_HIGH (tmp);
3118 lo = TREE_INT_CST_LOW (tmp);
3122 /* This will probably eat buckets of memory for large arrays. */
3123 while (hi != 0 || lo != 0)
3125 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3133 /* Create a vector of all the elements. */
3134 for (c = expr->value.constructor; c; c = c->next)
3138 /* Problems occur when we get something like
3139 integer :: a(lots) = (/(i, i=1,lots)/) */
3140 /* TODO: Unexpanded array initializers. */
3142 ("Possible frontend bug: array constructor not expanded");
3144 if (mpz_cmp_si (c->n.offset, 0) != 0)
3145 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3149 if (mpz_cmp_si (c->repeat, 0) != 0)
3153 mpz_set (maxval, c->repeat);
3154 mpz_add (maxval, c->n.offset, maxval);
3155 mpz_sub_ui (maxval, maxval, 1);
3156 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3157 if (mpz_cmp_si (c->n.offset, 0) != 0)
3159 mpz_add_ui (maxval, c->n.offset, 1);
3160 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3163 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3165 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3171 gfc_init_se (&se, NULL);
3172 switch (c->expr->expr_type)
3175 gfc_conv_constant (&se, c->expr);
3176 if (range == NULL_TREE)
3177 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3180 if (index != NULL_TREE)
3181 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3182 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3186 case EXPR_STRUCTURE:
3187 gfc_conv_structure (&se, c->expr, 1);
3188 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3201 /* Create a constructor from the list of elements. */
3202 tmp = build_constructor (type, v);
3203 TREE_CONSTANT (tmp) = 1;
3204 TREE_INVARIANT (tmp) = 1;
3209 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3210 returns the size (in elements) of the array. */
3213 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3214 stmtblock_t * pblock)
3229 size = gfc_index_one_node;
3230 offset = gfc_index_zero_node;
3231 for (dim = 0; dim < as->rank; dim++)
3233 /* Evaluate non-constant array bound expressions. */
3234 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3235 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3237 gfc_init_se (&se, NULL);
3238 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3239 gfc_add_block_to_block (pblock, &se.pre);
3240 gfc_add_modify_expr (pblock, lbound, se.expr);
3242 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3243 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3245 gfc_init_se (&se, NULL);
3246 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3247 gfc_add_block_to_block (pblock, &se.pre);
3248 gfc_add_modify_expr (pblock, ubound, se.expr);
3250 /* The offset of this dimension. offset = offset - lbound * stride. */
3251 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3252 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3254 /* The size of this dimension, and the stride of the next. */
3255 if (dim + 1 < as->rank)
3256 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3260 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3262 /* Calculate stride = size * (ubound + 1 - lbound). */
3263 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3264 gfc_index_one_node, lbound);
3265 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3266 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3268 gfc_add_modify_expr (pblock, stride, tmp);
3270 stride = gfc_evaluate_now (tmp, pblock);
3281 /* Generate code to initialize/allocate an array variable. */
3284 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3294 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3296 /* Do nothing for USEd variables. */
3297 if (sym->attr.use_assoc)
3300 type = TREE_TYPE (decl);
3301 gcc_assert (GFC_ARRAY_TYPE_P (type));
3302 onstack = TREE_CODE (type) != POINTER_TYPE;
3304 gfc_start_block (&block);
3306 /* Evaluate character string length. */
3307 if (sym->ts.type == BT_CHARACTER
3308 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3310 gfc_trans_init_string_length (sym->ts.cl, &block);
3312 /* Emit a DECL_EXPR for this variable, which will cause the
3313 gimplifier to allocate storage, and all that good stuff. */
3314 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3315 gfc_add_expr_to_block (&block, tmp);
3320 gfc_add_expr_to_block (&block, fnbody);
3321 return gfc_finish_block (&block);
3324 type = TREE_TYPE (type);
3326 gcc_assert (!sym->attr.use_assoc);
3327 gcc_assert (!TREE_STATIC (decl));
3328 gcc_assert (!sym->module);
3330 if (sym->ts.type == BT_CHARACTER
3331 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3332 gfc_trans_init_string_length (sym->ts.cl, &block);
3334 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3336 /* Don't actually allocate space for Cray Pointees. */
3337 if (sym->attr.cray_pointee)
3339 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3340 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3341 gfc_add_expr_to_block (&block, fnbody);
3342 return gfc_finish_block (&block);
3345 /* The size is the number of elements in the array, so multiply by the
3346 size of an element to get the total size. */
3347 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3348 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3350 /* Allocate memory to hold the data. */
3351 tmp = gfc_chainon_list (NULL_TREE, size);
3353 if (gfc_index_integer_kind == 4)
3354 fndecl = gfor_fndecl_internal_malloc;
3355 else if (gfc_index_integer_kind == 8)
3356 fndecl = gfor_fndecl_internal_malloc64;
3359 tmp = build_function_call_expr (fndecl, tmp);
3360 tmp = fold (convert (TREE_TYPE (decl), tmp));
3361 gfc_add_modify_expr (&block, decl, tmp);
3363 /* Set offset of the array. */
3364 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3365 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3368 /* Automatic arrays should not have initializers. */
3369 gcc_assert (!sym->value);
3371 gfc_add_expr_to_block (&block, fnbody);
3373 /* Free the temporary. */
3374 tmp = convert (pvoid_type_node, decl);
3375 tmp = gfc_chainon_list (NULL_TREE, tmp);
3376 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3377 gfc_add_expr_to_block (&block, tmp);
3379 return gfc_finish_block (&block);
3383 /* Generate entry and exit code for g77 calling convention arrays. */
3386 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3395 gfc_get_backend_locus (&loc);
3396 gfc_set_backend_locus (&sym->declared_at);
3398 /* Descriptor type. */
3399 parm = sym->backend_decl;
3400 type = TREE_TYPE (parm);
3401 gcc_assert (GFC_ARRAY_TYPE_P (type));
3403 gfc_start_block (&block);
3405 if (sym->ts.type == BT_CHARACTER
3406 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3407 gfc_trans_init_string_length (sym->ts.cl, &block);
3409 /* Evaluate the bounds of the array. */
3410 gfc_trans_array_bounds (type, sym, &offset, &block);
3412 /* Set the offset. */
3413 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3414 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3416 /* Set the pointer itself if we aren't using the parameter directly. */
3417 if (TREE_CODE (parm) != PARM_DECL)
3419 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3420 gfc_add_modify_expr (&block, parm, tmp);
3422 tmp = gfc_finish_block (&block);
3424 gfc_set_backend_locus (&loc);
3426 gfc_start_block (&block);
3427 /* Add the initialization code to the start of the function. */
3428 gfc_add_expr_to_block (&block, tmp);
3429 gfc_add_expr_to_block (&block, body);
3431 return gfc_finish_block (&block);
3435 /* Modify the descriptor of an array parameter so that it has the
3436 correct lower bound. Also move the upper bound accordingly.
3437 If the array is not packed, it will be copied into a temporary.
3438 For each dimension we set the new lower and upper bounds. Then we copy the
3439 stride and calculate the offset for this dimension. We also work out
3440 what the stride of a packed array would be, and see it the two match.
3441 If the array need repacking, we set the stride to the values we just
3442 calculated, recalculate the offset and copy the array data.
3443 Code is also added to copy the data back at the end of the function.
3447 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3454 stmtblock_t cleanup;
3472 /* Do nothing for pointer and allocatable arrays. */
3473 if (sym->attr.pointer || sym->attr.allocatable)
3476 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3477 return gfc_trans_g77_array (sym, body);
3479 gfc_get_backend_locus (&loc);
3480 gfc_set_backend_locus (&sym->declared_at);
3482 /* Descriptor type. */
3483 type = TREE_TYPE (tmpdesc);
3484 gcc_assert (GFC_ARRAY_TYPE_P (type));
3485 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3486 dumdesc = build_fold_indirect_ref (dumdesc);
3487 gfc_start_block (&block);
3489 if (sym->ts.type == BT_CHARACTER
3490 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3491 gfc_trans_init_string_length (sym->ts.cl, &block);
3493 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3495 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3496 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3498 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3500 /* For non-constant shape arrays we only check if the first dimension
3501 is contiguous. Repacking higher dimensions wouldn't gain us
3502 anything as we still don't know the array stride. */
3503 partial = gfc_create_var (boolean_type_node, "partial");
3504 TREE_USED (partial) = 1;
3505 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3506 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3507 gfc_add_modify_expr (&block, partial, tmp);
3511 partial = NULL_TREE;
3514 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3515 here, however I think it does the right thing. */
3518 /* Set the first stride. */
3519 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3520 stride = gfc_evaluate_now (stride, &block);
3522 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3523 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3524 gfc_index_one_node, stride);
3525 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3526 gfc_add_modify_expr (&block, stride, tmp);
3528 /* Allow the user to disable array repacking. */
3529 stmt_unpacked = NULL_TREE;
3533 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3534 /* A library call to repack the array if necessary. */
3535 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3536 tmp = gfc_chainon_list (NULL_TREE, tmp);
3537 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
3539 stride = gfc_index_one_node;
3542 /* This is for the case where the array data is used directly without
3543 calling the repack function. */
3544 if (no_repack || partial != NULL_TREE)
3545 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3547 stmt_packed = NULL_TREE;
3549 /* Assign the data pointer. */
3550 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3552 /* Don't repack unknown shape arrays when the first stride is 1. */
3553 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3554 stmt_packed, stmt_unpacked);
3557 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3558 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3560 offset = gfc_index_zero_node;
3561 size = gfc_index_one_node;
3563 /* Evaluate the bounds of the array. */
3564 for (n = 0; n < sym->as->rank; n++)
3566 if (checkparm || !sym->as->upper[n])
3568 /* Get the bounds of the actual parameter. */
3569 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3570 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3574 dubound = NULL_TREE;
3575 dlbound = NULL_TREE;
3578 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3579 if (!INTEGER_CST_P (lbound))
3581 gfc_init_se (&se, NULL);
3582 gfc_conv_expr_type (&se, sym->as->lower[n],
3583 gfc_array_index_type);
3584 gfc_add_block_to_block (&block, &se.pre);
3585 gfc_add_modify_expr (&block, lbound, se.expr);
3588 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3589 /* Set the desired upper bound. */
3590 if (sym->as->upper[n])
3592 /* We know what we want the upper bound to be. */
3593 if (!INTEGER_CST_P (ubound))
3595 gfc_init_se (&se, NULL);
3596 gfc_conv_expr_type (&se, sym->as->upper[n],
3597 gfc_array_index_type);
3598 gfc_add_block_to_block (&block, &se.pre);
3599 gfc_add_modify_expr (&block, ubound, se.expr);
3602 /* Check the sizes match. */
3605 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3607 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3609 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3611 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3612 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3617 /* For assumed shape arrays move the upper bound by the same amount
3618 as the lower bound. */
3619 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3620 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3621 gfc_add_modify_expr (&block, ubound, tmp);
3623 /* The offset of this dimension. offset = offset - lbound * stride. */
3624 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3625 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3627 /* The size of this dimension, and the stride of the next. */
3628 if (n + 1 < sym->as->rank)
3630 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3632 if (no_repack || partial != NULL_TREE)
3635 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3638 /* Figure out the stride if not a known constant. */
3639 if (!INTEGER_CST_P (stride))
3642 stmt_packed = NULL_TREE;
3645 /* Calculate stride = size * (ubound + 1 - lbound). */
3646 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3647 gfc_index_one_node, lbound);
3648 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3650 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3655 /* Assign the stride. */
3656 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3657 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3658 stmt_unpacked, stmt_packed);
3660 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3661 gfc_add_modify_expr (&block, stride, tmp);
3666 /* Set the offset. */
3667 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3668 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3670 stmt = gfc_finish_block (&block);
3672 gfc_start_block (&block);
3674 /* Only do the entry/initialization code if the arg is present. */
3675 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3676 optional_arg = (sym->attr.optional
3677 || (sym->ns->proc_name->attr.entry_master
3678 && sym->attr.dummy));
3681 tmp = gfc_conv_expr_present (sym);
3682 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3684 gfc_add_expr_to_block (&block, stmt);
3686 /* Add the main function body. */
3687 gfc_add_expr_to_block (&block, body);
3692 gfc_start_block (&cleanup);
3694 if (sym->attr.intent != INTENT_IN)
3696 /* Copy the data back. */
3697 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3698 tmp = gfc_chainon_list (tmp, tmpdesc);
3699 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
3700 gfc_add_expr_to_block (&cleanup, tmp);
3703 /* Free the temporary. */
3704 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3705 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3706 gfc_add_expr_to_block (&cleanup, tmp);
3708 stmt = gfc_finish_block (&cleanup);
3710 /* Only do the cleanup if the array was repacked. */
3711 tmp = build_fold_indirect_ref (dumdesc);
3712 tmp = gfc_conv_descriptor_data_get (tmp);
3713 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3714 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3718 tmp = gfc_conv_expr_present (sym);
3719 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3721 gfc_add_expr_to_block (&block, stmt);
3723 /* We don't need to free any memory allocated by internal_pack as it will
3724 be freed at the end of the function by pop_context. */
3725 return gfc_finish_block (&block);
3729 /* Convert an array for passing as an actual argument. Expressions and
3730 vector subscripts are evaluated and stored in a temporary, which is then
3731 passed. For whole arrays the descriptor is passed. For array sections
3732 a modified copy of the descriptor is passed, but using the original data.
3734 This function is also used for array pointer assignments, and there
3737 - want_pointer && !se->direct_byref
3738 EXPR is an actual argument. On exit, se->expr contains a
3739 pointer to the array descriptor.
3741 - !want_pointer && !se->direct_byref
3742 EXPR is an actual argument to an intrinsic function or the
3743 left-hand side of a pointer assignment. On exit, se->expr
3744 contains the descriptor for EXPR.
3746 - !want_pointer && se->direct_byref
3747 EXPR is the right-hand side of a pointer assignment and
3748 se->expr is the descriptor for the previously-evaluated
3749 left-hand side. The function creates an assignment from
3750 EXPR to se->expr. */
3753 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3768 gcc_assert (ss != gfc_ss_terminator);
3770 /* TODO: Pass constant array constructors without a temporary. */
3771 /* Special case things we know we can pass easily. */
3772 switch (expr->expr_type)
3775 /* If we have a linear array section, we can pass it directly.
3776 Otherwise we need to copy it into a temporary. */
3778 /* Find the SS for the array section. */
3780 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3781 secss = secss->next;
3783 gcc_assert (secss != gfc_ss_terminator);
3784 info = &secss->data.info;
3786 /* Get the descriptor for the array. */
3787 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3788 desc = info->descriptor;
3790 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
3793 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3795 /* Create a new descriptor if the array doesn't have one. */
3798 else if (info->ref->u.ar.type == AR_FULL)
3800 else if (se->direct_byref)
3805 gcc_assert (ref->u.ar.type == AR_SECTION);
3808 for (n = 0; n < ref->u.ar.dimen; n++)
3810 /* Detect passing the full array as a section. This could do
3811 even more checking, but it doesn't seem worth it. */
3812 if (ref->u.ar.start[n]
3814 || (ref->u.ar.stride[n]
3815 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3825 if (se->direct_byref)
3827 /* Copy the descriptor for pointer assignments. */
3828 gfc_add_modify_expr (&se->pre, se->expr, desc);
3830 else if (se->want_pointer)
3832 /* We pass full arrays directly. This means that pointers and
3833 allocatable arrays should also work. */
3834 se->expr = build_fold_addr_expr (desc);
3841 if (expr->ts.type == BT_CHARACTER)
3842 se->string_length = gfc_get_expr_charlen (expr);
3849 /* A transformational function return value will be a temporary
3850 array descriptor. We still need to go through the scalarizer
3851 to create the descriptor. Elemental functions ar handled as
3852 arbitrary expressions, i.e. copy to a temporary. */
3854 /* Look for the SS for this function. */
3855 while (secss != gfc_ss_terminator
3856 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3857 secss = secss->next;
3859 if (se->direct_byref)
3861 gcc_assert (secss != gfc_ss_terminator);
3863 /* For pointer assignments pass the descriptor directly. */
3865 se->expr = build_fold_addr_expr (se->expr);
3866 gfc_conv_expr (se, expr);
3870 if (secss == gfc_ss_terminator)
3872 /* Elemental function. */
3878 /* Transformational function. */
3879 info = &secss->data.info;
3885 /* Something complicated. Copy it into a temporary. */
3893 gfc_init_loopinfo (&loop);
3895 /* Associate the SS with the loop. */
3896 gfc_add_ss_to_loop (&loop, ss);
3898 /* Tell the scalarizer not to bother creating loop variables, etc. */
3900 loop.array_parameter = 1;
3902 /* The right-hand side of a pointer assignment mustn't use a temporary. */
3903 gcc_assert (!se->direct_byref);
3905 /* Setup the scalarizing loops and bounds. */
3906 gfc_conv_ss_startstride (&loop);
3910 /* Tell the scalarizer to make a temporary. */
3911 loop.temp_ss = gfc_get_ss ();
3912 loop.temp_ss->type = GFC_SS_TEMP;
3913 loop.temp_ss->next = gfc_ss_terminator;
3914 if (expr->ts.type == BT_CHARACTER)
3916 gcc_assert (expr->ts.cl && expr->ts.cl->length
3917 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3918 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3919 (expr->ts.cl->length->value.integer,
3920 expr->ts.cl->length->ts.kind);
3921 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3923 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3925 /* ... which can hold our string, if present. */
3926 if (expr->ts.type == BT_CHARACTER)
3928 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3929 se->string_length = loop.temp_ss->string_length;
3932 loop.temp_ss->string_length = NULL;
3933 loop.temp_ss->data.temp.dimen = loop.dimen;
3934 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3937 gfc_conv_loop_setup (&loop);
3941 /* Copy into a temporary and pass that. We don't need to copy the data
3942 back because expressions and vector subscripts must be INTENT_IN. */
3943 /* TODO: Optimize passing function return values. */
3947 /* Start the copying loops. */
3948 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3949 gfc_mark_ss_chain_used (ss, 1);
3950 gfc_start_scalarized_body (&loop, &block);
3952 /* Copy each data element. */
3953 gfc_init_se (&lse, NULL);
3954 gfc_copy_loopinfo_to_se (&lse, &loop);
3955 gfc_init_se (&rse, NULL);
3956 gfc_copy_loopinfo_to_se (&rse, &loop);
3958 lse.ss = loop.temp_ss;
3961 gfc_conv_scalarized_array_ref (&lse, NULL);
3962 if (expr->ts.type == BT_CHARACTER)
3964 gfc_conv_expr (&rse, expr);
3965 rse.expr = build_fold_indirect_ref (rse.expr);
3968 gfc_conv_expr_val (&rse, expr);
3970 gfc_add_block_to_block (&block, &rse.pre);
3971 gfc_add_block_to_block (&block, &lse.pre);
3973 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3975 /* Finish the copying loops. */
3976 gfc_trans_scalarizing_loops (&loop, &block);
3978 /* Set the first stride component to zero to indicate a temporary. */
3979 desc = loop.temp_ss->data.info.descriptor;
3980 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3981 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3983 gcc_assert (is_gimple_lvalue (desc));
3985 else if (expr->expr_type == EXPR_FUNCTION)
3987 desc = info->descriptor;
3988 se->string_length = ss->string_length;
3992 /* We pass sections without copying to a temporary. Make a new
3993 descriptor and point it at the section we want. The loop variable
3994 limits will be the limits of the section.
3995 A function may decide to repack the array to speed up access, but
3996 we're not bothered about that here. */
4005 /* Set the string_length for a character array. */
4006 if (expr->ts.type == BT_CHARACTER)
4007 se->string_length = gfc_get_expr_charlen (expr);
4009 desc = info->descriptor;
4010 gcc_assert (secss && secss != gfc_ss_terminator);
4011 if (se->direct_byref)
4013 /* For pointer assignments we fill in the destination. */
4015 parmtype = TREE_TYPE (parm);
4019 /* Otherwise make a new one. */
4020 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4021 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4022 loop.from, loop.to, 0);
4023 parm = gfc_create_var (parmtype, "parm");
4026 offset = gfc_index_zero_node;
4029 /* The following can be somewhat confusing. We have two
4030 descriptors, a new one and the original array.
4031 {parm, parmtype, dim} refer to the new one.
4032 {desc, type, n, secss, loop} refer to the original, which maybe
4033 a descriptorless array.
4034 The bounds of the scalarization are the bounds of the section.
4035 We don't have to worry about numeric overflows when calculating
4036 the offsets because all elements are within the array data. */
4038 /* Set the dtype. */
4039 tmp = gfc_conv_descriptor_dtype (parm);
4040 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4042 if (se->direct_byref)
4043 base = gfc_index_zero_node;
4047 for (n = 0; n < info->ref->u.ar.dimen; n++)
4049 stride = gfc_conv_array_stride (desc, n);
4051 /* Work out the offset. */
4052 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4054 gcc_assert (info->subscript[n]
4055 && info->subscript[n]->type == GFC_SS_SCALAR);
4056 start = info->subscript[n]->data.scalar.expr;
4060 /* Check we haven't somehow got out of sync. */
4061 gcc_assert (info->dim[dim] == n);
4063 /* Evaluate and remember the start of the section. */
4064 start = info->start[dim];
4065 stride = gfc_evaluate_now (stride, &loop.pre);
4068 tmp = gfc_conv_array_lbound (desc, n);
4069 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4071 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4072 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4074 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4076 /* For elemental dimensions, we only need the offset. */
4080 /* Vector subscripts need copying and are handled elsewhere. */
4081 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4083 /* Set the new lower bound. */
4084 from = loop.from[dim];
4087 /* If we have an array section or are assigning to a pointer,
4088 make sure that the lower bound is 1. References to the full
4089 array should otherwise keep the original bounds. */
4090 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4091 && !integer_onep (from))
4093 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4094 gfc_index_one_node, from);
4095 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4096 from = gfc_index_one_node;
4098 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4099 gfc_add_modify_expr (&loop.pre, tmp, from);
4101 /* Set the new upper bound. */
4102 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4103 gfc_add_modify_expr (&loop.pre, tmp, to);
4105 /* Multiply the stride by the section stride to get the
4107 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4108 stride, info->stride[dim]);
4110 if (se->direct_byref)
4111 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4114 /* Store the new stride. */
4115 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4116 gfc_add_modify_expr (&loop.pre, tmp, stride);
4121 /* Point the data pointer at the first element in the section. */
4122 tmp = gfc_conv_array_data (desc);
4123 tmp = build_fold_indirect_ref (tmp);
4124 tmp = gfc_build_array_ref (tmp, offset);
4125 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4126 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4128 if (se->direct_byref)
4130 /* Set the offset. */
4131 tmp = gfc_conv_descriptor_offset (parm);
4132 gfc_add_modify_expr (&loop.pre, tmp, base);
4136 /* Only the callee knows what the correct offset it, so just set
4138 tmp = gfc_conv_descriptor_offset (parm);
4139 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4144 if (!se->direct_byref)
4146 /* Get a pointer to the new descriptor. */
4147 if (se->want_pointer)
4148 se->expr = build_fold_addr_expr (desc);
4153 gfc_add_block_to_block (&se->pre, &loop.pre);
4154 gfc_add_block_to_block (&se->post, &loop.post);
4156 /* Cleanup the scalarizer. */
4157 gfc_cleanup_loop (&loop);
4161 /* Convert an array for passing as an actual parameter. */
4162 /* TODO: Optimize passing g77 arrays. */
4165 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4174 /* Passing address of the array if it is not pointer or assumed-shape. */
4175 if (expr->expr_type == EXPR_VARIABLE
4176 && expr->ref->u.ar.type == AR_FULL && g77)
4178 sym = expr->symtree->n.sym;
4179 tmp = gfc_get_symbol_decl (sym);
4181 if (sym->ts.type == BT_CHARACTER)
4182 se->string_length = sym->ts.cl->backend_decl;
4183 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4184 && !sym->attr.allocatable)
4186 /* Some variables are declared directly, others are declared as
4187 pointers and allocated on the heap. */
4188 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4191 se->expr = build_fold_addr_expr (tmp);
4194 if (sym->attr.allocatable)
4196 se->expr = gfc_conv_array_data (tmp);
4201 se->want_pointer = 1;
4202 gfc_conv_expr_descriptor (se, expr, ss);
4207 /* Repack the array. */
4208 tmp = gfc_chainon_list (NULL_TREE, desc);
4209 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4210 ptr = gfc_evaluate_now (ptr, &se->pre);
4213 gfc_start_block (&block);
4215 /* Copy the data back. */
4216 tmp = gfc_chainon_list (NULL_TREE, desc);
4217 tmp = gfc_chainon_list (tmp, ptr);
4218 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4219 gfc_add_expr_to_block (&block, tmp);
4221 /* Free the temporary. */
4222 tmp = convert (pvoid_type_node, ptr);
4223 tmp = gfc_chainon_list (NULL_TREE, tmp);
4224 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4225 gfc_add_expr_to_block (&block, tmp);
4227 stmt = gfc_finish_block (&block);
4229 gfc_init_block (&block);
4230 /* Only if it was repacked. This code needs to be executed before the
4231 loop cleanup code. */
4232 tmp = build_fold_indirect_ref (desc);
4233 tmp = gfc_conv_array_data (tmp);
4234 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4235 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4237 gfc_add_expr_to_block (&block, tmp);
4238 gfc_add_block_to_block (&block, &se->post);
4240 gfc_init_block (&se->post);
4241 gfc_add_block_to_block (&se->post, &block);
4246 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4249 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4256 stmtblock_t fnblock;
4259 /* Make sure the frontend gets these right. */
4260 if (!(sym->attr.pointer || sym->attr.allocatable))
4262 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4264 gfc_init_block (&fnblock);
4266 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4267 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4269 if (sym->ts.type == BT_CHARACTER
4270 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4271 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4273 /* Dummy and use associated variables don't need anything special. */
4274 if (sym->attr.dummy || sym->attr.use_assoc)
4276 gfc_add_expr_to_block (&fnblock, body);
4278 return gfc_finish_block (&fnblock);
4281 gfc_get_backend_locus (&loc);
4282 gfc_set_backend_locus (&sym->declared_at);
4283 descriptor = sym->backend_decl;
4285 if (TREE_STATIC (descriptor))
4287 /* SAVEd variables are not freed on exit. */
4288 gfc_trans_static_array_pointer (sym);
4292 /* Get the descriptor type. */
4293 type = TREE_TYPE (sym->backend_decl);
4294 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4296 /* NULLIFY the data pointer. */
4297 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4299 gfc_add_expr_to_block (&fnblock, body);
4301 gfc_set_backend_locus (&loc);
4302 /* Allocatable arrays need to be freed when they go out of scope. */
4303 if (sym->attr.allocatable)
4305 gfc_start_block (&block);
4307 /* Deallocate if still allocated at the end of the procedure. */
4308 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4310 tmp = gfc_conv_descriptor_data_get (descriptor);
4311 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4312 build_int_cst (TREE_TYPE (tmp), 0));
4313 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4314 gfc_add_expr_to_block (&block, tmp);
4316 tmp = gfc_finish_block (&block);
4317 gfc_add_expr_to_block (&fnblock, tmp);
4320 return gfc_finish_block (&fnblock);
4323 /************ Expression Walking Functions ******************/
4325 /* Walk a variable reference.
4327 Possible extension - multiple component subscripts.
4328 x(:,:) = foo%a(:)%b(:)
4330 forall (i=..., j=...)
4331 x(i,j) = foo%a(j)%b(i)
4333 This adds a fair amout of complexity because you need to deal with more
4334 than one ref. Maybe handle in a similar manner to vector subscripts.
4335 Maybe not worth the effort. */
4339 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4347 for (ref = expr->ref; ref; ref = ref->next)
4348 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4351 for (; ref; ref = ref->next)
4353 if (ref->type == REF_SUBSTRING)
4355 newss = gfc_get_ss ();
4356 newss->type = GFC_SS_SCALAR;
4357 newss->expr = ref->u.ss.start;
4361 newss = gfc_get_ss ();
4362 newss->type = GFC_SS_SCALAR;
4363 newss->expr = ref->u.ss.end;
4368 /* We're only interested in array sections from now on. */
4369 if (ref->type != REF_ARRAY)
4376 for (n = 0; n < ar->dimen; n++)
4378 newss = gfc_get_ss ();
4379 newss->type = GFC_SS_SCALAR;
4380 newss->expr = ar->start[n];
4387 newss = gfc_get_ss ();
4388 newss->type = GFC_SS_SECTION;
4391 newss->data.info.dimen = ar->as->rank;
4392 newss->data.info.ref = ref;
4394 /* Make sure array is the same as array(:,:), this way
4395 we don't need to special case all the time. */
4396 ar->dimen = ar->as->rank;
4397 for (n = 0; n < ar->dimen; n++)
4399 newss->data.info.dim[n] = n;
4400 ar->dimen_type[n] = DIMEN_RANGE;
4402 gcc_assert (ar->start[n] == NULL);
4403 gcc_assert (ar->end[n] == NULL);
4404 gcc_assert (ar->stride[n] == NULL);
4410 newss = gfc_get_ss ();
4411 newss->type = GFC_SS_SECTION;
4414 newss->data.info.dimen = 0;
4415 newss->data.info.ref = ref;
4419 /* We add SS chains for all the subscripts in the section. */
4420 for (n = 0; n < ar->dimen; n++)
4424 switch (ar->dimen_type[n])
4427 /* Add SS for elemental (scalar) subscripts. */
4428 gcc_assert (ar->start[n]);
4429 indexss = gfc_get_ss ();
4430 indexss->type = GFC_SS_SCALAR;
4431 indexss->expr = ar->start[n];
4432 indexss->next = gfc_ss_terminator;
4433 indexss->loop_chain = gfc_ss_terminator;
4434 newss->data.info.subscript[n] = indexss;
4438 /* We don't add anything for sections, just remember this
4439 dimension for later. */
4440 newss->data.info.dim[newss->data.info.dimen] = n;
4441 newss->data.info.dimen++;
4445 /* Create a GFC_SS_VECTOR index in which we can store
4446 the vector's descriptor. */
4447 indexss = gfc_get_ss ();
4448 indexss->type = GFC_SS_VECTOR;
4449 indexss->expr = ar->start[n];
4450 indexss->next = gfc_ss_terminator;
4451 indexss->loop_chain = gfc_ss_terminator;
4452 newss->data.info.subscript[n] = indexss;
4453 newss->data.info.dim[newss->data.info.dimen] = n;
4454 newss->data.info.dimen++;
4458 /* We should know what sort of section it is by now. */
4462 /* We should have at least one non-elemental dimension. */
4463 gcc_assert (newss->data.info.dimen > 0);
4468 /* We should know what sort of section it is by now. */
4477 /* Walk an expression operator. If only one operand of a binary expression is
4478 scalar, we must also add the scalar term to the SS chain. */
4481 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4487 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4488 if (expr->value.op.op2 == NULL)
4491 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4493 /* All operands are scalar. Pass back and let the caller deal with it. */
4497 /* All operands require scalarization. */
4498 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4501 /* One of the operands needs scalarization, the other is scalar.
4502 Create a gfc_ss for the scalar expression. */
4503 newss = gfc_get_ss ();
4504 newss->type = GFC_SS_SCALAR;
4507 /* First operand is scalar. We build the chain in reverse order, so
4508 add the scarar SS after the second operand. */
4510 while (head && head->next != ss)
4512 /* Check we haven't somehow broken the chain. */
4516 newss->expr = expr->value.op.op1;
4518 else /* head2 == head */
4520 gcc_assert (head2 == head);
4521 /* Second operand is scalar. */
4522 newss->next = head2;
4524 newss->expr = expr->value.op.op2;
4531 /* Reverse a SS chain. */
4534 gfc_reverse_ss (gfc_ss * ss)
4539 gcc_assert (ss != NULL);
4541 head = gfc_ss_terminator;
4542 while (ss != gfc_ss_terminator)
4545 /* Check we didn't somehow break the chain. */
4546 gcc_assert (next != NULL);
4556 /* Walk the arguments of an elemental function. */
4559 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
4567 head = gfc_ss_terminator;
4570 for (; arg; arg = arg->next)
4575 newss = gfc_walk_subexpr (head, arg->expr);
4578 /* Scalar argument. */
4579 newss = gfc_get_ss ();
4581 newss->expr = arg->expr;
4591 while (tail->next != gfc_ss_terminator)
4598 /* If all the arguments are scalar we don't need the argument SS. */
4599 gfc_free_ss_chain (head);
4604 /* Add it onto the existing chain. */
4610 /* Walk a function call. Scalar functions are passed back, and taken out of
4611 scalarization loops. For elemental functions we walk their arguments.
4612 The result of functions returning arrays is stored in a temporary outside
4613 the loop, so that the function is only called once. Hence we do not need
4614 to walk their arguments. */
4617 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4620 gfc_intrinsic_sym *isym;
4623 isym = expr->value.function.isym;
4625 /* Handle intrinsic functions separately. */
4627 return gfc_walk_intrinsic_function (ss, expr, isym);
4629 sym = expr->value.function.esym;
4631 sym = expr->symtree->n.sym;
4633 /* A function that returns arrays. */
4634 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4636 newss = gfc_get_ss ();
4637 newss->type = GFC_SS_FUNCTION;
4640 newss->data.info.dimen = expr->rank;
4644 /* Walk the parameters of an elemental function. For now we always pass
4646 if (sym->attr.elemental)
4647 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
4650 /* Scalar functions are OK as these are evaluated outside the scalarization
4651 loop. Pass back and let the caller deal with it. */
4656 /* An array temporary is constructed for array constructors. */
4659 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4664 newss = gfc_get_ss ();
4665 newss->type = GFC_SS_CONSTRUCTOR;
4668 newss->data.info.dimen = expr->rank;
4669 for (n = 0; n < expr->rank; n++)
4670 newss->data.info.dim[n] = n;
4676 /* Walk an expression. Add walked expressions to the head of the SS chain.
4677 A wholly scalar expression will not be added. */
4680 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4684 switch (expr->expr_type)
4687 head = gfc_walk_variable_expr (ss, expr);
4691 head = gfc_walk_op_expr (ss, expr);
4695 head = gfc_walk_function_expr (ss, expr);
4700 case EXPR_STRUCTURE:
4701 /* Pass back and let the caller deal with it. */
4705 head = gfc_walk_array_constructor (ss, expr);
4708 case EXPR_SUBSTRING:
4709 /* Pass back and let the caller deal with it. */
4713 internal_error ("bad expression type during walk (%d)",
4720 /* Entry point for expression walking.
4721 A return value equal to the passed chain means this is
4722 a scalar expression. It is up to the caller to take whatever action is
4723 necessary to translate these. */
4726 gfc_walk_expr (gfc_expr * expr)
4730 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4731 return gfc_reverse_ss (res);