1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field. */
161 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
165 type = TREE_TYPE (desc);
166 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
168 field = TYPE_FIELDS (type);
169 gcc_assert (DATA_FIELD == 0);
171 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
172 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
176 /* This provides address access to the data field. This should only be
177 used by array allocation, passing this on to the runtime. */
180 gfc_conv_descriptor_data_addr (tree desc)
184 type = TREE_TYPE (desc);
185 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
187 field = TYPE_FIELDS (type);
188 gcc_assert (DATA_FIELD == 0);
190 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
191 return gfc_build_addr_expr (NULL, t);
195 gfc_conv_descriptor_offset (tree desc)
200 type = TREE_TYPE (desc);
201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
203 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
204 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
206 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
210 gfc_conv_descriptor_dtype (tree desc)
215 type = TREE_TYPE (desc);
216 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
218 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
219 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
221 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
225 gfc_conv_descriptor_dimension (tree desc, tree dim)
231 type = TREE_TYPE (desc);
232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
234 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
235 gcc_assert (field != NULL_TREE
236 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
237 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
239 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
240 tmp = gfc_build_array_ref (tmp, dim);
245 gfc_conv_descriptor_stride (tree desc, tree dim)
250 tmp = gfc_conv_descriptor_dimension (desc, dim);
251 field = TYPE_FIELDS (TREE_TYPE (tmp));
252 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
253 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
255 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
260 gfc_conv_descriptor_lbound (tree desc, tree dim)
265 tmp = gfc_conv_descriptor_dimension (desc, dim);
266 field = TYPE_FIELDS (TREE_TYPE (tmp));
267 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
268 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
270 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
275 gfc_conv_descriptor_ubound (tree desc, tree dim)
280 tmp = gfc_conv_descriptor_dimension (desc, dim);
281 field = TYPE_FIELDS (TREE_TYPE (tmp));
282 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
285 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
290 /* Build a null array descriptor constructor. */
293 gfc_build_null_descriptor (tree type)
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
299 gcc_assert (DATA_FIELD == 0);
300 field = TYPE_FIELDS (type);
302 /* Set a NULL data pointer. */
303 tmp = build_constructor_single (type, field, null_pointer_node);
304 TREE_CONSTANT (tmp) = 1;
305 TREE_INVARIANT (tmp) = 1;
306 /* All other fields are ignored. */
312 /* Cleanup those #defines. */
317 #undef DIMENSION_FIELD
318 #undef STRIDE_SUBFIELD
319 #undef LBOUND_SUBFIELD
320 #undef UBOUND_SUBFIELD
323 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
324 flags & 1 = Main loop body.
325 flags & 2 = temp copy loop. */
328 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
330 for (; ss != gfc_ss_terminator; ss = ss->next)
331 ss->useflags = flags;
334 static void gfc_free_ss (gfc_ss *);
337 /* Free a gfc_ss chain. */
340 gfc_free_ss_chain (gfc_ss * ss)
344 while (ss != gfc_ss_terminator)
346 gcc_assert (ss != NULL);
357 gfc_free_ss (gfc_ss * ss)
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 /* Generate code to allocate an array temporary, or create a variable to
437 hold the data. If size is NULL zero the descriptor so that so that the
438 callee will allocate the array. Also generates code to free the array
441 DYNAMIC is true if the caller may want to extend the array later
442 using realloc. This prevents us from putting the array on the stack. */
445 gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
446 tree size, tree nelem, bool dynamic)
453 desc = info->descriptor;
454 info->offset = gfc_index_zero_node;
455 if (size == NULL_TREE || integer_zerop (size))
457 /* A callee allocated array. */
458 gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
463 /* Allocate the temporary. */
464 onstack = !dynamic && gfc_can_put_var_on_stack (size);
468 /* Make a temporary variable to hold the data. */
469 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
471 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
473 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
475 tmp = gfc_create_var (tmp, "A");
476 tmp = gfc_build_addr_expr (NULL, tmp);
477 gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
481 /* Allocate memory to hold the data. */
482 args = gfc_chainon_list (NULL_TREE, size);
484 if (gfc_index_integer_kind == 4)
485 tmp = gfor_fndecl_internal_malloc;
486 else if (gfc_index_integer_kind == 8)
487 tmp = gfor_fndecl_internal_malloc64;
490 tmp = gfc_build_function_call (tmp, args);
491 tmp = gfc_evaluate_now (tmp, &loop->pre);
492 gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
495 info->data = gfc_conv_descriptor_data_get (desc);
497 /* The offset is zero because we create temporaries with a zero
499 tmp = gfc_conv_descriptor_offset (desc);
500 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
504 /* Free the temporary. */
505 tmp = gfc_conv_descriptor_data_get (desc);
506 tmp = fold_convert (pvoid_type_node, tmp);
507 tmp = gfc_chainon_list (NULL_TREE, tmp);
508 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
509 gfc_add_expr_to_block (&loop->post, tmp);
514 /* Generate code to allocate and initialize the descriptor for a temporary
515 array. This is used for both temporaries needed by the scalarizer, and
516 functions returning arrays. Adjusts the loop variables to be zero-based,
517 and calculates the loop bounds for callee allocated arrays.
518 Also fills in the descriptor, data and offset fields of info if known.
519 Returns the size of the array, or NULL for a callee allocated array.
521 DYNAMIC is as for gfc_trans_allocate_array_storage. */
524 gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
525 tree eltype, bool dynamic)
535 gcc_assert (info->dimen > 0);
536 /* Set the lower bound to zero. */
537 for (dim = 0; dim < info->dimen; dim++)
539 n = loop->order[dim];
540 if (n < loop->temp_dim)
541 gcc_assert (integer_zerop (loop->from[n]));
544 /* Callee allocated arrays may not have a known bound yet. */
546 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
547 loop->to[n], loop->from[n]);
548 loop->from[n] = gfc_index_zero_node;
551 info->delta[dim] = gfc_index_zero_node;
552 info->start[dim] = gfc_index_zero_node;
553 info->stride[dim] = gfc_index_one_node;
554 info->dim[dim] = dim;
557 /* Initialize the descriptor. */
559 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
560 desc = gfc_create_var (type, "atmp");
561 GFC_DECL_PACKED_ARRAY (desc) = 1;
563 info->descriptor = desc;
564 size = gfc_index_one_node;
566 /* Fill in the array dtype. */
567 tmp = gfc_conv_descriptor_dtype (desc);
568 gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
571 Fill in the bounds and stride. This is a packed array, so:
574 for (n = 0; n < rank; n++)
577 delta = ubound[n] + 1 - lbound[n];
580 size = size * sizeof(element);
583 for (n = 0; n < info->dimen; n++)
585 if (loop->to[n] == NULL_TREE)
587 /* For a callee allocated array express the loop bounds in terms
588 of the descriptor fields. */
589 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
590 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
591 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
597 /* Store the stride and bound components in the descriptor. */
598 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
599 gfc_add_modify_expr (&loop->pre, tmp, size);
601 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
602 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
604 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
605 gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
607 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
608 loop->to[n], gfc_index_one_node);
610 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
611 size = gfc_evaluate_now (size, &loop->pre);
614 /* Get the size of the array. */
617 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
618 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
620 gfc_trans_allocate_array_storage (loop, info, size, nelem, dynamic);
622 if (info->dimen > loop->temp_dim)
623 loop->temp_dim = info->dimen;
629 /* Return the number of iterations in a loop that starts at START,
630 ends at END, and has step STEP. */
633 gfc_get_iteration_count (tree start, tree end, tree step)
638 type = TREE_TYPE (step);
639 tmp = fold_build2 (MINUS_EXPR, type, end, start);
640 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
641 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
642 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
643 return fold_convert (gfc_array_index_type, tmp);
647 /* Extend the data in array DESC by EXTRA elements. */
650 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
657 if (integer_zerop (extra))
660 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
662 /* Add EXTRA to the upper bound. */
663 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
664 gfc_add_modify_expr (pblock, ubound, tmp);
666 /* Get the value of the current data pointer. */
667 tmp = gfc_conv_descriptor_data_get (desc);
668 args = gfc_chainon_list (NULL_TREE, tmp);
670 /* Calculate the new array size. */
671 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
672 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
673 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
674 args = gfc_chainon_list (args, tmp);
676 /* Pick the appropriate realloc function. */
677 if (gfc_index_integer_kind == 4)
678 tmp = gfor_fndecl_internal_realloc;
679 else if (gfc_index_integer_kind == 8)
680 tmp = gfor_fndecl_internal_realloc64;
684 /* Set the new data pointer. */
685 tmp = gfc_build_function_call (tmp, args);
686 gfc_conv_descriptor_data_set (pblock, desc, tmp);
690 /* Return true if the bounds of iterator I can only be determined
694 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
696 return (i->start->expr_type != EXPR_CONSTANT
697 || i->end->expr_type != EXPR_CONSTANT
698 || i->step->expr_type != EXPR_CONSTANT);
702 /* Split the size of constructor element EXPR into the sum of two terms,
703 one of which can be determined at compile time and one of which must
704 be calculated at run time. Set *SIZE to the former and return true
705 if the latter might be nonzero. */
708 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
710 if (expr->expr_type == EXPR_ARRAY)
711 return gfc_get_array_constructor_size (size, expr->value.constructor);
712 else if (expr->rank > 0)
714 /* Calculate everything at run time. */
715 mpz_set_ui (*size, 0);
720 /* A single element. */
721 mpz_set_ui (*size, 1);
727 /* Like gfc_get_array_constructor_element_size, but applied to the whole
728 of array constructor C. */
731 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
738 mpz_set_ui (*size, 0);
743 for (; c; c = c->next)
746 if (i && gfc_iterator_has_dynamic_bounds (i))
750 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
753 /* Multiply the static part of the element size by the
754 number of iterations. */
755 mpz_sub (val, i->end->value.integer, i->start->value.integer);
756 mpz_fdiv_q (val, val, i->step->value.integer);
757 mpz_add_ui (val, val, 1);
758 if (mpz_sgn (val) > 0)
759 mpz_mul (len, len, val);
763 mpz_add (*size, *size, len);
772 /* Make sure offset is a variable. */
775 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
778 /* We should have already created the offset variable. We cannot
779 create it here because we may be in an inner scope. */
780 gcc_assert (*offsetvar != NULL_TREE);
781 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
782 *poffset = *offsetvar;
783 TREE_USED (*offsetvar) = 1;
787 /* Assign an element of an array constructor. */
790 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
791 tree offset, gfc_se * se, gfc_expr * expr)
796 gfc_conv_expr (se, expr);
798 /* Store the value. */
799 tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
800 tmp = gfc_build_array_ref (tmp, offset);
801 if (expr->ts.type == BT_CHARACTER)
803 gfc_conv_string_parameter (se);
804 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
806 /* The temporary is an array of pointers. */
807 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
808 gfc_add_modify_expr (&se->pre, tmp, se->expr);
812 /* The temporary is an array of string values. */
813 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
814 /* We know the temporary and the value will be the same length,
815 so can use memcpy. */
816 args = gfc_chainon_list (NULL_TREE, tmp);
817 args = gfc_chainon_list (args, se->expr);
818 args = gfc_chainon_list (args, se->string_length);
819 tmp = built_in_decls[BUILT_IN_MEMCPY];
820 tmp = gfc_build_function_call (tmp, args);
821 gfc_add_expr_to_block (&se->pre, tmp);
826 /* TODO: Should the frontend already have done this conversion? */
827 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
828 gfc_add_modify_expr (&se->pre, tmp, se->expr);
831 gfc_add_block_to_block (pblock, &se->pre);
832 gfc_add_block_to_block (pblock, &se->post);
836 /* Add the contents of an array to the constructor. DYNAMIC is as for
837 gfc_trans_array_constructor_value. */
840 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
841 tree type ATTRIBUTE_UNUSED,
842 tree desc, gfc_expr * expr,
843 tree * poffset, tree * offsetvar,
854 /* We need this to be a variable so we can increment it. */
855 gfc_put_offset_into_var (pblock, poffset, offsetvar);
857 gfc_init_se (&se, NULL);
859 /* Walk the array expression. */
860 ss = gfc_walk_expr (expr);
861 gcc_assert (ss != gfc_ss_terminator);
863 /* Initialize the scalarizer. */
864 gfc_init_loopinfo (&loop);
865 gfc_add_ss_to_loop (&loop, ss);
867 /* Initialize the loop. */
868 gfc_conv_ss_startstride (&loop);
869 gfc_conv_loop_setup (&loop);
871 /* Make sure the constructed array has room for the new data. */
874 /* Set SIZE to the total number of elements in the subarray. */
875 size = gfc_index_one_node;
876 for (n = 0; n < loop.dimen; n++)
878 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
880 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
883 /* Grow the constructed array by SIZE elements. */
884 gfc_grow_array (&loop.pre, desc, size);
887 /* Make the loop body. */
888 gfc_mark_ss_chain_used (ss, 1);
889 gfc_start_scalarized_body (&loop, &body);
890 gfc_copy_loopinfo_to_se (&se, &loop);
893 if (expr->ts.type == BT_CHARACTER)
894 gfc_todo_error ("character arrays in constructors");
896 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
897 gcc_assert (se.ss == gfc_ss_terminator);
899 /* Increment the offset. */
900 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
901 gfc_add_modify_expr (&body, *poffset, tmp);
903 /* Finish the loop. */
904 gfc_trans_scalarizing_loops (&loop, &body);
905 gfc_add_block_to_block (&loop.pre, &loop.post);
906 tmp = gfc_finish_block (&loop.pre);
907 gfc_add_expr_to_block (pblock, tmp);
909 gfc_cleanup_loop (&loop);
913 /* Assign the values to the elements of an array constructor. DYNAMIC
914 is true if descriptor DESC only contains enough data for the static
915 size calculated by gfc_get_array_constructor_size. When true, memory
916 for the dynamic parts must be allocated using realloc. */
919 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
920 tree desc, gfc_constructor * c,
921 tree * poffset, tree * offsetvar,
930 for (; c; c = c->next)
932 /* If this is an iterator or an array, the offset must be a variable. */
933 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
934 gfc_put_offset_into_var (pblock, poffset, offsetvar);
936 gfc_start_block (&body);
938 if (c->expr->expr_type == EXPR_ARRAY)
940 /* Array constructors can be nested. */
941 gfc_trans_array_constructor_value (&body, type, desc,
942 c->expr->value.constructor,
943 poffset, offsetvar, dynamic);
945 else if (c->expr->rank > 0)
947 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
948 poffset, offsetvar, dynamic);
952 /* This code really upsets the gimplifier so don't bother for now. */
959 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
967 gfc_init_se (&se, NULL);
968 gfc_trans_array_ctor_element (&body, desc, *poffset,
971 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
972 *poffset, gfc_index_one_node);
976 /* Collect multiple scalar constants into a constructor. */
984 /* Count the number of consecutive scalar constants. */
985 while (p && !(p->iterator
986 || p->expr->expr_type != EXPR_CONSTANT))
988 gfc_init_se (&se, NULL);
989 gfc_conv_constant (&se, p->expr);
990 if (p->expr->ts.type == BT_CHARACTER
991 && POINTER_TYPE_P (type))
993 /* For constant character array constructors we build
994 an array of pointers. */
995 se.expr = gfc_build_addr_expr (pchar_type_node,
999 list = tree_cons (NULL_TREE, se.expr, list);
1004 bound = build_int_cst (NULL_TREE, n - 1);
1005 /* Create an array type to hold them. */
1006 tmptype = build_range_type (gfc_array_index_type,
1007 gfc_index_zero_node, bound);
1008 tmptype = build_array_type (type, tmptype);
1010 init = build_constructor_from_list (tmptype, nreverse (list));
1011 TREE_CONSTANT (init) = 1;
1012 TREE_INVARIANT (init) = 1;
1013 TREE_STATIC (init) = 1;
1014 /* Create a static variable to hold the data. */
1015 tmp = gfc_create_var (tmptype, "data");
1016 TREE_STATIC (tmp) = 1;
1017 TREE_CONSTANT (tmp) = 1;
1018 TREE_INVARIANT (tmp) = 1;
1019 DECL_INITIAL (tmp) = init;
1022 /* Use BUILTIN_MEMCPY to assign the values. */
1023 tmp = gfc_conv_descriptor_data_get (desc);
1024 tmp = gfc_build_indirect_ref (tmp);
1025 tmp = gfc_build_array_ref (tmp, *poffset);
1026 tmp = gfc_build_addr_expr (NULL, tmp);
1027 init = gfc_build_addr_expr (NULL, init);
1029 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1030 bound = build_int_cst (NULL_TREE, n * size);
1031 tmp = gfc_chainon_list (NULL_TREE, tmp);
1032 tmp = gfc_chainon_list (tmp, init);
1033 tmp = gfc_chainon_list (tmp, bound);
1034 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
1036 gfc_add_expr_to_block (&body, tmp);
1038 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1039 *poffset, build_int_cst (NULL_TREE, n));
1041 if (!INTEGER_CST_P (*poffset))
1043 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1044 *poffset = *offsetvar;
1048 /* The frontend should already have done any expansions possible
1052 /* Pass the code as is. */
1053 tmp = gfc_finish_block (&body);
1054 gfc_add_expr_to_block (pblock, tmp);
1058 /* Build the implied do-loop. */
1067 loopbody = gfc_finish_block (&body);
1069 gfc_init_se (&se, NULL);
1070 gfc_conv_expr (&se, c->iterator->var);
1071 gfc_add_block_to_block (pblock, &se.pre);
1074 /* Initialize the loop. */
1075 gfc_init_se (&se, NULL);
1076 gfc_conv_expr_val (&se, c->iterator->start);
1077 gfc_add_block_to_block (pblock, &se.pre);
1078 gfc_add_modify_expr (pblock, loopvar, se.expr);
1080 gfc_init_se (&se, NULL);
1081 gfc_conv_expr_val (&se, c->iterator->end);
1082 gfc_add_block_to_block (pblock, &se.pre);
1083 end = gfc_evaluate_now (se.expr, pblock);
1085 gfc_init_se (&se, NULL);
1086 gfc_conv_expr_val (&se, c->iterator->step);
1087 gfc_add_block_to_block (pblock, &se.pre);
1088 step = gfc_evaluate_now (se.expr, pblock);
1090 /* If this array expands dynamically, and the number of iterations
1091 is not constant, we won't have allocated space for the static
1092 part of C->EXPR's size. Do that now. */
1093 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1095 /* Get the number of iterations. */
1096 tmp = gfc_get_iteration_count (loopvar, end, step);
1098 /* Get the static part of C->EXPR's size. */
1099 gfc_get_array_constructor_element_size (&size, c->expr);
1100 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1102 /* Grow the array by TMP * TMP2 elements. */
1103 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1104 gfc_grow_array (pblock, desc, tmp);
1107 /* Generate the loop body. */
1108 exit_label = gfc_build_label_decl (NULL_TREE);
1109 gfc_start_block (&body);
1111 /* Generate the exit condition. Depending on the sign of
1112 the step variable we have to generate the correct
1114 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1115 build_int_cst (TREE_TYPE (step), 0));
1116 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1117 build2 (GT_EXPR, boolean_type_node,
1119 build2 (LT_EXPR, boolean_type_node,
1121 tmp = build1_v (GOTO_EXPR, exit_label);
1122 TREE_USED (exit_label) = 1;
1123 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1124 gfc_add_expr_to_block (&body, tmp);
1126 /* The main loop body. */
1127 gfc_add_expr_to_block (&body, loopbody);
1129 /* Increase loop variable by step. */
1130 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1131 gfc_add_modify_expr (&body, loopvar, tmp);
1133 /* Finish the loop. */
1134 tmp = gfc_finish_block (&body);
1135 tmp = build1_v (LOOP_EXPR, tmp);
1136 gfc_add_expr_to_block (pblock, tmp);
1138 /* Add the exit label. */
1139 tmp = build1_v (LABEL_EXPR, exit_label);
1140 gfc_add_expr_to_block (pblock, tmp);
1147 /* Figure out the string length of a variable reference expression.
1148 Used by get_array_ctor_strlen. */
1151 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1156 /* Don't bother if we already know the length is a constant. */
1157 if (*len && INTEGER_CST_P (*len))
1160 ts = &expr->symtree->n.sym->ts;
1161 for (ref = expr->ref; ref; ref = ref->next)
1166 /* Array references don't change the string length. */
1170 /* Use the length of the component. */
1171 ts = &ref->u.c.component->ts;
1175 /* TODO: Substrings are tricky because we can't evaluate the
1176 expression more than once. For now we just give up, and hope
1177 we can figure it out elsewhere. */
1182 *len = ts->cl->backend_decl;
1186 /* Figure out the string length of a character array constructor.
1187 Returns TRUE if all elements are character constants. */
1190 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1195 for (; c; c = c->next)
1197 switch (c->expr->expr_type)
1200 if (!(*len && INTEGER_CST_P (*len)))
1201 *len = build_int_cstu (gfc_charlen_type_node,
1202 c->expr->value.character.length);
1206 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1212 get_array_ctor_var_strlen (c->expr, len);
1217 /* TODO: For now we just ignore anything we don't know how to
1218 handle, and hope we can figure it out a different way. */
1227 /* Array constructors are handled by constructing a temporary, then using that
1228 within the scalarization loop. This is not optimal, but seems by far the
1232 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1242 ss->data.info.dimen = loop->dimen;
1244 c = ss->expr->value.constructor;
1245 if (ss->expr->ts.type == BT_CHARACTER)
1247 const_string = get_array_ctor_strlen (c, &ss->string_length);
1248 if (!ss->string_length)
1249 gfc_todo_error ("complex character array constructors");
1251 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1253 type = build_pointer_type (type);
1257 const_string = TRUE;
1258 type = gfc_typenode_for_spec (&ss->expr->ts);
1261 /* See if the constructor determines the loop bounds. */
1263 if (loop->to[0] == NULL_TREE)
1267 /* We should have a 1-dimensional, zero-based loop. */
1268 gcc_assert (loop->dimen == 1);
1269 gcc_assert (integer_zerop (loop->from[0]));
1271 /* Split the constructor size into a static part and a dynamic part.
1272 Allocate the static size up-front and record whether the dynamic
1273 size might be nonzero. */
1275 dynamic = gfc_get_array_constructor_size (&size, c);
1276 mpz_sub_ui (size, size, 1);
1277 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1281 gfc_trans_allocate_temp_array (loop, &ss->data.info, type, dynamic);
1283 desc = ss->data.info.descriptor;
1284 offset = gfc_index_zero_node;
1285 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1286 TREE_USED (offsetvar) = 0;
1287 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1288 &offset, &offsetvar, dynamic);
1290 /* If the array grows dynamically, the upper bound of the loop variable
1291 is determined by the array's final upper bound. */
1293 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1295 if (TREE_USED (offsetvar))
1296 pushdecl (offsetvar);
1298 gcc_assert (INTEGER_CST_P (offset));
1300 /* Disable bound checking for now because it's probably broken. */
1301 if (flag_bounds_check)
1309 /* Add the pre and post chains for all the scalar expressions in a SS chain
1310 to loop. This is called after the loop parameters have been calculated,
1311 but before the actual scalarizing loops. */
1314 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1319 /* TODO: This can generate bad code if there are ordering dependencies.
1320 eg. a callee allocated function and an unknown size constructor. */
1321 gcc_assert (ss != NULL);
1323 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1330 /* Scalar expression. Evaluate this now. This includes elemental
1331 dimension indices, but not array section bounds. */
1332 gfc_init_se (&se, NULL);
1333 gfc_conv_expr (&se, ss->expr);
1334 gfc_add_block_to_block (&loop->pre, &se.pre);
1336 if (ss->expr->ts.type != BT_CHARACTER)
1338 /* Move the evaluation of scalar expressions outside the
1339 scalarization loop. */
1341 se.expr = convert(gfc_array_index_type, se.expr);
1342 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1343 gfc_add_block_to_block (&loop->pre, &se.post);
1346 gfc_add_block_to_block (&loop->post, &se.post);
1348 ss->data.scalar.expr = se.expr;
1349 ss->string_length = se.string_length;
1352 case GFC_SS_REFERENCE:
1353 /* Scalar reference. Evaluate this now. */
1354 gfc_init_se (&se, NULL);
1355 gfc_conv_expr_reference (&se, ss->expr);
1356 gfc_add_block_to_block (&loop->pre, &se.pre);
1357 gfc_add_block_to_block (&loop->post, &se.post);
1359 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1360 ss->string_length = se.string_length;
1363 case GFC_SS_SECTION:
1365 /* Scalarized expression. Evaluate any scalar subscripts. */
1366 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1368 /* Add the expressions for scalar subscripts. */
1369 if (ss->data.info.subscript[n])
1370 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1374 case GFC_SS_INTRINSIC:
1375 gfc_add_intrinsic_ss_code (loop, ss);
1378 case GFC_SS_FUNCTION:
1379 /* Array function return value. We call the function and save its
1380 result in a temporary for use inside the loop. */
1381 gfc_init_se (&se, NULL);
1384 gfc_conv_expr (&se, ss->expr);
1385 gfc_add_block_to_block (&loop->pre, &se.pre);
1386 gfc_add_block_to_block (&loop->post, &se.post);
1387 ss->string_length = se.string_length;
1390 case GFC_SS_CONSTRUCTOR:
1391 gfc_trans_array_constructor (loop, ss);
1395 case GFC_SS_COMPONENT:
1396 /* Do nothing. These are handled elsewhere. */
1406 /* Translate expressions for the descriptor and data pointer of a SS. */
1410 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1415 /* Get the descriptor for the array to be scalarized. */
1416 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1417 gfc_init_se (&se, NULL);
1418 se.descriptor_only = 1;
1419 gfc_conv_expr_lhs (&se, ss->expr);
1420 gfc_add_block_to_block (block, &se.pre);
1421 ss->data.info.descriptor = se.expr;
1422 ss->string_length = se.string_length;
1426 /* Also the data pointer. */
1427 tmp = gfc_conv_array_data (se.expr);
1428 /* If this is a variable or address of a variable we use it directly.
1429 Otherwise we must evaluate it now to avoid breaking dependency
1430 analysis by pulling the expressions for elemental array indices
1433 || (TREE_CODE (tmp) == ADDR_EXPR
1434 && DECL_P (TREE_OPERAND (tmp, 0)))))
1435 tmp = gfc_evaluate_now (tmp, block);
1436 ss->data.info.data = tmp;
1438 tmp = gfc_conv_array_offset (se.expr);
1439 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1444 /* Initialize a gfc_loopinfo structure. */
1447 gfc_init_loopinfo (gfc_loopinfo * loop)
1451 memset (loop, 0, sizeof (gfc_loopinfo));
1452 gfc_init_block (&loop->pre);
1453 gfc_init_block (&loop->post);
1455 /* Initially scalarize in order. */
1456 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1459 loop->ss = gfc_ss_terminator;
1463 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1467 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1473 /* Return an expression for the data pointer of an array. */
1476 gfc_conv_array_data (tree descriptor)
1480 type = TREE_TYPE (descriptor);
1481 if (GFC_ARRAY_TYPE_P (type))
1483 if (TREE_CODE (type) == POINTER_TYPE)
1487 /* Descriptorless arrays. */
1488 return gfc_build_addr_expr (NULL, descriptor);
1492 return gfc_conv_descriptor_data_get (descriptor);
1496 /* Return an expression for the base offset of an array. */
1499 gfc_conv_array_offset (tree descriptor)
1503 type = TREE_TYPE (descriptor);
1504 if (GFC_ARRAY_TYPE_P (type))
1505 return GFC_TYPE_ARRAY_OFFSET (type);
1507 return gfc_conv_descriptor_offset (descriptor);
1511 /* Get an expression for the array stride. */
1514 gfc_conv_array_stride (tree descriptor, int dim)
1519 type = TREE_TYPE (descriptor);
1521 /* For descriptorless arrays use the array size. */
1522 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1523 if (tmp != NULL_TREE)
1526 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1531 /* Like gfc_conv_array_stride, but for the lower bound. */
1534 gfc_conv_array_lbound (tree descriptor, int dim)
1539 type = TREE_TYPE (descriptor);
1541 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1542 if (tmp != NULL_TREE)
1545 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1550 /* Like gfc_conv_array_stride, but for the upper bound. */
1553 gfc_conv_array_ubound (tree descriptor, int dim)
1558 type = TREE_TYPE (descriptor);
1560 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1561 if (tmp != NULL_TREE)
1564 /* This should only ever happen when passing an assumed shape array
1565 as an actual parameter. The value will never be used. */
1566 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1567 return gfc_index_zero_node;
1569 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1574 /* Translate an array reference. The descriptor should be in se->expr.
1575 Do not use this function, it wil be removed soon. */
1579 gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
1580 tree offset, int dimen)
1587 array = gfc_build_indirect_ref (pointer);
1590 for (n = 0; n < dimen; n++)
1592 /* index = index + stride[n]*indices[n] */
1593 tmp = gfc_conv_array_stride (se->expr, n);
1594 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
1596 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1599 /* Result = data[index]. */
1600 tmp = gfc_build_array_ref (array, index);
1602 /* Check we've used the correct number of dimensions. */
1603 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
1609 /* Generate code to perform an array index bound check. */
1612 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1618 if (!flag_bounds_check)
1621 index = gfc_evaluate_now (index, &se->pre);
1622 /* Check lower bound. */
1623 tmp = gfc_conv_array_lbound (descriptor, n);
1624 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1625 /* Check upper bound. */
1626 tmp = gfc_conv_array_ubound (descriptor, n);
1627 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1628 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1630 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1636 /* A reference to an array vector subscript. Uses recursion to handle nested
1637 vector subscripts. */
1640 gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
1643 tree indices[GFC_MAX_DIMENSIONS];
1648 gcc_assert (ss && ss->type == GFC_SS_VECTOR);
1650 /* Save the descriptor. */
1651 descsave = se->expr;
1652 info = &ss->data.info;
1653 se->expr = info->descriptor;
1655 ar = &info->ref->u.ar;
1656 for (n = 0; n < ar->dimen; n++)
1658 switch (ar->dimen_type[n])
1661 gcc_assert (info->subscript[n] != gfc_ss_terminator
1662 && info->subscript[n]->type == GFC_SS_SCALAR);
1663 indices[n] = info->subscript[n]->data.scalar.expr;
1671 index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
1674 gfc_trans_array_bound_check (se, info->descriptor, index, n);
1681 /* Get the index from the vector. */
1682 gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
1684 /* Put the descriptor back. */
1685 se->expr = descsave;
1691 /* Return the offset for an index. Performs bound checking for elemental
1692 dimensions. Single element references are processed separately. */
1695 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1696 gfc_array_ref * ar, tree stride)
1700 /* Get the index into the array for this dimension. */
1703 gcc_assert (ar->type != AR_ELEMENT);
1704 if (ar->dimen_type[dim] == DIMEN_ELEMENT)
1706 gcc_assert (i == -1);
1707 /* Elemental dimension. */
1708 gcc_assert (info->subscript[dim]
1709 && info->subscript[dim]->type == GFC_SS_SCALAR);
1710 /* We've already translated this value outside the loop. */
1711 index = info->subscript[dim]->data.scalar.expr;
1714 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1718 /* Scalarized dimension. */
1719 gcc_assert (info && se->loop);
1721 /* Multiply the loop variable by the stride and delta. */
1722 index = se->loop->loopvar[i];
1723 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1725 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1728 if (ar->dimen_type[dim] == DIMEN_VECTOR)
1730 /* Handle vector subscripts. */
1731 index = gfc_conv_vector_array_index (se, index,
1732 info->subscript[dim]);
1734 gfc_trans_array_bound_check (se, info->descriptor, index,
1738 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
1743 /* Temporary array or derived type component. */
1744 gcc_assert (se->loop);
1745 index = se->loop->loopvar[se->loop->order[i]];
1746 if (!integer_zerop (info->delta[i]))
1747 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1748 index, info->delta[i]);
1751 /* Multiply by the stride. */
1752 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1758 /* Build a scalarized reference to an array. */
1761 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1768 info = &se->ss->data.info;
1770 n = se->loop->order[0];
1774 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1776 /* Add the offset for this dimension to the stored offset for all other
1778 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1780 tmp = gfc_build_indirect_ref (info->data);
1781 se->expr = gfc_build_array_ref (tmp, index);
1785 /* Translate access of temporary array. */
1788 gfc_conv_tmp_array_ref (gfc_se * se)
1790 se->string_length = se->ss->string_length;
1791 gfc_conv_scalarized_array_ref (se, NULL);
1795 /* Build an array reference. se->expr already holds the array descriptor.
1796 This should be either a variable, indirect variable reference or component
1797 reference. For arrays which do not have a descriptor, se->expr will be
1799 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1802 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1811 /* Handle scalarized references separately. */
1812 if (ar->type != AR_ELEMENT)
1814 gfc_conv_scalarized_array_ref (se, ar);
1815 gfc_advance_se_ss_chain (se);
1819 index = gfc_index_zero_node;
1821 fault = gfc_index_zero_node;
1823 /* Calculate the offsets from all the dimensions. */
1824 for (n = 0; n < ar->dimen; n++)
1826 /* Calculate the index for this dimension. */
1827 gfc_init_se (&indexse, se);
1828 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1829 gfc_add_block_to_block (&se->pre, &indexse.pre);
1831 if (flag_bounds_check)
1833 /* Check array bounds. */
1836 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1838 tmp = gfc_conv_array_lbound (se->expr, n);
1839 cond = fold_build2 (LT_EXPR, boolean_type_node,
1842 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1844 tmp = gfc_conv_array_ubound (se->expr, n);
1845 cond = fold_build2 (GT_EXPR, boolean_type_node,
1848 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1851 /* Multiply the index by the stride. */
1852 stride = gfc_conv_array_stride (se->expr, n);
1853 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1856 /* And add it to the total. */
1857 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1860 if (flag_bounds_check)
1861 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1863 tmp = gfc_conv_array_offset (se->expr);
1864 if (!integer_zerop (tmp))
1865 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1867 /* Access the calculated element. */
1868 tmp = gfc_conv_array_data (se->expr);
1869 tmp = gfc_build_indirect_ref (tmp);
1870 se->expr = gfc_build_array_ref (tmp, index);
1874 /* Generate the code to be executed immediately before entering a
1875 scalarization loop. */
1878 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1879 stmtblock_t * pblock)
1888 /* This code will be executed before entering the scalarization loop
1889 for this dimension. */
1890 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1892 if ((ss->useflags & flag) == 0)
1895 if (ss->type != GFC_SS_SECTION
1896 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1897 && ss->type != GFC_SS_COMPONENT)
1900 info = &ss->data.info;
1902 if (dim >= info->dimen)
1905 if (dim == info->dimen - 1)
1907 /* For the outermost loop calculate the offset due to any
1908 elemental dimensions. It will have been initialized with the
1909 base offset of the array. */
1912 for (i = 0; i < info->ref->u.ar.dimen; i++)
1914 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1917 gfc_init_se (&se, NULL);
1919 se.expr = info->descriptor;
1920 stride = gfc_conv_array_stride (info->descriptor, i);
1921 index = gfc_conv_array_index_offset (&se, info, i, -1,
1924 gfc_add_block_to_block (pblock, &se.pre);
1926 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1927 info->offset, index);
1928 info->offset = gfc_evaluate_now (info->offset, pblock);
1932 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1935 stride = gfc_conv_array_stride (info->descriptor, 0);
1937 /* Calculate the stride of the innermost loop. Hopefully this will
1938 allow the backend optimizers to do their stuff more effectively.
1940 info->stride0 = gfc_evaluate_now (stride, pblock);
1944 /* Add the offset for the previous loop dimension. */
1949 ar = &info->ref->u.ar;
1950 i = loop->order[dim + 1];
1958 gfc_init_se (&se, NULL);
1960 se.expr = info->descriptor;
1961 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1962 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
1964 gfc_add_block_to_block (pblock, &se.pre);
1965 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1966 info->offset, index);
1967 info->offset = gfc_evaluate_now (info->offset, pblock);
1970 /* Remember this offset for the second loop. */
1971 if (dim == loop->temp_dim - 1)
1972 info->saved_offset = info->offset;
1977 /* Start a scalarized expression. Creates a scope and declares loop
1981 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
1987 gcc_assert (!loop->array_parameter);
1989 for (dim = loop->dimen - 1; dim >= 0; dim--)
1991 n = loop->order[dim];
1993 gfc_start_block (&loop->code[n]);
1995 /* Create the loop variable. */
1996 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
1998 if (dim < loop->temp_dim)
2002 /* Calculate values that will be constant within this loop. */
2003 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2005 gfc_start_block (pbody);
2009 /* Generates the actual loop code for a scalarization loop. */
2012 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2013 stmtblock_t * pbody)
2021 loopbody = gfc_finish_block (pbody);
2023 /* Initialize the loopvar. */
2024 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2026 exit_label = gfc_build_label_decl (NULL_TREE);
2028 /* Generate the loop body. */
2029 gfc_init_block (&block);
2031 /* The exit condition. */
2032 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2033 tmp = build1_v (GOTO_EXPR, exit_label);
2034 TREE_USED (exit_label) = 1;
2035 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2036 gfc_add_expr_to_block (&block, tmp);
2038 /* The main body. */
2039 gfc_add_expr_to_block (&block, loopbody);
2041 /* Increment the loopvar. */
2042 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2043 loop->loopvar[n], gfc_index_one_node);
2044 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2046 /* Build the loop. */
2047 tmp = gfc_finish_block (&block);
2048 tmp = build1_v (LOOP_EXPR, tmp);
2049 gfc_add_expr_to_block (&loop->code[n], tmp);
2051 /* Add the exit label. */
2052 tmp = build1_v (LABEL_EXPR, exit_label);
2053 gfc_add_expr_to_block (&loop->code[n], tmp);
2057 /* Finishes and generates the loops for a scalarized expression. */
2060 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2065 stmtblock_t *pblock;
2069 /* Generate the loops. */
2070 for (dim = 0; dim < loop->dimen; dim++)
2072 n = loop->order[dim];
2073 gfc_trans_scalarized_loop_end (loop, n, pblock);
2074 loop->loopvar[n] = NULL_TREE;
2075 pblock = &loop->code[n];
2078 tmp = gfc_finish_block (pblock);
2079 gfc_add_expr_to_block (&loop->pre, tmp);
2081 /* Clear all the used flags. */
2082 for (ss = loop->ss; ss; ss = ss->loop_chain)
2087 /* Finish the main body of a scalarized expression, and start the secondary
2091 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2095 stmtblock_t *pblock;
2099 /* We finish as many loops as are used by the temporary. */
2100 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2102 n = loop->order[dim];
2103 gfc_trans_scalarized_loop_end (loop, n, pblock);
2104 loop->loopvar[n] = NULL_TREE;
2105 pblock = &loop->code[n];
2108 /* We don't want to finish the outermost loop entirely. */
2109 n = loop->order[loop->temp_dim - 1];
2110 gfc_trans_scalarized_loop_end (loop, n, pblock);
2112 /* Restore the initial offsets. */
2113 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2115 if ((ss->useflags & 2) == 0)
2118 if (ss->type != GFC_SS_SECTION
2119 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2120 && ss->type != GFC_SS_COMPONENT)
2123 ss->data.info.offset = ss->data.info.saved_offset;
2126 /* Restart all the inner loops we just finished. */
2127 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2129 n = loop->order[dim];
2131 gfc_start_block (&loop->code[n]);
2133 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2135 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2138 /* Start a block for the secondary copying code. */
2139 gfc_start_block (body);
2143 /* Calculate the upper bound of an array section. */
2146 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2155 gcc_assert (ss->type == GFC_SS_SECTION);
2157 /* For vector array subscripts we want the size of the vector. */
2158 dim = ss->data.info.dim[n];
2160 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2162 vecss = vecss->data.info.subscript[dim];
2163 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2164 dim = vecss->data.info.dim[0];
2167 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2168 end = vecss->data.info.ref->u.ar.end[dim];
2169 desc = vecss->data.info.descriptor;
2173 /* The upper bound was specified. */
2174 gfc_init_se (&se, NULL);
2175 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2176 gfc_add_block_to_block (pblock, &se.pre);
2181 /* No upper bound was specified, so use the bound of the array. */
2182 bound = gfc_conv_array_ubound (desc, dim);
2189 /* Calculate the lower bound of an array section. */
2192 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2202 info = &ss->data.info;
2206 /* For vector array subscripts we want the size of the vector. */
2208 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2210 vecss = vecss->data.info.subscript[dim];
2211 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2212 /* Get the descriptors for the vector subscripts as well. */
2213 if (!vecss->data.info.descriptor)
2214 gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
2215 dim = vecss->data.info.dim[0];
2218 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2219 start = vecss->data.info.ref->u.ar.start[dim];
2220 stride = vecss->data.info.ref->u.ar.stride[dim];
2221 desc = vecss->data.info.descriptor;
2223 /* Calculate the start of the range. For vector subscripts this will
2224 be the range of the vector. */
2227 /* Specified section start. */
2228 gfc_init_se (&se, NULL);
2229 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2230 gfc_add_block_to_block (&loop->pre, &se.pre);
2231 info->start[n] = se.expr;
2235 /* No lower bound specified so use the bound of the array. */
2236 info->start[n] = gfc_conv_array_lbound (desc, dim);
2238 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2240 /* Calculate the stride. */
2242 info->stride[n] = gfc_index_one_node;
2245 gfc_init_se (&se, NULL);
2246 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2247 gfc_add_block_to_block (&loop->pre, &se.pre);
2248 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2253 /* Calculates the range start and stride for a SS chain. Also gets the
2254 descriptor and data pointer. The range of vector subscripts is the size
2255 of the vector. Array bounds are also checked. */
2258 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2267 /* Determine the rank of the loop. */
2269 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2273 case GFC_SS_SECTION:
2274 case GFC_SS_CONSTRUCTOR:
2275 case GFC_SS_FUNCTION:
2276 case GFC_SS_COMPONENT:
2277 loop->dimen = ss->data.info.dimen;
2285 if (loop->dimen == 0)
2286 gfc_todo_error ("Unable to determine rank of expression");
2289 /* Loop over all the SS in the chain. */
2290 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2292 if (ss->expr && ss->expr->shape && !ss->shape)
2293 ss->shape = ss->expr->shape;
2297 case GFC_SS_SECTION:
2298 /* Get the descriptor for the array. */
2299 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2301 for (n = 0; n < ss->data.info.dimen; n++)
2302 gfc_conv_section_startstride (loop, ss, n);
2305 case GFC_SS_CONSTRUCTOR:
2306 case GFC_SS_FUNCTION:
2307 for (n = 0; n < ss->data.info.dimen; n++)
2309 ss->data.info.start[n] = gfc_index_zero_node;
2310 ss->data.info.stride[n] = gfc_index_one_node;
2319 /* The rest is just runtime bound checking. */
2320 if (flag_bounds_check)
2326 tree size[GFC_MAX_DIMENSIONS];
2330 gfc_start_block (&block);
2332 fault = integer_zero_node;
2333 for (n = 0; n < loop->dimen; n++)
2334 size[n] = NULL_TREE;
2336 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2338 if (ss->type != GFC_SS_SECTION)
2341 /* TODO: range checking for mapped dimensions. */
2342 info = &ss->data.info;
2344 /* This only checks scalarized dimensions, elemental dimensions are
2346 for (n = 0; n < loop->dimen; n++)
2350 while (vecss->data.info.ref->u.ar.dimen_type[dim]
2353 vecss = vecss->data.info.subscript[dim];
2354 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2355 dim = vecss->data.info.dim[0];
2357 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
2359 desc = vecss->data.info.descriptor;
2361 /* Check lower bound. */
2362 bound = gfc_conv_array_lbound (desc, dim);
2363 tmp = info->start[n];
2364 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2365 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2368 /* Check the upper bound. */
2369 bound = gfc_conv_array_ubound (desc, dim);
2370 end = gfc_conv_section_upper_bound (ss, n, &block);
2371 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2372 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2375 /* Check the section sizes match. */
2376 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2378 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2380 /* We remember the size of the first section, and check all the
2381 others against this. */
2385 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2387 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2390 size[n] = gfc_evaluate_now (tmp, &block);
2393 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2395 tmp = gfc_finish_block (&block);
2396 gfc_add_expr_to_block (&loop->pre, tmp);
2401 /* Return true if the two SS could be aliased, i.e. both point to the same data
2403 /* TODO: resolve aliases based on frontend expressions. */
2406 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2413 lsym = lss->expr->symtree->n.sym;
2414 rsym = rss->expr->symtree->n.sym;
2415 if (gfc_symbols_could_alias (lsym, rsym))
2418 if (rsym->ts.type != BT_DERIVED
2419 && lsym->ts.type != BT_DERIVED)
2422 /* For derived types we must check all the component types. We can ignore
2423 array references as these will have the same base type as the previous
2425 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2427 if (lref->type != REF_COMPONENT)
2430 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2433 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2436 if (rref->type != REF_COMPONENT)
2439 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2444 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2446 if (rref->type != REF_COMPONENT)
2449 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2457 /* Resolve array data dependencies. Creates a temporary if required. */
2458 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2462 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2472 loop->temp_ss = NULL;
2473 aref = dest->data.info.ref;
2476 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2478 if (ss->type != GFC_SS_SECTION)
2481 if (gfc_could_be_alias (dest, ss))
2487 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2489 lref = dest->expr->ref;
2490 rref = ss->expr->ref;
2492 nDepend = gfc_dep_resolver (lref, rref);
2494 /* TODO : loop shifting. */
2497 /* Mark the dimensions for LOOP SHIFTING */
2498 for (n = 0; n < loop->dimen; n++)
2500 int dim = dest->data.info.dim[n];
2502 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2504 else if (! gfc_is_same_range (&lref->u.ar,
2505 &rref->u.ar, dim, 0))
2509 /* Put all the dimensions with dependencies in the
2512 for (n = 0; n < loop->dimen; n++)
2514 gcc_assert (loop->order[n] == n);
2516 loop->order[dim++] = n;
2519 for (n = 0; n < loop->dimen; n++)
2522 loop->order[dim++] = n;
2525 gcc_assert (dim == loop->dimen);
2534 loop->temp_ss = gfc_get_ss ();
2535 loop->temp_ss->type = GFC_SS_TEMP;
2536 loop->temp_ss->data.temp.type =
2537 gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
2538 loop->temp_ss->string_length = dest->string_length;
2539 loop->temp_ss->data.temp.dimen = loop->dimen;
2540 loop->temp_ss->next = gfc_ss_terminator;
2541 gfc_add_ss_to_loop (loop, loop->temp_ss);
2544 loop->temp_ss = NULL;
2548 /* Initialize the scalarization loop. Creates the loop variables. Determines
2549 the range of the loop variables. Creates a temporary if required.
2550 Calculates how to transform from loop variables to array indices for each
2551 expression. Also generates code for scalar expressions which have been
2552 moved outside the loop. */
2555 gfc_conv_loop_setup (gfc_loopinfo * loop)
2560 gfc_ss_info *specinfo;
2564 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2565 bool dynamic[GFC_MAX_DIMENSIONS];
2571 for (n = 0; n < loop->dimen; n++)
2575 /* We use one SS term, and use that to determine the bounds of the
2576 loop for this dimension. We try to pick the simplest term. */
2577 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2581 /* The frontend has worked out the size for us. */
2586 if (ss->type == GFC_SS_CONSTRUCTOR)
2588 /* An unknown size constructor will always be rank one.
2589 Higher rank constructors will either have known shape,
2590 or still be wrapped in a call to reshape. */
2591 gcc_assert (loop->dimen == 1);
2593 /* Always prefer to use the constructor bounds if the size
2594 can be determined at compile time. Prefer not to otherwise,
2595 since the general case involves realloc, and it's better to
2596 avoid that overhead if possible. */
2597 c = ss->expr->value.constructor;
2598 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2599 if (!dynamic[n] || !loopspec[n])
2604 /* TODO: Pick the best bound if we have a choice between a
2605 function and something else. */
2606 if (ss->type == GFC_SS_FUNCTION)
2612 if (ss->type != GFC_SS_SECTION)
2616 specinfo = &loopspec[n]->data.info;
2619 info = &ss->data.info;
2623 /* Criteria for choosing a loop specifier (most important first):
2624 doesn't need realloc
2630 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2632 else if (integer_onep (info->stride[n])
2633 && !integer_onep (specinfo->stride[n]))
2635 else if (INTEGER_CST_P (info->stride[n])
2636 && !INTEGER_CST_P (specinfo->stride[n]))
2638 else if (INTEGER_CST_P (info->start[n])
2639 && !INTEGER_CST_P (specinfo->start[n]))
2641 /* We don't work out the upper bound.
2642 else if (INTEGER_CST_P (info->finish[n])
2643 && ! INTEGER_CST_P (specinfo->finish[n]))
2644 loopspec[n] = ss; */
2648 gfc_todo_error ("Unable to find scalarization loop specifier");
2650 info = &loopspec[n]->data.info;
2652 /* Set the extents of this range. */
2653 cshape = loopspec[n]->shape;
2654 if (cshape && INTEGER_CST_P (info->start[n])
2655 && INTEGER_CST_P (info->stride[n]))
2657 loop->from[n] = info->start[n];
2658 mpz_set (i, cshape[n]);
2659 mpz_sub_ui (i, i, 1);
2660 /* To = from + (size - 1) * stride. */
2661 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2662 if (!integer_onep (info->stride[n]))
2663 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2664 tmp, info->stride[n]);
2665 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2666 loop->from[n], tmp);
2670 loop->from[n] = info->start[n];
2671 switch (loopspec[n]->type)
2673 case GFC_SS_CONSTRUCTOR:
2674 /* The upper bound is calculated when we expand the
2676 gcc_assert (loop->to[n] == NULL_TREE);
2679 case GFC_SS_SECTION:
2680 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2684 case GFC_SS_FUNCTION:
2685 /* The loop bound will be set when we generate the call. */
2686 gcc_assert (loop->to[n] == NULL_TREE);
2694 /* Transform everything so we have a simple incrementing variable. */
2695 if (integer_onep (info->stride[n]))
2696 info->delta[n] = gfc_index_zero_node;
2699 /* Set the delta for this section. */
2700 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2701 /* Number of iterations is (end - start + step) / step.
2702 with start = 0, this simplifies to
2704 for (i = 0; i<=last; i++){...}; */
2705 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2706 loop->to[n], loop->from[n]);
2707 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2708 tmp, info->stride[n]);
2709 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2710 /* Make the loop variable start at 0. */
2711 loop->from[n] = gfc_index_zero_node;
2715 /* Add all the scalar code that can be taken out of the loops.
2716 This may include calculating the loop bounds, so do it before
2717 allocating the temporary. */
2718 gfc_add_loop_ss_code (loop, loop->ss, false);
2720 /* If we want a temporary then create it. */
2721 if (loop->temp_ss != NULL)
2723 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2724 tmp = loop->temp_ss->data.temp.type;
2725 len = loop->temp_ss->string_length;
2726 n = loop->temp_ss->data.temp.dimen;
2727 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2728 loop->temp_ss->type = GFC_SS_SECTION;
2729 loop->temp_ss->data.info.dimen = n;
2730 gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
2734 for (n = 0; n < loop->temp_dim; n++)
2735 loopspec[loop->order[n]] = NULL;
2739 /* For array parameters we don't have loop variables, so don't calculate the
2741 if (loop->array_parameter)
2744 /* Calculate the translation from loop variables to array indices. */
2745 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2747 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2750 info = &ss->data.info;
2752 for (n = 0; n < info->dimen; n++)
2756 /* If we are specifying the range the delta is already set. */
2757 if (loopspec[n] != ss)
2759 /* Calculate the offset relative to the loop variable.
2760 First multiply by the stride. */
2761 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2762 loop->from[n], info->stride[n]);
2764 /* Then subtract this from our starting value. */
2765 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2766 info->start[n], tmp);
2768 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2775 /* Fills in an array descriptor, and returns the size of the array. The size
2776 will be a simple_val, ie a variable or a constant. Also calculates the
2777 offset of the base. Returns the size of the array.
2781 for (n = 0; n < rank; n++)
2783 a.lbound[n] = specified_lower_bound;
2784 offset = offset + a.lbond[n] * stride;
2786 a.ubound[n] = specified_upper_bound;
2787 a.stride[n] = stride;
2788 size = ubound + size; //size = ubound + 1 - lbound
2789 stride = stride * size;
2796 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2797 gfc_expr ** lower, gfc_expr ** upper,
2798 stmtblock_t * pblock)
2809 type = TREE_TYPE (descriptor);
2811 stride = gfc_index_one_node;
2812 offset = gfc_index_zero_node;
2814 /* Set the dtype. */
2815 tmp = gfc_conv_descriptor_dtype (descriptor);
2816 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2818 for (n = 0; n < rank; n++)
2820 /* We have 3 possibilities for determining the size of the array:
2821 lower == NULL => lbound = 1, ubound = upper[n]
2822 upper[n] = NULL => lbound = 1, ubound = lower[n]
2823 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2826 /* Set lower bound. */
2827 gfc_init_se (&se, NULL);
2829 se.expr = gfc_index_one_node;
2832 gcc_assert (lower[n]);
2835 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2836 gfc_add_block_to_block (pblock, &se.pre);
2840 se.expr = gfc_index_one_node;
2844 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2845 gfc_add_modify_expr (pblock, tmp, se.expr);
2847 /* Work out the offset for this component. */
2848 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2849 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2851 /* Start the calculation for the size of this dimension. */
2852 size = build2 (MINUS_EXPR, gfc_array_index_type,
2853 gfc_index_one_node, se.expr);
2855 /* Set upper bound. */
2856 gfc_init_se (&se, NULL);
2857 gcc_assert (ubound);
2858 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2859 gfc_add_block_to_block (pblock, &se.pre);
2861 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2862 gfc_add_modify_expr (pblock, tmp, se.expr);
2864 /* Store the stride. */
2865 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2866 gfc_add_modify_expr (pblock, tmp, stride);
2868 /* Calculate the size of this dimension. */
2869 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2871 /* Multiply the stride by the number of elements in this dimension. */
2872 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2873 stride = gfc_evaluate_now (stride, pblock);
2876 /* The stride is the number of elements in the array, so multiply by the
2877 size of an element to get the total size. */
2878 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2879 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2881 if (poffset != NULL)
2883 offset = gfc_evaluate_now (offset, pblock);
2887 size = gfc_evaluate_now (size, pblock);
2892 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2893 the work for an ALLOCATE statement. */
2897 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2907 /* Figure out the size of the array. */
2908 switch (ref->u.ar.type)
2912 upper = ref->u.ar.start;
2916 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2918 lower = ref->u.ar.as->lower;
2919 upper = ref->u.ar.as->upper;
2923 lower = ref->u.ar.start;
2924 upper = ref->u.ar.end;
2932 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2933 lower, upper, &se->pre);
2935 /* Allocate memory to store the data. */
2936 tmp = gfc_conv_descriptor_data_addr (se->expr);
2937 pointer = gfc_evaluate_now (tmp, &se->pre);
2939 if (TYPE_PRECISION (gfc_array_index_type) == 32)
2940 allocate = gfor_fndecl_allocate;
2941 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2942 allocate = gfor_fndecl_allocate64;
2946 tmp = gfc_chainon_list (NULL_TREE, pointer);
2947 tmp = gfc_chainon_list (tmp, size);
2948 tmp = gfc_chainon_list (tmp, pstat);
2949 tmp = gfc_build_function_call (allocate, tmp);
2950 gfc_add_expr_to_block (&se->pre, tmp);
2952 tmp = gfc_conv_descriptor_offset (se->expr);
2953 gfc_add_modify_expr (&se->pre, tmp, offset);
2957 /* Deallocate an array variable. Also used when an allocated variable goes
2962 gfc_array_deallocate (tree descriptor, tree pstat)
2968 gfc_start_block (&block);
2969 /* Get a pointer to the data. */
2970 tmp = gfc_conv_descriptor_data_addr (descriptor);
2971 var = gfc_evaluate_now (tmp, &block);
2973 /* Parameter is the address of the data component. */
2974 tmp = gfc_chainon_list (NULL_TREE, var);
2975 tmp = gfc_chainon_list (tmp, pstat);
2976 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2977 gfc_add_expr_to_block (&block, tmp);
2979 return gfc_finish_block (&block);
2983 /* Create an array constructor from an initialization expression.
2984 We assume the frontend already did any expansions and conversions. */
2987 gfc_conv_array_initializer (tree type, gfc_expr * expr)
2994 unsigned HOST_WIDE_INT lo;
2996 VEC(constructor_elt,gc) *v = NULL;
2998 switch (expr->expr_type)
3001 case EXPR_STRUCTURE:
3002 /* A single scalar or derived type value. Create an array with all
3003 elements equal to that value. */
3004 gfc_init_se (&se, NULL);
3006 if (expr->expr_type == EXPR_CONSTANT)
3007 gfc_conv_constant (&se, expr);
3009 gfc_conv_structure (&se, expr, 1);
3011 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3012 gcc_assert (tmp && INTEGER_CST_P (tmp));
3013 hi = TREE_INT_CST_HIGH (tmp);
3014 lo = TREE_INT_CST_LOW (tmp);
3018 /* This will probably eat buckets of memory for large arrays. */
3019 while (hi != 0 || lo != 0)
3021 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3029 /* Create a vector of all the elements. */
3030 for (c = expr->value.constructor; c; c = c->next)
3034 /* Problems occur when we get something like
3035 integer :: a(lots) = (/(i, i=1,lots)/) */
3036 /* TODO: Unexpanded array initializers. */
3038 ("Possible frontend bug: array constructor not expanded");
3040 if (mpz_cmp_si (c->n.offset, 0) != 0)
3041 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3045 if (mpz_cmp_si (c->repeat, 0) != 0)
3049 mpz_set (maxval, c->repeat);
3050 mpz_add (maxval, c->n.offset, maxval);
3051 mpz_sub_ui (maxval, maxval, 1);
3052 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3053 if (mpz_cmp_si (c->n.offset, 0) != 0)
3055 mpz_add_ui (maxval, c->n.offset, 1);
3056 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3059 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3061 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3067 gfc_init_se (&se, NULL);
3068 switch (c->expr->expr_type)
3071 gfc_conv_constant (&se, c->expr);
3072 if (range == NULL_TREE)
3073 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3076 if (index != NULL_TREE)
3077 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3078 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3082 case EXPR_STRUCTURE:
3083 gfc_conv_structure (&se, c->expr, 1);
3084 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3097 /* Create a constructor from the list of elements. */
3098 tmp = build_constructor (type, v);
3099 TREE_CONSTANT (tmp) = 1;
3100 TREE_INVARIANT (tmp) = 1;
3105 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3106 returns the size (in elements) of the array. */
3109 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3110 stmtblock_t * pblock)
3125 size = gfc_index_one_node;
3126 offset = gfc_index_zero_node;
3127 for (dim = 0; dim < as->rank; dim++)
3129 /* Evaluate non-constant array bound expressions. */
3130 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3131 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3133 gfc_init_se (&se, NULL);
3134 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3135 gfc_add_block_to_block (pblock, &se.pre);
3136 gfc_add_modify_expr (pblock, lbound, se.expr);
3138 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3139 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3141 gfc_init_se (&se, NULL);
3142 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3143 gfc_add_block_to_block (pblock, &se.pre);
3144 gfc_add_modify_expr (pblock, ubound, se.expr);
3146 /* The offset of this dimension. offset = offset - lbound * stride. */
3147 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3148 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3150 /* The size of this dimension, and the stride of the next. */
3151 if (dim + 1 < as->rank)
3152 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3156 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3158 /* Calculate stride = size * (ubound + 1 - lbound). */
3159 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3160 gfc_index_one_node, lbound);
3161 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3162 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3164 gfc_add_modify_expr (pblock, stride, tmp);
3166 stride = gfc_evaluate_now (tmp, pblock);
3177 /* Generate code to initialize/allocate an array variable. */
3180 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3190 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3192 /* Do nothing for USEd variables. */
3193 if (sym->attr.use_assoc)
3196 type = TREE_TYPE (decl);
3197 gcc_assert (GFC_ARRAY_TYPE_P (type));
3198 onstack = TREE_CODE (type) != POINTER_TYPE;
3200 gfc_start_block (&block);
3202 /* Evaluate character string length. */
3203 if (sym->ts.type == BT_CHARACTER
3204 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3206 gfc_trans_init_string_length (sym->ts.cl, &block);
3208 /* Emit a DECL_EXPR for this variable, which will cause the
3209 gimplifier to allocate storage, and all that good stuff. */
3210 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3211 gfc_add_expr_to_block (&block, tmp);
3216 gfc_add_expr_to_block (&block, fnbody);
3217 return gfc_finish_block (&block);
3220 type = TREE_TYPE (type);
3222 gcc_assert (!sym->attr.use_assoc);
3223 gcc_assert (!TREE_STATIC (decl));
3224 gcc_assert (!sym->module);
3226 if (sym->ts.type == BT_CHARACTER
3227 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3228 gfc_trans_init_string_length (sym->ts.cl, &block);
3230 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3232 /* The size is the number of elements in the array, so multiply by the
3233 size of an element to get the total size. */
3234 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3235 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3237 /* Allocate memory to hold the data. */
3238 tmp = gfc_chainon_list (NULL_TREE, size);
3240 if (gfc_index_integer_kind == 4)
3241 fndecl = gfor_fndecl_internal_malloc;
3242 else if (gfc_index_integer_kind == 8)
3243 fndecl = gfor_fndecl_internal_malloc64;
3246 tmp = gfc_build_function_call (fndecl, tmp);
3247 tmp = fold (convert (TREE_TYPE (decl), tmp));
3248 gfc_add_modify_expr (&block, decl, tmp);
3250 /* Set offset of the array. */
3251 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3252 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3255 /* Automatic arrays should not have initializers. */
3256 gcc_assert (!sym->value);
3258 gfc_add_expr_to_block (&block, fnbody);
3260 /* Free the temporary. */
3261 tmp = convert (pvoid_type_node, decl);
3262 tmp = gfc_chainon_list (NULL_TREE, tmp);
3263 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3264 gfc_add_expr_to_block (&block, tmp);
3266 return gfc_finish_block (&block);
3270 /* Generate entry and exit code for g77 calling convention arrays. */
3273 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3282 gfc_get_backend_locus (&loc);
3283 gfc_set_backend_locus (&sym->declared_at);
3285 /* Descriptor type. */
3286 parm = sym->backend_decl;
3287 type = TREE_TYPE (parm);
3288 gcc_assert (GFC_ARRAY_TYPE_P (type));
3290 gfc_start_block (&block);
3292 if (sym->ts.type == BT_CHARACTER
3293 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3294 gfc_trans_init_string_length (sym->ts.cl, &block);
3296 /* Evaluate the bounds of the array. */
3297 gfc_trans_array_bounds (type, sym, &offset, &block);
3299 /* Set the offset. */
3300 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3301 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3303 /* Set the pointer itself if we aren't using the parameter directly. */
3304 if (TREE_CODE (parm) != PARM_DECL)
3306 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3307 gfc_add_modify_expr (&block, parm, tmp);
3309 tmp = gfc_finish_block (&block);
3311 gfc_set_backend_locus (&loc);
3313 gfc_start_block (&block);
3314 /* Add the initialization code to the start of the function. */
3315 gfc_add_expr_to_block (&block, tmp);
3316 gfc_add_expr_to_block (&block, body);
3318 return gfc_finish_block (&block);
3322 /* Modify the descriptor of an array parameter so that it has the
3323 correct lower bound. Also move the upper bound accordingly.
3324 If the array is not packed, it will be copied into a temporary.
3325 For each dimension we set the new lower and upper bounds. Then we copy the
3326 stride and calculate the offset for this dimension. We also work out
3327 what the stride of a packed array would be, and see it the two match.
3328 If the array need repacking, we set the stride to the values we just
3329 calculated, recalculate the offset and copy the array data.
3330 Code is also added to copy the data back at the end of the function.
3334 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3341 stmtblock_t cleanup;
3359 /* Do nothing for pointer and allocatable arrays. */
3360 if (sym->attr.pointer || sym->attr.allocatable)
3363 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3364 return gfc_trans_g77_array (sym, body);
3366 gfc_get_backend_locus (&loc);
3367 gfc_set_backend_locus (&sym->declared_at);
3369 /* Descriptor type. */
3370 type = TREE_TYPE (tmpdesc);
3371 gcc_assert (GFC_ARRAY_TYPE_P (type));
3372 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3373 dumdesc = gfc_build_indirect_ref (dumdesc);
3374 gfc_start_block (&block);
3376 if (sym->ts.type == BT_CHARACTER
3377 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3378 gfc_trans_init_string_length (sym->ts.cl, &block);
3380 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3382 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3383 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3385 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3387 /* For non-constant shape arrays we only check if the first dimension
3388 is contiguous. Repacking higher dimensions wouldn't gain us
3389 anything as we still don't know the array stride. */
3390 partial = gfc_create_var (boolean_type_node, "partial");
3391 TREE_USED (partial) = 1;
3392 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3393 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3394 gfc_add_modify_expr (&block, partial, tmp);
3398 partial = NULL_TREE;
3401 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3402 here, however I think it does the right thing. */
3405 /* Set the first stride. */
3406 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3407 stride = gfc_evaluate_now (stride, &block);
3409 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3410 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3411 gfc_index_one_node, stride);
3412 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3413 gfc_add_modify_expr (&block, stride, tmp);
3415 /* Allow the user to disable array repacking. */
3416 stmt_unpacked = NULL_TREE;
3420 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3421 /* A library call to repack the array if necessary. */
3422 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3423 tmp = gfc_chainon_list (NULL_TREE, tmp);
3424 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3426 stride = gfc_index_one_node;
3429 /* This is for the case where the array data is used directly without
3430 calling the repack function. */
3431 if (no_repack || partial != NULL_TREE)
3432 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3434 stmt_packed = NULL_TREE;
3436 /* Assign the data pointer. */
3437 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3439 /* Don't repack unknown shape arrays when the first stride is 1. */
3440 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3441 stmt_packed, stmt_unpacked);
3444 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3445 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3447 offset = gfc_index_zero_node;
3448 size = gfc_index_one_node;
3450 /* Evaluate the bounds of the array. */
3451 for (n = 0; n < sym->as->rank; n++)
3453 if (checkparm || !sym->as->upper[n])
3455 /* Get the bounds of the actual parameter. */
3456 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3457 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3461 dubound = NULL_TREE;
3462 dlbound = NULL_TREE;
3465 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3466 if (!INTEGER_CST_P (lbound))
3468 gfc_init_se (&se, NULL);
3469 gfc_conv_expr_type (&se, sym->as->upper[n],
3470 gfc_array_index_type);
3471 gfc_add_block_to_block (&block, &se.pre);
3472 gfc_add_modify_expr (&block, lbound, se.expr);
3475 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3476 /* Set the desired upper bound. */
3477 if (sym->as->upper[n])
3479 /* We know what we want the upper bound to be. */
3480 if (!INTEGER_CST_P (ubound))
3482 gfc_init_se (&se, NULL);
3483 gfc_conv_expr_type (&se, sym->as->upper[n],
3484 gfc_array_index_type);
3485 gfc_add_block_to_block (&block, &se.pre);
3486 gfc_add_modify_expr (&block, ubound, se.expr);
3489 /* Check the sizes match. */
3492 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3494 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3496 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3498 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3499 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3504 /* For assumed shape arrays move the upper bound by the same amount
3505 as the lower bound. */
3506 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3507 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3508 gfc_add_modify_expr (&block, ubound, tmp);
3510 /* The offset of this dimension. offset = offset - lbound * stride. */
3511 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3512 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3514 /* The size of this dimension, and the stride of the next. */
3515 if (n + 1 < sym->as->rank)
3517 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3519 if (no_repack || partial != NULL_TREE)
3522 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3525 /* Figure out the stride if not a known constant. */
3526 if (!INTEGER_CST_P (stride))
3529 stmt_packed = NULL_TREE;
3532 /* Calculate stride = size * (ubound + 1 - lbound). */
3533 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3534 gfc_index_one_node, lbound);
3535 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3537 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3542 /* Assign the stride. */
3543 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3544 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3545 stmt_unpacked, stmt_packed);
3547 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3548 gfc_add_modify_expr (&block, stride, tmp);
3553 /* Set the offset. */
3554 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3555 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3557 stmt = gfc_finish_block (&block);
3559 gfc_start_block (&block);
3561 /* Only do the entry/initialization code if the arg is present. */
3562 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3563 optional_arg = (sym->attr.optional
3564 || (sym->ns->proc_name->attr.entry_master
3565 && sym->attr.dummy));
3568 tmp = gfc_conv_expr_present (sym);
3569 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3571 gfc_add_expr_to_block (&block, stmt);
3573 /* Add the main function body. */
3574 gfc_add_expr_to_block (&block, body);
3579 gfc_start_block (&cleanup);
3581 if (sym->attr.intent != INTENT_IN)
3583 /* Copy the data back. */
3584 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3585 tmp = gfc_chainon_list (tmp, tmpdesc);
3586 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3587 gfc_add_expr_to_block (&cleanup, tmp);
3590 /* Free the temporary. */
3591 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3592 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3593 gfc_add_expr_to_block (&cleanup, tmp);
3595 stmt = gfc_finish_block (&cleanup);
3597 /* Only do the cleanup if the array was repacked. */
3598 tmp = gfc_build_indirect_ref (dumdesc);
3599 tmp = gfc_conv_descriptor_data_get (tmp);
3600 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3601 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3605 tmp = gfc_conv_expr_present (sym);
3606 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3608 gfc_add_expr_to_block (&block, stmt);
3610 /* We don't need to free any memory allocated by internal_pack as it will
3611 be freed at the end of the function by pop_context. */
3612 return gfc_finish_block (&block);
3616 /* Convert an array for passing as an actual parameter. Expressions and
3617 vector subscripts are evaluated and stored in a temporary, which is then
3618 passed. For whole arrays the descriptor is passed. For array sections
3619 a modified copy of the descriptor is passed, but using the original data.
3620 Also used for array pointer assignments by setting se->direct_byref. */
3623 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3639 gcc_assert (ss != gfc_ss_terminator);
3641 /* TODO: Pass constant array constructors without a temporary. */
3642 /* Special case things we know we can pass easily. */
3643 switch (expr->expr_type)
3646 /* If we have a linear array section, we can pass it directly.
3647 Otherwise we need to copy it into a temporary. */
3649 /* Find the SS for the array section. */
3651 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3652 secss = secss->next;
3654 gcc_assert (secss != gfc_ss_terminator);
3657 for (n = 0; n < secss->data.info.dimen; n++)
3659 vss = secss->data.info.subscript[secss->data.info.dim[n]];
3660 if (vss && vss->type == GFC_SS_VECTOR)
3664 info = &secss->data.info;
3666 /* Get the descriptor for the array. */
3667 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3668 desc = info->descriptor;
3669 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3671 /* Create a new descriptor if the array doesn't have one. */
3674 else if (info->ref->u.ar.type == AR_FULL)
3676 else if (se->direct_byref)
3681 gcc_assert (ref->u.ar.type == AR_SECTION);
3684 for (n = 0; n < ref->u.ar.dimen; n++)
3686 /* Detect passing the full array as a section. This could do
3687 even more checking, but it doesn't seem worth it. */
3688 if (ref->u.ar.start[n]
3690 || (ref->u.ar.stride[n]
3691 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3699 /* Check for substring references. */
3701 if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
3705 if (ref->type == REF_SUBSTRING)
3707 /* In general character substrings need a copy. Character
3708 array strides are expressed as multiples of the element
3709 size (consistent with other array types), not in
3718 if (se->direct_byref)
3720 /* Copy the descriptor for pointer assignments. */
3721 gfc_add_modify_expr (&se->pre, se->expr, desc);
3723 else if (se->want_pointer)
3725 /* We pass full arrays directly. This means that pointers and
3726 allocatable arrays should also work. */
3727 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3734 if (expr->ts.type == BT_CHARACTER)
3735 se->string_length = gfc_get_expr_charlen (expr);
3742 /* A transformational function return value will be a temporary
3743 array descriptor. We still need to go through the scalarizer
3744 to create the descriptor. Elemental functions ar handled as
3745 arbitrary expressions, i.e. copy to a temporary. */
3747 /* Look for the SS for this function. */
3748 while (secss != gfc_ss_terminator
3749 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3750 secss = secss->next;
3752 if (se->direct_byref)
3754 gcc_assert (secss != gfc_ss_terminator);
3756 /* For pointer assignments pass the descriptor directly. */
3758 se->expr = gfc_build_addr_expr (NULL, se->expr);
3759 gfc_conv_expr (se, expr);
3763 if (secss == gfc_ss_terminator)
3765 /* Elemental function. */
3771 /* Transformational function. */
3772 info = &secss->data.info;
3778 /* Something complicated. Copy it into a temporary. */
3786 gfc_init_loopinfo (&loop);
3788 /* Associate the SS with the loop. */
3789 gfc_add_ss_to_loop (&loop, ss);
3791 /* Tell the scalarizer not to bother creating loop variables, etc. */
3793 loop.array_parameter = 1;
3795 gcc_assert (se->want_pointer && !se->direct_byref);
3797 /* Setup the scalarizing loops and bounds. */
3798 gfc_conv_ss_startstride (&loop);
3802 /* Tell the scalarizer to make a temporary. */
3803 loop.temp_ss = gfc_get_ss ();
3804 loop.temp_ss->type = GFC_SS_TEMP;
3805 loop.temp_ss->next = gfc_ss_terminator;
3806 if (expr->ts.type == BT_CHARACTER)
3808 gcc_assert (expr->ts.cl && expr->ts.cl->length
3809 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3810 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3811 (expr->ts.cl->length->value.integer,
3812 expr->ts.cl->length->ts.kind);
3813 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3815 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3817 /* ... which can hold our string, if present. */
3818 if (expr->ts.type == BT_CHARACTER)
3820 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3821 se->string_length = loop.temp_ss->string_length;
3824 loop.temp_ss->string_length = NULL;
3825 loop.temp_ss->data.temp.dimen = loop.dimen;
3826 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3829 gfc_conv_loop_setup (&loop);
3833 /* Copy into a temporary and pass that. We don't need to copy the data
3834 back because expressions and vector subscripts must be INTENT_IN. */
3835 /* TODO: Optimize passing function return values. */
3839 /* Start the copying loops. */
3840 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3841 gfc_mark_ss_chain_used (ss, 1);
3842 gfc_start_scalarized_body (&loop, &block);
3844 /* Copy each data element. */
3845 gfc_init_se (&lse, NULL);
3846 gfc_copy_loopinfo_to_se (&lse, &loop);
3847 gfc_init_se (&rse, NULL);
3848 gfc_copy_loopinfo_to_se (&rse, &loop);
3850 lse.ss = loop.temp_ss;
3853 gfc_conv_scalarized_array_ref (&lse, NULL);
3854 if (expr->ts.type == BT_CHARACTER)
3856 gfc_conv_expr (&rse, expr);
3857 rse.expr = gfc_build_indirect_ref (rse.expr);
3860 gfc_conv_expr_val (&rse, expr);
3862 gfc_add_block_to_block (&block, &rse.pre);
3863 gfc_add_block_to_block (&block, &lse.pre);
3865 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3867 /* Finish the copying loops. */
3868 gfc_trans_scalarizing_loops (&loop, &block);
3870 /* Set the first stride component to zero to indicate a temporary. */
3871 desc = loop.temp_ss->data.info.descriptor;
3872 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3873 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3875 gcc_assert (is_gimple_lvalue (desc));
3876 se->expr = gfc_build_addr_expr (NULL, desc);
3878 else if (expr->expr_type == EXPR_FUNCTION)
3880 desc = info->descriptor;
3882 if (se->want_pointer)
3883 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3887 if (expr->ts.type == BT_CHARACTER)
3888 se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
3892 /* We pass sections without copying to a temporary. Make a new
3893 descriptor and point it at the section we want. The loop variable
3894 limits will be the limits of the section.
3895 A function may decide to repack the array to speed up access, but
3896 we're not bothered about that here. */
3905 /* Set the string_length for a character array. */
3906 if (expr->ts.type == BT_CHARACTER)
3907 se->string_length = gfc_get_expr_charlen (expr);
3909 desc = info->descriptor;
3910 gcc_assert (secss && secss != gfc_ss_terminator);
3911 if (se->direct_byref)
3913 /* For pointer assignments we fill in the destination. */
3915 parmtype = TREE_TYPE (parm);
3919 /* Otherwise make a new one. */
3920 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3921 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3922 loop.from, loop.to, 0);
3923 parm = gfc_create_var (parmtype, "parm");
3926 offset = gfc_index_zero_node;
3929 /* The following can be somewhat confusing. We have two
3930 descriptors, a new one and the original array.
3931 {parm, parmtype, dim} refer to the new one.
3932 {desc, type, n, secss, loop} refer to the original, which maybe
3933 a descriptorless array.
3934 The bounds of the scalarization are the bounds of the section.
3935 We don't have to worry about numeric overflows when calculating
3936 the offsets because all elements are within the array data. */
3938 /* Set the dtype. */
3939 tmp = gfc_conv_descriptor_dtype (parm);
3940 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
3942 if (se->direct_byref)
3943 base = gfc_index_zero_node;
3947 for (n = 0; n < info->ref->u.ar.dimen; n++)
3949 stride = gfc_conv_array_stride (desc, n);
3951 /* Work out the offset. */
3952 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3954 gcc_assert (info->subscript[n]
3955 && info->subscript[n]->type == GFC_SS_SCALAR);
3956 start = info->subscript[n]->data.scalar.expr;
3960 /* Check we haven't somehow got out of sync. */
3961 gcc_assert (info->dim[dim] == n);
3963 /* Evaluate and remember the start of the section. */
3964 start = info->start[dim];
3965 stride = gfc_evaluate_now (stride, &loop.pre);
3968 tmp = gfc_conv_array_lbound (desc, n);
3969 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
3971 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
3972 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
3974 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3976 /* For elemental dimensions, we only need the offset. */
3980 /* Vector subscripts need copying and are handled elsewhere. */
3981 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
3983 /* Set the new lower bound. */
3984 from = loop.from[dim];
3986 if (!integer_onep (from))
3988 /* Make sure the new section starts at 1. */
3989 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3990 gfc_index_one_node, from);
3991 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
3992 from = gfc_index_one_node;
3994 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
3995 gfc_add_modify_expr (&loop.pre, tmp, from);
3997 /* Set the new upper bound. */
3998 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
3999 gfc_add_modify_expr (&loop.pre, tmp, to);
4001 /* Multiply the stride by the section stride to get the
4003 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4004 stride, info->stride[dim]);
4006 if (se->direct_byref)
4007 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4010 /* Store the new stride. */
4011 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4012 gfc_add_modify_expr (&loop.pre, tmp, stride);
4017 /* Point the data pointer at the first element in the section. */
4018 tmp = gfc_conv_array_data (desc);
4019 tmp = gfc_build_indirect_ref (tmp);
4020 tmp = gfc_build_array_ref (tmp, offset);
4021 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4022 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4024 if (se->direct_byref)
4026 /* Set the offset. */
4027 tmp = gfc_conv_descriptor_offset (parm);
4028 gfc_add_modify_expr (&loop.pre, tmp, base);
4032 /* Only the callee knows what the correct offset it, so just set
4034 tmp = gfc_conv_descriptor_offset (parm);
4035 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4038 if (!se->direct_byref)
4040 /* Get a pointer to the new descriptor. */
4041 if (se->want_pointer)
4042 se->expr = gfc_build_addr_expr (NULL, parm);
4048 gfc_add_block_to_block (&se->pre, &loop.pre);
4049 gfc_add_block_to_block (&se->post, &loop.post);
4051 /* Cleanup the scalarizer. */
4052 gfc_cleanup_loop (&loop);
4056 /* Convert an array for passing as an actual parameter. */
4057 /* TODO: Optimize passing g77 arrays. */
4060 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4069 /* Passing address of the array if it is not pointer or assumed-shape. */
4070 if (expr->expr_type == EXPR_VARIABLE
4071 && expr->ref->u.ar.type == AR_FULL && g77)
4073 sym = expr->symtree->n.sym;
4074 tmp = gfc_get_symbol_decl (sym);
4075 if (sym->ts.type == BT_CHARACTER)
4076 se->string_length = sym->ts.cl->backend_decl;
4077 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4078 && !sym->attr.allocatable)
4080 /* Some variables are declared directly, others are declared as
4081 pointers and allocated on the heap. */
4082 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4085 se->expr = gfc_build_addr_expr (NULL, tmp);
4088 if (sym->attr.allocatable)
4090 se->expr = gfc_conv_array_data (tmp);
4095 se->want_pointer = 1;
4096 gfc_conv_expr_descriptor (se, expr, ss);
4101 /* Repack the array. */
4102 tmp = gfc_chainon_list (NULL_TREE, desc);
4103 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
4104 ptr = gfc_evaluate_now (ptr, &se->pre);
4107 gfc_start_block (&block);
4109 /* Copy the data back. */
4110 tmp = gfc_chainon_list (NULL_TREE, desc);
4111 tmp = gfc_chainon_list (tmp, ptr);
4112 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
4113 gfc_add_expr_to_block (&block, tmp);
4115 /* Free the temporary. */
4116 tmp = convert (pvoid_type_node, ptr);
4117 tmp = gfc_chainon_list (NULL_TREE, tmp);
4118 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
4119 gfc_add_expr_to_block (&block, tmp);
4121 stmt = gfc_finish_block (&block);
4123 gfc_init_block (&block);
4124 /* Only if it was repacked. This code needs to be executed before the
4125 loop cleanup code. */
4126 tmp = gfc_build_indirect_ref (desc);
4127 tmp = gfc_conv_array_data (tmp);
4128 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4129 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4131 gfc_add_expr_to_block (&block, tmp);
4132 gfc_add_block_to_block (&block, &se->post);
4134 gfc_init_block (&se->post);
4135 gfc_add_block_to_block (&se->post, &block);
4140 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4143 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4150 stmtblock_t fnblock;
4153 /* Make sure the frontend gets these right. */
4154 if (!(sym->attr.pointer || sym->attr.allocatable))
4156 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4158 gfc_init_block (&fnblock);
4160 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
4161 if (sym->ts.type == BT_CHARACTER
4162 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4163 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4165 /* Dummy and use associated variables don't need anything special. */
4166 if (sym->attr.dummy || sym->attr.use_assoc)
4168 gfc_add_expr_to_block (&fnblock, body);
4170 return gfc_finish_block (&fnblock);
4173 gfc_get_backend_locus (&loc);
4174 gfc_set_backend_locus (&sym->declared_at);
4175 descriptor = sym->backend_decl;
4177 if (TREE_STATIC (descriptor))
4179 /* SAVEd variables are not freed on exit. */
4180 gfc_trans_static_array_pointer (sym);
4184 /* Get the descriptor type. */
4185 type = TREE_TYPE (sym->backend_decl);
4186 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4188 /* NULLIFY the data pointer. */
4189 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4191 gfc_add_expr_to_block (&fnblock, body);
4193 gfc_set_backend_locus (&loc);
4194 /* Allocatable arrays need to be freed when they go out of scope. */
4195 if (sym->attr.allocatable)
4197 gfc_start_block (&block);
4199 /* Deallocate if still allocated at the end of the procedure. */
4200 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4202 tmp = gfc_conv_descriptor_data_get (descriptor);
4203 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4204 build_int_cst (TREE_TYPE (tmp), 0));
4205 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4206 gfc_add_expr_to_block (&block, tmp);
4208 tmp = gfc_finish_block (&block);
4209 gfc_add_expr_to_block (&fnblock, tmp);
4212 return gfc_finish_block (&fnblock);
4215 /************ Expression Walking Functions ******************/
4217 /* Walk a variable reference.
4219 Possible extension - multiple component subscripts.
4220 x(:,:) = foo%a(:)%b(:)
4222 forall (i=..., j=...)
4223 x(i,j) = foo%a(j)%b(i)
4225 This adds a fair amout of complexity because you need to deal with more
4226 than one ref. Maybe handle in a similar manner to vector subscripts.
4227 Maybe not worth the effort. */
4231 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4239 for (ref = expr->ref; ref; ref = ref->next)
4240 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4243 for (; ref; ref = ref->next)
4245 if (ref->type == REF_SUBSTRING)
4247 newss = gfc_get_ss ();
4248 newss->type = GFC_SS_SCALAR;
4249 newss->expr = ref->u.ss.start;
4253 newss = gfc_get_ss ();
4254 newss->type = GFC_SS_SCALAR;
4255 newss->expr = ref->u.ss.end;
4260 /* We're only interested in array sections from now on. */
4261 if (ref->type != REF_ARRAY)
4268 for (n = 0; n < ar->dimen; n++)
4270 newss = gfc_get_ss ();
4271 newss->type = GFC_SS_SCALAR;
4272 newss->expr = ar->start[n];
4279 newss = gfc_get_ss ();
4280 newss->type = GFC_SS_SECTION;
4283 newss->data.info.dimen = ar->as->rank;
4284 newss->data.info.ref = ref;
4286 /* Make sure array is the same as array(:,:), this way
4287 we don't need to special case all the time. */
4288 ar->dimen = ar->as->rank;
4289 for (n = 0; n < ar->dimen; n++)
4291 newss->data.info.dim[n] = n;
4292 ar->dimen_type[n] = DIMEN_RANGE;
4294 gcc_assert (ar->start[n] == NULL);
4295 gcc_assert (ar->end[n] == NULL);
4296 gcc_assert (ar->stride[n] == NULL);
4302 newss = gfc_get_ss ();
4303 newss->type = GFC_SS_SECTION;
4306 newss->data.info.dimen = 0;
4307 newss->data.info.ref = ref;
4311 /* We add SS chains for all the subscripts in the section. */
4312 for (n = 0; n < ar->dimen; n++)
4316 switch (ar->dimen_type[n])
4319 /* Add SS for elemental (scalar) subscripts. */
4320 gcc_assert (ar->start[n]);
4321 indexss = gfc_get_ss ();
4322 indexss->type = GFC_SS_SCALAR;
4323 indexss->expr = ar->start[n];
4324 indexss->next = gfc_ss_terminator;
4325 indexss->loop_chain = gfc_ss_terminator;
4326 newss->data.info.subscript[n] = indexss;
4330 /* We don't add anything for sections, just remember this
4331 dimension for later. */
4332 newss->data.info.dim[newss->data.info.dimen] = n;
4333 newss->data.info.dimen++;
4337 /* Get a SS for the vector. This will not be added to the
4339 indexss = gfc_walk_expr (ar->start[n]);
4340 if (indexss == gfc_ss_terminator)
4341 internal_error ("scalar vector subscript???");
4343 /* We currently only handle really simple vector
4345 if (indexss->next != gfc_ss_terminator)
4346 gfc_todo_error ("vector subscript expressions");
4347 indexss->loop_chain = gfc_ss_terminator;
4349 /* Mark this as a vector subscript. We don't add this
4350 directly into the chain, but as a subscript of the
4351 existing SS for this term. */
4352 indexss->type = GFC_SS_VECTOR;
4353 newss->data.info.subscript[n] = indexss;
4354 /* Also remember this dimension. */
4355 newss->data.info.dim[newss->data.info.dimen] = n;
4356 newss->data.info.dimen++;
4360 /* We should know what sort of section it is by now. */
4364 /* We should have at least one non-elemental dimension. */
4365 gcc_assert (newss->data.info.dimen > 0);
4370 /* We should know what sort of section it is by now. */
4379 /* Walk an expression operator. If only one operand of a binary expression is
4380 scalar, we must also add the scalar term to the SS chain. */
4383 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4389 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4390 if (expr->value.op.op2 == NULL)
4393 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4395 /* All operands are scalar. Pass back and let the caller deal with it. */
4399 /* All operands require scalarization. */
4400 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4403 /* One of the operands needs scalarization, the other is scalar.
4404 Create a gfc_ss for the scalar expression. */
4405 newss = gfc_get_ss ();
4406 newss->type = GFC_SS_SCALAR;
4409 /* First operand is scalar. We build the chain in reverse order, so
4410 add the scarar SS after the second operand. */
4412 while (head && head->next != ss)
4414 /* Check we haven't somehow broken the chain. */
4418 newss->expr = expr->value.op.op1;
4420 else /* head2 == head */
4422 gcc_assert (head2 == head);
4423 /* Second operand is scalar. */
4424 newss->next = head2;
4426 newss->expr = expr->value.op.op2;
4433 /* Reverse a SS chain. */
4436 gfc_reverse_ss (gfc_ss * ss)
4441 gcc_assert (ss != NULL);
4443 head = gfc_ss_terminator;
4444 while (ss != gfc_ss_terminator)
4447 /* Check we didn't somehow break the chain. */
4448 gcc_assert (next != NULL);
4458 /* Walk the arguments of an elemental function. */
4461 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4464 gfc_actual_arglist *arg;
4470 head = gfc_ss_terminator;
4473 for (arg = expr->value.function.actual; arg; arg = arg->next)
4478 newss = gfc_walk_subexpr (head, arg->expr);
4481 /* Scalar argument. */
4482 newss = gfc_get_ss ();
4484 newss->expr = arg->expr;
4494 while (tail->next != gfc_ss_terminator)
4501 /* If all the arguments are scalar we don't need the argument SS. */
4502 gfc_free_ss_chain (head);
4507 /* Add it onto the existing chain. */
4513 /* Walk a function call. Scalar functions are passed back, and taken out of
4514 scalarization loops. For elemental functions we walk their arguments.
4515 The result of functions returning arrays is stored in a temporary outside
4516 the loop, so that the function is only called once. Hence we do not need
4517 to walk their arguments. */
4520 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4523 gfc_intrinsic_sym *isym;
4526 isym = expr->value.function.isym;
4528 /* Handle intrinsic functions separately. */
4530 return gfc_walk_intrinsic_function (ss, expr, isym);
4532 sym = expr->value.function.esym;
4534 sym = expr->symtree->n.sym;
4536 /* A function that returns arrays. */
4537 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4539 newss = gfc_get_ss ();
4540 newss->type = GFC_SS_FUNCTION;
4543 newss->data.info.dimen = expr->rank;
4547 /* Walk the parameters of an elemental function. For now we always pass
4549 if (sym->attr.elemental)
4550 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4552 /* Scalar functions are OK as these are evaluated outside the scalarization
4553 loop. Pass back and let the caller deal with it. */
4558 /* An array temporary is constructed for array constructors. */
4561 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4566 newss = gfc_get_ss ();
4567 newss->type = GFC_SS_CONSTRUCTOR;
4570 newss->data.info.dimen = expr->rank;
4571 for (n = 0; n < expr->rank; n++)
4572 newss->data.info.dim[n] = n;
4578 /* Walk an expression. Add walked expressions to the head of the SS chain.
4579 A wholly scalar expression will not be added. */
4582 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4586 switch (expr->expr_type)
4589 head = gfc_walk_variable_expr (ss, expr);
4593 head = gfc_walk_op_expr (ss, expr);
4597 head = gfc_walk_function_expr (ss, expr);
4602 case EXPR_STRUCTURE:
4603 /* Pass back and let the caller deal with it. */
4607 head = gfc_walk_array_constructor (ss, expr);
4610 case EXPR_SUBSTRING:
4611 /* Pass back and let the caller deal with it. */
4615 internal_error ("bad expression type during walk (%d)",
4622 /* Entry point for expression walking.
4623 A return value equal to the passed chain means this is
4624 a scalar expression. It is up to the caller to take whatever action is
4625 necessary to translate these. */
4628 gfc_walk_expr (gfc_expr * expr)
4632 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4633 return gfc_reverse_ss (res);