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 /* If the bounds of SE's loop have not yet been set, see if they can be
437 determined from array spec AS, which is the array spec of a called
438 function. MAPPING maps the callee's dummy arguments to the values
439 that the caller is passing. Add any initialization and finalization
443 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
444 gfc_se * se, gfc_array_spec * as)
452 if (as && as->type == AS_EXPLICIT)
453 for (dim = 0; dim < se->loop->dimen; dim++)
455 n = se->loop->order[dim];
456 if (se->loop->to[n] == NULL_TREE)
458 /* Evaluate the lower bound. */
459 gfc_init_se (&tmpse, NULL);
460 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
461 gfc_add_block_to_block (&se->pre, &tmpse.pre);
462 gfc_add_block_to_block (&se->post, &tmpse.post);
465 /* ...and the upper bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* Set the upper bound of the loop to UPPER - LOWER. */
473 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
474 tmp = gfc_evaluate_now (tmp, &se->pre);
475 se->loop->to[n] = tmp;
481 /* Generate code to allocate an array temporary, or create a variable to
482 hold the data. If size is NULL zero the descriptor so that so that the
483 callee will allocate the array. Also generates code to free the array
486 Initialization code is added to PRE and finalization code to POST.
487 DYNAMIC is true if the caller may want to extend the array later
488 using realloc. This prevents us from putting the array on the stack. */
491 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
492 gfc_ss_info * info, tree size, tree nelem,
500 desc = info->descriptor;
501 info->offset = gfc_index_zero_node;
502 if (size == NULL_TREE || integer_zerop (size))
504 /* A callee allocated array. */
505 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
510 /* Allocate the temporary. */
511 onstack = !dynamic && gfc_can_put_var_on_stack (size);
515 /* Make a temporary variable to hold the data. */
516 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
518 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
520 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
522 tmp = gfc_create_var (tmp, "A");
523 tmp = gfc_build_addr_expr (NULL, tmp);
524 gfc_conv_descriptor_data_set (pre, desc, tmp);
528 /* Allocate memory to hold the data. */
529 args = gfc_chainon_list (NULL_TREE, size);
531 if (gfc_index_integer_kind == 4)
532 tmp = gfor_fndecl_internal_malloc;
533 else if (gfc_index_integer_kind == 8)
534 tmp = gfor_fndecl_internal_malloc64;
537 tmp = gfc_build_function_call (tmp, args);
538 tmp = gfc_evaluate_now (tmp, pre);
539 gfc_conv_descriptor_data_set (pre, desc, tmp);
542 info->data = gfc_conv_descriptor_data_get (desc);
544 /* The offset is zero because we create temporaries with a zero
546 tmp = gfc_conv_descriptor_offset (desc);
547 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
551 /* Free the temporary. */
552 tmp = gfc_conv_descriptor_data_get (desc);
553 tmp = fold_convert (pvoid_type_node, tmp);
554 tmp = gfc_chainon_list (NULL_TREE, tmp);
555 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
556 gfc_add_expr_to_block (post, tmp);
561 /* Generate code to allocate and initialize the descriptor for a temporary
562 array. This is used for both temporaries needed by the scalarizer, and
563 functions returning arrays. Adjusts the loop variables to be zero-based,
564 and calculates the loop bounds for callee allocated arrays.
565 Also fills in the descriptor, data and offset fields of info if known.
566 Returns the size of the array, or NULL for a callee allocated array.
568 PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage. */
571 gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
572 gfc_loopinfo * loop, gfc_ss_info * info,
573 tree eltype, bool dynamic)
583 gcc_assert (info->dimen > 0);
584 /* Set the lower bound to zero. */
585 for (dim = 0; dim < info->dimen; dim++)
587 n = loop->order[dim];
588 if (n < loop->temp_dim)
589 gcc_assert (integer_zerop (loop->from[n]));
592 /* Callee allocated arrays may not have a known bound yet. */
594 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
595 loop->to[n], loop->from[n]);
596 loop->from[n] = gfc_index_zero_node;
599 info->delta[dim] = gfc_index_zero_node;
600 info->start[dim] = gfc_index_zero_node;
601 info->stride[dim] = gfc_index_one_node;
602 info->dim[dim] = dim;
605 /* Initialize the descriptor. */
607 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
608 desc = gfc_create_var (type, "atmp");
609 GFC_DECL_PACKED_ARRAY (desc) = 1;
611 info->descriptor = desc;
612 size = gfc_index_one_node;
614 /* Fill in the array dtype. */
615 tmp = gfc_conv_descriptor_dtype (desc);
616 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
619 Fill in the bounds and stride. This is a packed array, so:
622 for (n = 0; n < rank; n++)
625 delta = ubound[n] + 1 - lbound[n];
628 size = size * sizeof(element);
631 for (n = 0; n < info->dimen; n++)
633 if (loop->to[n] == NULL_TREE)
635 /* For a callee allocated array express the loop bounds in terms
636 of the descriptor fields. */
637 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
638 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
639 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
645 /* Store the stride and bound components in the descriptor. */
646 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
647 gfc_add_modify_expr (pre, tmp, size);
649 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
650 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
652 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
653 gfc_add_modify_expr (pre, tmp, loop->to[n]);
655 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
656 loop->to[n], gfc_index_one_node);
658 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
659 size = gfc_evaluate_now (size, pre);
662 /* Get the size of the array. */
665 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
666 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
668 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
670 if (info->dimen > loop->temp_dim)
671 loop->temp_dim = info->dimen;
677 /* Return the number of iterations in a loop that starts at START,
678 ends at END, and has step STEP. */
681 gfc_get_iteration_count (tree start, tree end, tree step)
686 type = TREE_TYPE (step);
687 tmp = fold_build2 (MINUS_EXPR, type, end, start);
688 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
689 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
690 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
691 return fold_convert (gfc_array_index_type, tmp);
695 /* Extend the data in array DESC by EXTRA elements. */
698 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
705 if (integer_zerop (extra))
708 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
710 /* Add EXTRA to the upper bound. */
711 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
712 gfc_add_modify_expr (pblock, ubound, tmp);
714 /* Get the value of the current data pointer. */
715 tmp = gfc_conv_descriptor_data_get (desc);
716 args = gfc_chainon_list (NULL_TREE, tmp);
718 /* Calculate the new array size. */
719 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
720 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
721 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
722 args = gfc_chainon_list (args, tmp);
724 /* Pick the appropriate realloc function. */
725 if (gfc_index_integer_kind == 4)
726 tmp = gfor_fndecl_internal_realloc;
727 else if (gfc_index_integer_kind == 8)
728 tmp = gfor_fndecl_internal_realloc64;
732 /* Set the new data pointer. */
733 tmp = gfc_build_function_call (tmp, args);
734 gfc_conv_descriptor_data_set (pblock, desc, tmp);
738 /* Return true if the bounds of iterator I can only be determined
742 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
744 return (i->start->expr_type != EXPR_CONSTANT
745 || i->end->expr_type != EXPR_CONSTANT
746 || i->step->expr_type != EXPR_CONSTANT);
750 /* Split the size of constructor element EXPR into the sum of two terms,
751 one of which can be determined at compile time and one of which must
752 be calculated at run time. Set *SIZE to the former and return true
753 if the latter might be nonzero. */
756 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
758 if (expr->expr_type == EXPR_ARRAY)
759 return gfc_get_array_constructor_size (size, expr->value.constructor);
760 else if (expr->rank > 0)
762 /* Calculate everything at run time. */
763 mpz_set_ui (*size, 0);
768 /* A single element. */
769 mpz_set_ui (*size, 1);
775 /* Like gfc_get_array_constructor_element_size, but applied to the whole
776 of array constructor C. */
779 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
786 mpz_set_ui (*size, 0);
791 for (; c; c = c->next)
794 if (i && gfc_iterator_has_dynamic_bounds (i))
798 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
801 /* Multiply the static part of the element size by the
802 number of iterations. */
803 mpz_sub (val, i->end->value.integer, i->start->value.integer);
804 mpz_fdiv_q (val, val, i->step->value.integer);
805 mpz_add_ui (val, val, 1);
806 if (mpz_sgn (val) > 0)
807 mpz_mul (len, len, val);
811 mpz_add (*size, *size, len);
820 /* Make sure offset is a variable. */
823 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
826 /* We should have already created the offset variable. We cannot
827 create it here because we may be in an inner scope. */
828 gcc_assert (*offsetvar != NULL_TREE);
829 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
830 *poffset = *offsetvar;
831 TREE_USED (*offsetvar) = 1;
835 /* Assign an element of an array constructor. */
838 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
839 tree offset, gfc_se * se, gfc_expr * expr)
844 gfc_conv_expr (se, expr);
846 /* Store the value. */
847 tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
848 tmp = gfc_build_array_ref (tmp, offset);
849 if (expr->ts.type == BT_CHARACTER)
851 gfc_conv_string_parameter (se);
852 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
854 /* The temporary is an array of pointers. */
855 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
856 gfc_add_modify_expr (&se->pre, tmp, se->expr);
860 /* The temporary is an array of string values. */
861 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
862 /* We know the temporary and the value will be the same length,
863 so can use memcpy. */
864 args = gfc_chainon_list (NULL_TREE, tmp);
865 args = gfc_chainon_list (args, se->expr);
866 args = gfc_chainon_list (args, se->string_length);
867 tmp = built_in_decls[BUILT_IN_MEMCPY];
868 tmp = gfc_build_function_call (tmp, args);
869 gfc_add_expr_to_block (&se->pre, tmp);
874 /* TODO: Should the frontend already have done this conversion? */
875 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
876 gfc_add_modify_expr (&se->pre, tmp, se->expr);
879 gfc_add_block_to_block (pblock, &se->pre);
880 gfc_add_block_to_block (pblock, &se->post);
884 /* Add the contents of an array to the constructor. DYNAMIC is as for
885 gfc_trans_array_constructor_value. */
888 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
889 tree type ATTRIBUTE_UNUSED,
890 tree desc, gfc_expr * expr,
891 tree * poffset, tree * offsetvar,
902 /* We need this to be a variable so we can increment it. */
903 gfc_put_offset_into_var (pblock, poffset, offsetvar);
905 gfc_init_se (&se, NULL);
907 /* Walk the array expression. */
908 ss = gfc_walk_expr (expr);
909 gcc_assert (ss != gfc_ss_terminator);
911 /* Initialize the scalarizer. */
912 gfc_init_loopinfo (&loop);
913 gfc_add_ss_to_loop (&loop, ss);
915 /* Initialize the loop. */
916 gfc_conv_ss_startstride (&loop);
917 gfc_conv_loop_setup (&loop);
919 /* Make sure the constructed array has room for the new data. */
922 /* Set SIZE to the total number of elements in the subarray. */
923 size = gfc_index_one_node;
924 for (n = 0; n < loop.dimen; n++)
926 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
928 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
931 /* Grow the constructed array by SIZE elements. */
932 gfc_grow_array (&loop.pre, desc, size);
935 /* Make the loop body. */
936 gfc_mark_ss_chain_used (ss, 1);
937 gfc_start_scalarized_body (&loop, &body);
938 gfc_copy_loopinfo_to_se (&se, &loop);
941 if (expr->ts.type == BT_CHARACTER)
942 gfc_todo_error ("character arrays in constructors");
944 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
945 gcc_assert (se.ss == gfc_ss_terminator);
947 /* Increment the offset. */
948 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
949 gfc_add_modify_expr (&body, *poffset, tmp);
951 /* Finish the loop. */
952 gfc_trans_scalarizing_loops (&loop, &body);
953 gfc_add_block_to_block (&loop.pre, &loop.post);
954 tmp = gfc_finish_block (&loop.pre);
955 gfc_add_expr_to_block (pblock, tmp);
957 gfc_cleanup_loop (&loop);
961 /* Assign the values to the elements of an array constructor. DYNAMIC
962 is true if descriptor DESC only contains enough data for the static
963 size calculated by gfc_get_array_constructor_size. When true, memory
964 for the dynamic parts must be allocated using realloc. */
967 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
968 tree desc, gfc_constructor * c,
969 tree * poffset, tree * offsetvar,
978 for (; c; c = c->next)
980 /* If this is an iterator or an array, the offset must be a variable. */
981 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
982 gfc_put_offset_into_var (pblock, poffset, offsetvar);
984 gfc_start_block (&body);
986 if (c->expr->expr_type == EXPR_ARRAY)
988 /* Array constructors can be nested. */
989 gfc_trans_array_constructor_value (&body, type, desc,
990 c->expr->value.constructor,
991 poffset, offsetvar, dynamic);
993 else if (c->expr->rank > 0)
995 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
996 poffset, offsetvar, dynamic);
1000 /* This code really upsets the gimplifier so don't bother for now. */
1007 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1014 /* Scalar values. */
1015 gfc_init_se (&se, NULL);
1016 gfc_trans_array_ctor_element (&body, desc, *poffset,
1019 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1020 *poffset, gfc_index_one_node);
1024 /* Collect multiple scalar constants into a constructor. */
1032 /* Count the number of consecutive scalar constants. */
1033 while (p && !(p->iterator
1034 || p->expr->expr_type != EXPR_CONSTANT))
1036 gfc_init_se (&se, NULL);
1037 gfc_conv_constant (&se, p->expr);
1038 if (p->expr->ts.type == BT_CHARACTER
1039 && POINTER_TYPE_P (type))
1041 /* For constant character array constructors we build
1042 an array of pointers. */
1043 se.expr = gfc_build_addr_expr (pchar_type_node,
1047 list = tree_cons (NULL_TREE, se.expr, list);
1052 bound = build_int_cst (NULL_TREE, n - 1);
1053 /* Create an array type to hold them. */
1054 tmptype = build_range_type (gfc_array_index_type,
1055 gfc_index_zero_node, bound);
1056 tmptype = build_array_type (type, tmptype);
1058 init = build_constructor_from_list (tmptype, nreverse (list));
1059 TREE_CONSTANT (init) = 1;
1060 TREE_INVARIANT (init) = 1;
1061 TREE_STATIC (init) = 1;
1062 /* Create a static variable to hold the data. */
1063 tmp = gfc_create_var (tmptype, "data");
1064 TREE_STATIC (tmp) = 1;
1065 TREE_CONSTANT (tmp) = 1;
1066 TREE_INVARIANT (tmp) = 1;
1067 DECL_INITIAL (tmp) = init;
1070 /* Use BUILTIN_MEMCPY to assign the values. */
1071 tmp = gfc_conv_descriptor_data_get (desc);
1072 tmp = gfc_build_indirect_ref (tmp);
1073 tmp = gfc_build_array_ref (tmp, *poffset);
1074 tmp = gfc_build_addr_expr (NULL, tmp);
1075 init = gfc_build_addr_expr (NULL, init);
1077 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1078 bound = build_int_cst (NULL_TREE, n * size);
1079 tmp = gfc_chainon_list (NULL_TREE, tmp);
1080 tmp = gfc_chainon_list (tmp, init);
1081 tmp = gfc_chainon_list (tmp, bound);
1082 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
1084 gfc_add_expr_to_block (&body, tmp);
1086 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1087 *poffset, build_int_cst (NULL_TREE, n));
1089 if (!INTEGER_CST_P (*poffset))
1091 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1092 *poffset = *offsetvar;
1096 /* The frontend should already have done any expansions possible
1100 /* Pass the code as is. */
1101 tmp = gfc_finish_block (&body);
1102 gfc_add_expr_to_block (pblock, tmp);
1106 /* Build the implied do-loop. */
1115 loopbody = gfc_finish_block (&body);
1117 gfc_init_se (&se, NULL);
1118 gfc_conv_expr (&se, c->iterator->var);
1119 gfc_add_block_to_block (pblock, &se.pre);
1122 /* Initialize the loop. */
1123 gfc_init_se (&se, NULL);
1124 gfc_conv_expr_val (&se, c->iterator->start);
1125 gfc_add_block_to_block (pblock, &se.pre);
1126 gfc_add_modify_expr (pblock, loopvar, se.expr);
1128 gfc_init_se (&se, NULL);
1129 gfc_conv_expr_val (&se, c->iterator->end);
1130 gfc_add_block_to_block (pblock, &se.pre);
1131 end = gfc_evaluate_now (se.expr, pblock);
1133 gfc_init_se (&se, NULL);
1134 gfc_conv_expr_val (&se, c->iterator->step);
1135 gfc_add_block_to_block (pblock, &se.pre);
1136 step = gfc_evaluate_now (se.expr, pblock);
1138 /* If this array expands dynamically, and the number of iterations
1139 is not constant, we won't have allocated space for the static
1140 part of C->EXPR's size. Do that now. */
1141 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1143 /* Get the number of iterations. */
1144 tmp = gfc_get_iteration_count (loopvar, end, step);
1146 /* Get the static part of C->EXPR's size. */
1147 gfc_get_array_constructor_element_size (&size, c->expr);
1148 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1150 /* Grow the array by TMP * TMP2 elements. */
1151 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1152 gfc_grow_array (pblock, desc, tmp);
1155 /* Generate the loop body. */
1156 exit_label = gfc_build_label_decl (NULL_TREE);
1157 gfc_start_block (&body);
1159 /* Generate the exit condition. Depending on the sign of
1160 the step variable we have to generate the correct
1162 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1163 build_int_cst (TREE_TYPE (step), 0));
1164 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1165 build2 (GT_EXPR, boolean_type_node,
1167 build2 (LT_EXPR, boolean_type_node,
1169 tmp = build1_v (GOTO_EXPR, exit_label);
1170 TREE_USED (exit_label) = 1;
1171 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1172 gfc_add_expr_to_block (&body, tmp);
1174 /* The main loop body. */
1175 gfc_add_expr_to_block (&body, loopbody);
1177 /* Increase loop variable by step. */
1178 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1179 gfc_add_modify_expr (&body, loopvar, tmp);
1181 /* Finish the loop. */
1182 tmp = gfc_finish_block (&body);
1183 tmp = build1_v (LOOP_EXPR, tmp);
1184 gfc_add_expr_to_block (pblock, tmp);
1186 /* Add the exit label. */
1187 tmp = build1_v (LABEL_EXPR, exit_label);
1188 gfc_add_expr_to_block (pblock, tmp);
1195 /* Figure out the string length of a variable reference expression.
1196 Used by get_array_ctor_strlen. */
1199 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1204 /* Don't bother if we already know the length is a constant. */
1205 if (*len && INTEGER_CST_P (*len))
1208 ts = &expr->symtree->n.sym->ts;
1209 for (ref = expr->ref; ref; ref = ref->next)
1214 /* Array references don't change the string length. */
1218 /* Use the length of the component. */
1219 ts = &ref->u.c.component->ts;
1223 /* TODO: Substrings are tricky because we can't evaluate the
1224 expression more than once. For now we just give up, and hope
1225 we can figure it out elsewhere. */
1230 *len = ts->cl->backend_decl;
1234 /* Figure out the string length of a character array constructor.
1235 Returns TRUE if all elements are character constants. */
1238 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1243 for (; c; c = c->next)
1245 switch (c->expr->expr_type)
1248 if (!(*len && INTEGER_CST_P (*len)))
1249 *len = build_int_cstu (gfc_charlen_type_node,
1250 c->expr->value.character.length);
1254 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1260 get_array_ctor_var_strlen (c->expr, len);
1265 /* TODO: For now we just ignore anything we don't know how to
1266 handle, and hope we can figure it out a different way. */
1275 /* Array constructors are handled by constructing a temporary, then using that
1276 within the scalarization loop. This is not optimal, but seems by far the
1280 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1290 ss->data.info.dimen = loop->dimen;
1292 c = ss->expr->value.constructor;
1293 if (ss->expr->ts.type == BT_CHARACTER)
1295 const_string = get_array_ctor_strlen (c, &ss->string_length);
1296 if (!ss->string_length)
1297 gfc_todo_error ("complex character array constructors");
1299 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1301 type = build_pointer_type (type);
1305 const_string = TRUE;
1306 type = gfc_typenode_for_spec (&ss->expr->ts);
1309 /* See if the constructor determines the loop bounds. */
1311 if (loop->to[0] == NULL_TREE)
1315 /* We should have a 1-dimensional, zero-based loop. */
1316 gcc_assert (loop->dimen == 1);
1317 gcc_assert (integer_zerop (loop->from[0]));
1319 /* Split the constructor size into a static part and a dynamic part.
1320 Allocate the static size up-front and record whether the dynamic
1321 size might be nonzero. */
1323 dynamic = gfc_get_array_constructor_size (&size, c);
1324 mpz_sub_ui (size, size, 1);
1325 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1329 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
1330 &ss->data.info, type, dynamic);
1332 desc = ss->data.info.descriptor;
1333 offset = gfc_index_zero_node;
1334 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1335 TREE_USED (offsetvar) = 0;
1336 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1337 &offset, &offsetvar, dynamic);
1339 /* If the array grows dynamically, the upper bound of the loop variable
1340 is determined by the array's final upper bound. */
1342 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1344 if (TREE_USED (offsetvar))
1345 pushdecl (offsetvar);
1347 gcc_assert (INTEGER_CST_P (offset));
1349 /* Disable bound checking for now because it's probably broken. */
1350 if (flag_bounds_check)
1358 /* Add the pre and post chains for all the scalar expressions in a SS chain
1359 to loop. This is called after the loop parameters have been calculated,
1360 but before the actual scalarizing loops. */
1363 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1368 /* TODO: This can generate bad code if there are ordering dependencies.
1369 eg. a callee allocated function and an unknown size constructor. */
1370 gcc_assert (ss != NULL);
1372 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1379 /* Scalar expression. Evaluate this now. This includes elemental
1380 dimension indices, but not array section bounds. */
1381 gfc_init_se (&se, NULL);
1382 gfc_conv_expr (&se, ss->expr);
1383 gfc_add_block_to_block (&loop->pre, &se.pre);
1385 if (ss->expr->ts.type != BT_CHARACTER)
1387 /* Move the evaluation of scalar expressions outside the
1388 scalarization loop. */
1390 se.expr = convert(gfc_array_index_type, se.expr);
1391 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1392 gfc_add_block_to_block (&loop->pre, &se.post);
1395 gfc_add_block_to_block (&loop->post, &se.post);
1397 ss->data.scalar.expr = se.expr;
1398 ss->string_length = se.string_length;
1401 case GFC_SS_REFERENCE:
1402 /* Scalar reference. Evaluate this now. */
1403 gfc_init_se (&se, NULL);
1404 gfc_conv_expr_reference (&se, ss->expr);
1405 gfc_add_block_to_block (&loop->pre, &se.pre);
1406 gfc_add_block_to_block (&loop->post, &se.post);
1408 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1409 ss->string_length = se.string_length;
1412 case GFC_SS_SECTION:
1414 /* Scalarized expression. Evaluate any scalar subscripts. */
1415 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1417 /* Add the expressions for scalar subscripts. */
1418 if (ss->data.info.subscript[n])
1419 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1423 case GFC_SS_INTRINSIC:
1424 gfc_add_intrinsic_ss_code (loop, ss);
1427 case GFC_SS_FUNCTION:
1428 /* Array function return value. We call the function and save its
1429 result in a temporary for use inside the loop. */
1430 gfc_init_se (&se, NULL);
1433 gfc_conv_expr (&se, ss->expr);
1434 gfc_add_block_to_block (&loop->pre, &se.pre);
1435 gfc_add_block_to_block (&loop->post, &se.post);
1436 ss->string_length = se.string_length;
1439 case GFC_SS_CONSTRUCTOR:
1440 gfc_trans_array_constructor (loop, ss);
1444 case GFC_SS_COMPONENT:
1445 /* Do nothing. These are handled elsewhere. */
1455 /* Translate expressions for the descriptor and data pointer of a SS. */
1459 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1464 /* Get the descriptor for the array to be scalarized. */
1465 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1466 gfc_init_se (&se, NULL);
1467 se.descriptor_only = 1;
1468 gfc_conv_expr_lhs (&se, ss->expr);
1469 gfc_add_block_to_block (block, &se.pre);
1470 ss->data.info.descriptor = se.expr;
1471 ss->string_length = se.string_length;
1475 /* Also the data pointer. */
1476 tmp = gfc_conv_array_data (se.expr);
1477 /* If this is a variable or address of a variable we use it directly.
1478 Otherwise we must evaluate it now to avoid breaking dependency
1479 analysis by pulling the expressions for elemental array indices
1482 || (TREE_CODE (tmp) == ADDR_EXPR
1483 && DECL_P (TREE_OPERAND (tmp, 0)))))
1484 tmp = gfc_evaluate_now (tmp, block);
1485 ss->data.info.data = tmp;
1487 tmp = gfc_conv_array_offset (se.expr);
1488 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1493 /* Initialize a gfc_loopinfo structure. */
1496 gfc_init_loopinfo (gfc_loopinfo * loop)
1500 memset (loop, 0, sizeof (gfc_loopinfo));
1501 gfc_init_block (&loop->pre);
1502 gfc_init_block (&loop->post);
1504 /* Initially scalarize in order. */
1505 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1508 loop->ss = gfc_ss_terminator;
1512 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1516 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1522 /* Return an expression for the data pointer of an array. */
1525 gfc_conv_array_data (tree descriptor)
1529 type = TREE_TYPE (descriptor);
1530 if (GFC_ARRAY_TYPE_P (type))
1532 if (TREE_CODE (type) == POINTER_TYPE)
1536 /* Descriptorless arrays. */
1537 return gfc_build_addr_expr (NULL, descriptor);
1541 return gfc_conv_descriptor_data_get (descriptor);
1545 /* Return an expression for the base offset of an array. */
1548 gfc_conv_array_offset (tree descriptor)
1552 type = TREE_TYPE (descriptor);
1553 if (GFC_ARRAY_TYPE_P (type))
1554 return GFC_TYPE_ARRAY_OFFSET (type);
1556 return gfc_conv_descriptor_offset (descriptor);
1560 /* Get an expression for the array stride. */
1563 gfc_conv_array_stride (tree descriptor, int dim)
1568 type = TREE_TYPE (descriptor);
1570 /* For descriptorless arrays use the array size. */
1571 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1572 if (tmp != NULL_TREE)
1575 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1580 /* Like gfc_conv_array_stride, but for the lower bound. */
1583 gfc_conv_array_lbound (tree descriptor, int dim)
1588 type = TREE_TYPE (descriptor);
1590 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1591 if (tmp != NULL_TREE)
1594 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1599 /* Like gfc_conv_array_stride, but for the upper bound. */
1602 gfc_conv_array_ubound (tree descriptor, int dim)
1607 type = TREE_TYPE (descriptor);
1609 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1610 if (tmp != NULL_TREE)
1613 /* This should only ever happen when passing an assumed shape array
1614 as an actual parameter. The value will never be used. */
1615 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1616 return gfc_index_zero_node;
1618 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1623 /* Translate an array reference. The descriptor should be in se->expr.
1624 Do not use this function, it wil be removed soon. */
1628 gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
1629 tree offset, int dimen)
1636 array = gfc_build_indirect_ref (pointer);
1639 for (n = 0; n < dimen; n++)
1641 /* index = index + stride[n]*indices[n] */
1642 tmp = gfc_conv_array_stride (se->expr, n);
1643 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
1645 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1648 /* Result = data[index]. */
1649 tmp = gfc_build_array_ref (array, index);
1651 /* Check we've used the correct number of dimensions. */
1652 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
1658 /* Generate code to perform an array index bound check. */
1661 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1667 if (!flag_bounds_check)
1670 index = gfc_evaluate_now (index, &se->pre);
1671 /* Check lower bound. */
1672 tmp = gfc_conv_array_lbound (descriptor, n);
1673 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1674 /* Check upper bound. */
1675 tmp = gfc_conv_array_ubound (descriptor, n);
1676 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1677 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1679 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1685 /* A reference to an array vector subscript. Uses recursion to handle nested
1686 vector subscripts. */
1689 gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
1692 tree indices[GFC_MAX_DIMENSIONS];
1697 gcc_assert (ss && ss->type == GFC_SS_VECTOR);
1699 /* Save the descriptor. */
1700 descsave = se->expr;
1701 info = &ss->data.info;
1702 se->expr = info->descriptor;
1704 ar = &info->ref->u.ar;
1705 for (n = 0; n < ar->dimen; n++)
1707 switch (ar->dimen_type[n])
1710 gcc_assert (info->subscript[n] != gfc_ss_terminator
1711 && info->subscript[n]->type == GFC_SS_SCALAR);
1712 indices[n] = info->subscript[n]->data.scalar.expr;
1720 index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
1723 gfc_trans_array_bound_check (se, info->descriptor, index, n);
1730 /* Get the index from the vector. */
1731 gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
1733 /* Put the descriptor back. */
1734 se->expr = descsave;
1740 /* Return the offset for an index. Performs bound checking for elemental
1741 dimensions. Single element references are processed separately. */
1744 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1745 gfc_array_ref * ar, tree stride)
1749 /* Get the index into the array for this dimension. */
1752 gcc_assert (ar->type != AR_ELEMENT);
1753 if (ar->dimen_type[dim] == DIMEN_ELEMENT)
1755 gcc_assert (i == -1);
1756 /* Elemental dimension. */
1757 gcc_assert (info->subscript[dim]
1758 && info->subscript[dim]->type == GFC_SS_SCALAR);
1759 /* We've already translated this value outside the loop. */
1760 index = info->subscript[dim]->data.scalar.expr;
1763 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1767 /* Scalarized dimension. */
1768 gcc_assert (info && se->loop);
1770 /* Multiply the loop variable by the stride and delta. */
1771 index = se->loop->loopvar[i];
1772 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1774 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1777 if (ar->dimen_type[dim] == DIMEN_VECTOR)
1779 /* Handle vector subscripts. */
1780 index = gfc_conv_vector_array_index (se, index,
1781 info->subscript[dim]);
1783 gfc_trans_array_bound_check (se, info->descriptor, index,
1787 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
1792 /* Temporary array or derived type component. */
1793 gcc_assert (se->loop);
1794 index = se->loop->loopvar[se->loop->order[i]];
1795 if (!integer_zerop (info->delta[i]))
1796 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1797 index, info->delta[i]);
1800 /* Multiply by the stride. */
1801 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1807 /* Build a scalarized reference to an array. */
1810 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1817 info = &se->ss->data.info;
1819 n = se->loop->order[0];
1823 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1825 /* Add the offset for this dimension to the stored offset for all other
1827 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1829 tmp = gfc_build_indirect_ref (info->data);
1830 se->expr = gfc_build_array_ref (tmp, index);
1834 /* Translate access of temporary array. */
1837 gfc_conv_tmp_array_ref (gfc_se * se)
1839 se->string_length = se->ss->string_length;
1840 gfc_conv_scalarized_array_ref (se, NULL);
1844 /* Build an array reference. se->expr already holds the array descriptor.
1845 This should be either a variable, indirect variable reference or component
1846 reference. For arrays which do not have a descriptor, se->expr will be
1848 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1851 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1860 /* Handle scalarized references separately. */
1861 if (ar->type != AR_ELEMENT)
1863 gfc_conv_scalarized_array_ref (se, ar);
1864 gfc_advance_se_ss_chain (se);
1868 index = gfc_index_zero_node;
1870 fault = gfc_index_zero_node;
1872 /* Calculate the offsets from all the dimensions. */
1873 for (n = 0; n < ar->dimen; n++)
1875 /* Calculate the index for this dimension. */
1876 gfc_init_se (&indexse, se);
1877 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1878 gfc_add_block_to_block (&se->pre, &indexse.pre);
1880 if (flag_bounds_check)
1882 /* Check array bounds. */
1885 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1887 tmp = gfc_conv_array_lbound (se->expr, n);
1888 cond = fold_build2 (LT_EXPR, boolean_type_node,
1891 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1893 tmp = gfc_conv_array_ubound (se->expr, n);
1894 cond = fold_build2 (GT_EXPR, boolean_type_node,
1897 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1900 /* Multiply the index by the stride. */
1901 stride = gfc_conv_array_stride (se->expr, n);
1902 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1905 /* And add it to the total. */
1906 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1909 if (flag_bounds_check)
1910 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1912 tmp = gfc_conv_array_offset (se->expr);
1913 if (!integer_zerop (tmp))
1914 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1916 /* Access the calculated element. */
1917 tmp = gfc_conv_array_data (se->expr);
1918 tmp = gfc_build_indirect_ref (tmp);
1919 se->expr = gfc_build_array_ref (tmp, index);
1923 /* Generate the code to be executed immediately before entering a
1924 scalarization loop. */
1927 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1928 stmtblock_t * pblock)
1937 /* This code will be executed before entering the scalarization loop
1938 for this dimension. */
1939 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1941 if ((ss->useflags & flag) == 0)
1944 if (ss->type != GFC_SS_SECTION
1945 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1946 && ss->type != GFC_SS_COMPONENT)
1949 info = &ss->data.info;
1951 if (dim >= info->dimen)
1954 if (dim == info->dimen - 1)
1956 /* For the outermost loop calculate the offset due to any
1957 elemental dimensions. It will have been initialized with the
1958 base offset of the array. */
1961 for (i = 0; i < info->ref->u.ar.dimen; i++)
1963 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1966 gfc_init_se (&se, NULL);
1968 se.expr = info->descriptor;
1969 stride = gfc_conv_array_stride (info->descriptor, i);
1970 index = gfc_conv_array_index_offset (&se, info, i, -1,
1973 gfc_add_block_to_block (pblock, &se.pre);
1975 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1976 info->offset, index);
1977 info->offset = gfc_evaluate_now (info->offset, pblock);
1981 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1984 stride = gfc_conv_array_stride (info->descriptor, 0);
1986 /* Calculate the stride of the innermost loop. Hopefully this will
1987 allow the backend optimizers to do their stuff more effectively.
1989 info->stride0 = gfc_evaluate_now (stride, pblock);
1993 /* Add the offset for the previous loop dimension. */
1998 ar = &info->ref->u.ar;
1999 i = loop->order[dim + 1];
2007 gfc_init_se (&se, NULL);
2009 se.expr = info->descriptor;
2010 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2011 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2013 gfc_add_block_to_block (pblock, &se.pre);
2014 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2015 info->offset, index);
2016 info->offset = gfc_evaluate_now (info->offset, pblock);
2019 /* Remember this offset for the second loop. */
2020 if (dim == loop->temp_dim - 1)
2021 info->saved_offset = info->offset;
2026 /* Start a scalarized expression. Creates a scope and declares loop
2030 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2036 gcc_assert (!loop->array_parameter);
2038 for (dim = loop->dimen - 1; dim >= 0; dim--)
2040 n = loop->order[dim];
2042 gfc_start_block (&loop->code[n]);
2044 /* Create the loop variable. */
2045 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2047 if (dim < loop->temp_dim)
2051 /* Calculate values that will be constant within this loop. */
2052 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2054 gfc_start_block (pbody);
2058 /* Generates the actual loop code for a scalarization loop. */
2061 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2062 stmtblock_t * pbody)
2070 loopbody = gfc_finish_block (pbody);
2072 /* Initialize the loopvar. */
2073 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2075 exit_label = gfc_build_label_decl (NULL_TREE);
2077 /* Generate the loop body. */
2078 gfc_init_block (&block);
2080 /* The exit condition. */
2081 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2082 tmp = build1_v (GOTO_EXPR, exit_label);
2083 TREE_USED (exit_label) = 1;
2084 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2085 gfc_add_expr_to_block (&block, tmp);
2087 /* The main body. */
2088 gfc_add_expr_to_block (&block, loopbody);
2090 /* Increment the loopvar. */
2091 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2092 loop->loopvar[n], gfc_index_one_node);
2093 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2095 /* Build the loop. */
2096 tmp = gfc_finish_block (&block);
2097 tmp = build1_v (LOOP_EXPR, tmp);
2098 gfc_add_expr_to_block (&loop->code[n], tmp);
2100 /* Add the exit label. */
2101 tmp = build1_v (LABEL_EXPR, exit_label);
2102 gfc_add_expr_to_block (&loop->code[n], tmp);
2106 /* Finishes and generates the loops for a scalarized expression. */
2109 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2114 stmtblock_t *pblock;
2118 /* Generate the loops. */
2119 for (dim = 0; dim < loop->dimen; dim++)
2121 n = loop->order[dim];
2122 gfc_trans_scalarized_loop_end (loop, n, pblock);
2123 loop->loopvar[n] = NULL_TREE;
2124 pblock = &loop->code[n];
2127 tmp = gfc_finish_block (pblock);
2128 gfc_add_expr_to_block (&loop->pre, tmp);
2130 /* Clear all the used flags. */
2131 for (ss = loop->ss; ss; ss = ss->loop_chain)
2136 /* Finish the main body of a scalarized expression, and start the secondary
2140 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2144 stmtblock_t *pblock;
2148 /* We finish as many loops as are used by the temporary. */
2149 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2151 n = loop->order[dim];
2152 gfc_trans_scalarized_loop_end (loop, n, pblock);
2153 loop->loopvar[n] = NULL_TREE;
2154 pblock = &loop->code[n];
2157 /* We don't want to finish the outermost loop entirely. */
2158 n = loop->order[loop->temp_dim - 1];
2159 gfc_trans_scalarized_loop_end (loop, n, pblock);
2161 /* Restore the initial offsets. */
2162 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2164 if ((ss->useflags & 2) == 0)
2167 if (ss->type != GFC_SS_SECTION
2168 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2169 && ss->type != GFC_SS_COMPONENT)
2172 ss->data.info.offset = ss->data.info.saved_offset;
2175 /* Restart all the inner loops we just finished. */
2176 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2178 n = loop->order[dim];
2180 gfc_start_block (&loop->code[n]);
2182 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2184 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2187 /* Start a block for the secondary copying code. */
2188 gfc_start_block (body);
2192 /* Calculate the upper bound of an array section. */
2195 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2204 gcc_assert (ss->type == GFC_SS_SECTION);
2206 /* For vector array subscripts we want the size of the vector. */
2207 dim = ss->data.info.dim[n];
2209 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2211 vecss = vecss->data.info.subscript[dim];
2212 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2213 dim = vecss->data.info.dim[0];
2216 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2217 end = vecss->data.info.ref->u.ar.end[dim];
2218 desc = vecss->data.info.descriptor;
2222 /* The upper bound was specified. */
2223 gfc_init_se (&se, NULL);
2224 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2225 gfc_add_block_to_block (pblock, &se.pre);
2230 /* No upper bound was specified, so use the bound of the array. */
2231 bound = gfc_conv_array_ubound (desc, dim);
2238 /* Calculate the lower bound of an array section. */
2241 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2251 info = &ss->data.info;
2255 /* For vector array subscripts we want the size of the vector. */
2257 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2259 vecss = vecss->data.info.subscript[dim];
2260 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2261 /* Get the descriptors for the vector subscripts as well. */
2262 if (!vecss->data.info.descriptor)
2263 gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
2264 dim = vecss->data.info.dim[0];
2267 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2268 start = vecss->data.info.ref->u.ar.start[dim];
2269 stride = vecss->data.info.ref->u.ar.stride[dim];
2270 desc = vecss->data.info.descriptor;
2272 /* Calculate the start of the range. For vector subscripts this will
2273 be the range of the vector. */
2276 /* Specified section start. */
2277 gfc_init_se (&se, NULL);
2278 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2279 gfc_add_block_to_block (&loop->pre, &se.pre);
2280 info->start[n] = se.expr;
2284 /* No lower bound specified so use the bound of the array. */
2285 info->start[n] = gfc_conv_array_lbound (desc, dim);
2287 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2289 /* Calculate the stride. */
2291 info->stride[n] = gfc_index_one_node;
2294 gfc_init_se (&se, NULL);
2295 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2296 gfc_add_block_to_block (&loop->pre, &se.pre);
2297 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2302 /* Calculates the range start and stride for a SS chain. Also gets the
2303 descriptor and data pointer. The range of vector subscripts is the size
2304 of the vector. Array bounds are also checked. */
2307 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2316 /* Determine the rank of the loop. */
2318 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2322 case GFC_SS_SECTION:
2323 case GFC_SS_CONSTRUCTOR:
2324 case GFC_SS_FUNCTION:
2325 case GFC_SS_COMPONENT:
2326 loop->dimen = ss->data.info.dimen;
2334 if (loop->dimen == 0)
2335 gfc_todo_error ("Unable to determine rank of expression");
2338 /* Loop over all the SS in the chain. */
2339 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2341 if (ss->expr && ss->expr->shape && !ss->shape)
2342 ss->shape = ss->expr->shape;
2346 case GFC_SS_SECTION:
2347 /* Get the descriptor for the array. */
2348 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2350 for (n = 0; n < ss->data.info.dimen; n++)
2351 gfc_conv_section_startstride (loop, ss, n);
2354 case GFC_SS_CONSTRUCTOR:
2355 case GFC_SS_FUNCTION:
2356 for (n = 0; n < ss->data.info.dimen; n++)
2358 ss->data.info.start[n] = gfc_index_zero_node;
2359 ss->data.info.stride[n] = gfc_index_one_node;
2368 /* The rest is just runtime bound checking. */
2369 if (flag_bounds_check)
2375 tree size[GFC_MAX_DIMENSIONS];
2379 gfc_start_block (&block);
2381 fault = integer_zero_node;
2382 for (n = 0; n < loop->dimen; n++)
2383 size[n] = NULL_TREE;
2385 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2387 if (ss->type != GFC_SS_SECTION)
2390 /* TODO: range checking for mapped dimensions. */
2391 info = &ss->data.info;
2393 /* This only checks scalarized dimensions, elemental dimensions are
2395 for (n = 0; n < loop->dimen; n++)
2399 while (vecss->data.info.ref->u.ar.dimen_type[dim]
2402 vecss = vecss->data.info.subscript[dim];
2403 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2404 dim = vecss->data.info.dim[0];
2406 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
2408 desc = vecss->data.info.descriptor;
2410 /* Check lower bound. */
2411 bound = gfc_conv_array_lbound (desc, dim);
2412 tmp = info->start[n];
2413 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2414 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2417 /* Check the upper bound. */
2418 bound = gfc_conv_array_ubound (desc, dim);
2419 end = gfc_conv_section_upper_bound (ss, n, &block);
2420 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2421 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2424 /* Check the section sizes match. */
2425 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2427 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2429 /* We remember the size of the first section, and check all the
2430 others against this. */
2434 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2436 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2439 size[n] = gfc_evaluate_now (tmp, &block);
2442 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2444 tmp = gfc_finish_block (&block);
2445 gfc_add_expr_to_block (&loop->pre, tmp);
2450 /* Return true if the two SS could be aliased, i.e. both point to the same data
2452 /* TODO: resolve aliases based on frontend expressions. */
2455 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2462 lsym = lss->expr->symtree->n.sym;
2463 rsym = rss->expr->symtree->n.sym;
2464 if (gfc_symbols_could_alias (lsym, rsym))
2467 if (rsym->ts.type != BT_DERIVED
2468 && lsym->ts.type != BT_DERIVED)
2471 /* For derived types we must check all the component types. We can ignore
2472 array references as these will have the same base type as the previous
2474 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2476 if (lref->type != REF_COMPONENT)
2479 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2482 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2485 if (rref->type != REF_COMPONENT)
2488 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2493 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2495 if (rref->type != REF_COMPONENT)
2498 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2506 /* Resolve array data dependencies. Creates a temporary if required. */
2507 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2511 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2521 loop->temp_ss = NULL;
2522 aref = dest->data.info.ref;
2525 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2527 if (ss->type != GFC_SS_SECTION)
2530 if (gfc_could_be_alias (dest, ss))
2536 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2538 lref = dest->expr->ref;
2539 rref = ss->expr->ref;
2541 nDepend = gfc_dep_resolver (lref, rref);
2543 /* TODO : loop shifting. */
2546 /* Mark the dimensions for LOOP SHIFTING */
2547 for (n = 0; n < loop->dimen; n++)
2549 int dim = dest->data.info.dim[n];
2551 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2553 else if (! gfc_is_same_range (&lref->u.ar,
2554 &rref->u.ar, dim, 0))
2558 /* Put all the dimensions with dependencies in the
2561 for (n = 0; n < loop->dimen; n++)
2563 gcc_assert (loop->order[n] == n);
2565 loop->order[dim++] = n;
2568 for (n = 0; n < loop->dimen; n++)
2571 loop->order[dim++] = n;
2574 gcc_assert (dim == loop->dimen);
2583 loop->temp_ss = gfc_get_ss ();
2584 loop->temp_ss->type = GFC_SS_TEMP;
2585 loop->temp_ss->data.temp.type =
2586 gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
2587 loop->temp_ss->string_length = dest->string_length;
2588 loop->temp_ss->data.temp.dimen = loop->dimen;
2589 loop->temp_ss->next = gfc_ss_terminator;
2590 gfc_add_ss_to_loop (loop, loop->temp_ss);
2593 loop->temp_ss = NULL;
2597 /* Initialize the scalarization loop. Creates the loop variables. Determines
2598 the range of the loop variables. Creates a temporary if required.
2599 Calculates how to transform from loop variables to array indices for each
2600 expression. Also generates code for scalar expressions which have been
2601 moved outside the loop. */
2604 gfc_conv_loop_setup (gfc_loopinfo * loop)
2609 gfc_ss_info *specinfo;
2613 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2614 bool dynamic[GFC_MAX_DIMENSIONS];
2620 for (n = 0; n < loop->dimen; n++)
2624 /* We use one SS term, and use that to determine the bounds of the
2625 loop for this dimension. We try to pick the simplest term. */
2626 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2630 /* The frontend has worked out the size for us. */
2635 if (ss->type == GFC_SS_CONSTRUCTOR)
2637 /* An unknown size constructor will always be rank one.
2638 Higher rank constructors will either have known shape,
2639 or still be wrapped in a call to reshape. */
2640 gcc_assert (loop->dimen == 1);
2642 /* Always prefer to use the constructor bounds if the size
2643 can be determined at compile time. Prefer not to otherwise,
2644 since the general case involves realloc, and it's better to
2645 avoid that overhead if possible. */
2646 c = ss->expr->value.constructor;
2647 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2648 if (!dynamic[n] || !loopspec[n])
2653 /* TODO: Pick the best bound if we have a choice between a
2654 function and something else. */
2655 if (ss->type == GFC_SS_FUNCTION)
2661 if (ss->type != GFC_SS_SECTION)
2665 specinfo = &loopspec[n]->data.info;
2668 info = &ss->data.info;
2672 /* Criteria for choosing a loop specifier (most important first):
2673 doesn't need realloc
2679 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2681 else if (integer_onep (info->stride[n])
2682 && !integer_onep (specinfo->stride[n]))
2684 else if (INTEGER_CST_P (info->stride[n])
2685 && !INTEGER_CST_P (specinfo->stride[n]))
2687 else if (INTEGER_CST_P (info->start[n])
2688 && !INTEGER_CST_P (specinfo->start[n]))
2690 /* We don't work out the upper bound.
2691 else if (INTEGER_CST_P (info->finish[n])
2692 && ! INTEGER_CST_P (specinfo->finish[n]))
2693 loopspec[n] = ss; */
2697 gfc_todo_error ("Unable to find scalarization loop specifier");
2699 info = &loopspec[n]->data.info;
2701 /* Set the extents of this range. */
2702 cshape = loopspec[n]->shape;
2703 if (cshape && INTEGER_CST_P (info->start[n])
2704 && INTEGER_CST_P (info->stride[n]))
2706 loop->from[n] = info->start[n];
2707 mpz_set (i, cshape[n]);
2708 mpz_sub_ui (i, i, 1);
2709 /* To = from + (size - 1) * stride. */
2710 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2711 if (!integer_onep (info->stride[n]))
2712 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2713 tmp, info->stride[n]);
2714 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2715 loop->from[n], tmp);
2719 loop->from[n] = info->start[n];
2720 switch (loopspec[n]->type)
2722 case GFC_SS_CONSTRUCTOR:
2723 /* The upper bound is calculated when we expand the
2725 gcc_assert (loop->to[n] == NULL_TREE);
2728 case GFC_SS_SECTION:
2729 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2733 case GFC_SS_FUNCTION:
2734 /* The loop bound will be set when we generate the call. */
2735 gcc_assert (loop->to[n] == NULL_TREE);
2743 /* Transform everything so we have a simple incrementing variable. */
2744 if (integer_onep (info->stride[n]))
2745 info->delta[n] = gfc_index_zero_node;
2748 /* Set the delta for this section. */
2749 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2750 /* Number of iterations is (end - start + step) / step.
2751 with start = 0, this simplifies to
2753 for (i = 0; i<=last; i++){...}; */
2754 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2755 loop->to[n], loop->from[n]);
2756 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2757 tmp, info->stride[n]);
2758 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2759 /* Make the loop variable start at 0. */
2760 loop->from[n] = gfc_index_zero_node;
2764 /* Add all the scalar code that can be taken out of the loops.
2765 This may include calculating the loop bounds, so do it before
2766 allocating the temporary. */
2767 gfc_add_loop_ss_code (loop, loop->ss, false);
2769 /* If we want a temporary then create it. */
2770 if (loop->temp_ss != NULL)
2772 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2773 tmp = loop->temp_ss->data.temp.type;
2774 len = loop->temp_ss->string_length;
2775 n = loop->temp_ss->data.temp.dimen;
2776 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2777 loop->temp_ss->type = GFC_SS_SECTION;
2778 loop->temp_ss->data.info.dimen = n;
2779 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
2780 &loop->temp_ss->data.info, tmp, false);
2783 for (n = 0; n < loop->temp_dim; n++)
2784 loopspec[loop->order[n]] = NULL;
2788 /* For array parameters we don't have loop variables, so don't calculate the
2790 if (loop->array_parameter)
2793 /* Calculate the translation from loop variables to array indices. */
2794 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2796 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2799 info = &ss->data.info;
2801 for (n = 0; n < info->dimen; n++)
2805 /* If we are specifying the range the delta is already set. */
2806 if (loopspec[n] != ss)
2808 /* Calculate the offset relative to the loop variable.
2809 First multiply by the stride. */
2810 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2811 loop->from[n], info->stride[n]);
2813 /* Then subtract this from our starting value. */
2814 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2815 info->start[n], tmp);
2817 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2824 /* Fills in an array descriptor, and returns the size of the array. The size
2825 will be a simple_val, ie a variable or a constant. Also calculates the
2826 offset of the base. Returns the size of the array.
2830 for (n = 0; n < rank; n++)
2832 a.lbound[n] = specified_lower_bound;
2833 offset = offset + a.lbond[n] * stride;
2835 a.ubound[n] = specified_upper_bound;
2836 a.stride[n] = stride;
2837 size = ubound + size; //size = ubound + 1 - lbound
2838 stride = stride * size;
2845 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2846 gfc_expr ** lower, gfc_expr ** upper,
2847 stmtblock_t * pblock)
2858 type = TREE_TYPE (descriptor);
2860 stride = gfc_index_one_node;
2861 offset = gfc_index_zero_node;
2863 /* Set the dtype. */
2864 tmp = gfc_conv_descriptor_dtype (descriptor);
2865 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2867 for (n = 0; n < rank; n++)
2869 /* We have 3 possibilities for determining the size of the array:
2870 lower == NULL => lbound = 1, ubound = upper[n]
2871 upper[n] = NULL => lbound = 1, ubound = lower[n]
2872 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2875 /* Set lower bound. */
2876 gfc_init_se (&se, NULL);
2878 se.expr = gfc_index_one_node;
2881 gcc_assert (lower[n]);
2884 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2885 gfc_add_block_to_block (pblock, &se.pre);
2889 se.expr = gfc_index_one_node;
2893 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2894 gfc_add_modify_expr (pblock, tmp, se.expr);
2896 /* Work out the offset for this component. */
2897 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2898 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2900 /* Start the calculation for the size of this dimension. */
2901 size = build2 (MINUS_EXPR, gfc_array_index_type,
2902 gfc_index_one_node, se.expr);
2904 /* Set upper bound. */
2905 gfc_init_se (&se, NULL);
2906 gcc_assert (ubound);
2907 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2908 gfc_add_block_to_block (pblock, &se.pre);
2910 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2911 gfc_add_modify_expr (pblock, tmp, se.expr);
2913 /* Store the stride. */
2914 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2915 gfc_add_modify_expr (pblock, tmp, stride);
2917 /* Calculate the size of this dimension. */
2918 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2920 /* Multiply the stride by the number of elements in this dimension. */
2921 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2922 stride = gfc_evaluate_now (stride, pblock);
2925 /* The stride is the number of elements in the array, so multiply by the
2926 size of an element to get the total size. */
2927 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2928 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2930 if (poffset != NULL)
2932 offset = gfc_evaluate_now (offset, pblock);
2936 size = gfc_evaluate_now (size, pblock);
2941 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2942 the work for an ALLOCATE statement. */
2946 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2956 /* Figure out the size of the array. */
2957 switch (ref->u.ar.type)
2961 upper = ref->u.ar.start;
2965 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2967 lower = ref->u.ar.as->lower;
2968 upper = ref->u.ar.as->upper;
2972 lower = ref->u.ar.start;
2973 upper = ref->u.ar.end;
2981 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2982 lower, upper, &se->pre);
2984 /* Allocate memory to store the data. */
2985 tmp = gfc_conv_descriptor_data_addr (se->expr);
2986 pointer = gfc_evaluate_now (tmp, &se->pre);
2988 if (TYPE_PRECISION (gfc_array_index_type) == 32)
2989 allocate = gfor_fndecl_allocate;
2990 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2991 allocate = gfor_fndecl_allocate64;
2995 tmp = gfc_chainon_list (NULL_TREE, pointer);
2996 tmp = gfc_chainon_list (tmp, size);
2997 tmp = gfc_chainon_list (tmp, pstat);
2998 tmp = gfc_build_function_call (allocate, tmp);
2999 gfc_add_expr_to_block (&se->pre, tmp);
3001 tmp = gfc_conv_descriptor_offset (se->expr);
3002 gfc_add_modify_expr (&se->pre, tmp, offset);
3006 /* Deallocate an array variable. Also used when an allocated variable goes
3011 gfc_array_deallocate (tree descriptor, tree pstat)
3017 gfc_start_block (&block);
3018 /* Get a pointer to the data. */
3019 tmp = gfc_conv_descriptor_data_addr (descriptor);
3020 var = gfc_evaluate_now (tmp, &block);
3022 /* Parameter is the address of the data component. */
3023 tmp = gfc_chainon_list (NULL_TREE, var);
3024 tmp = gfc_chainon_list (tmp, pstat);
3025 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3026 gfc_add_expr_to_block (&block, tmp);
3028 return gfc_finish_block (&block);
3032 /* Create an array constructor from an initialization expression.
3033 We assume the frontend already did any expansions and conversions. */
3036 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3043 unsigned HOST_WIDE_INT lo;
3045 VEC(constructor_elt,gc) *v = NULL;
3047 switch (expr->expr_type)
3050 case EXPR_STRUCTURE:
3051 /* A single scalar or derived type value. Create an array with all
3052 elements equal to that value. */
3053 gfc_init_se (&se, NULL);
3055 if (expr->expr_type == EXPR_CONSTANT)
3056 gfc_conv_constant (&se, expr);
3058 gfc_conv_structure (&se, expr, 1);
3060 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3061 gcc_assert (tmp && INTEGER_CST_P (tmp));
3062 hi = TREE_INT_CST_HIGH (tmp);
3063 lo = TREE_INT_CST_LOW (tmp);
3067 /* This will probably eat buckets of memory for large arrays. */
3068 while (hi != 0 || lo != 0)
3070 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3078 /* Create a vector of all the elements. */
3079 for (c = expr->value.constructor; c; c = c->next)
3083 /* Problems occur when we get something like
3084 integer :: a(lots) = (/(i, i=1,lots)/) */
3085 /* TODO: Unexpanded array initializers. */
3087 ("Possible frontend bug: array constructor not expanded");
3089 if (mpz_cmp_si (c->n.offset, 0) != 0)
3090 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3094 if (mpz_cmp_si (c->repeat, 0) != 0)
3098 mpz_set (maxval, c->repeat);
3099 mpz_add (maxval, c->n.offset, maxval);
3100 mpz_sub_ui (maxval, maxval, 1);
3101 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3102 if (mpz_cmp_si (c->n.offset, 0) != 0)
3104 mpz_add_ui (maxval, c->n.offset, 1);
3105 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3108 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3110 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3116 gfc_init_se (&se, NULL);
3117 switch (c->expr->expr_type)
3120 gfc_conv_constant (&se, c->expr);
3121 if (range == NULL_TREE)
3122 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3125 if (index != NULL_TREE)
3126 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3127 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3131 case EXPR_STRUCTURE:
3132 gfc_conv_structure (&se, c->expr, 1);
3133 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3146 /* Create a constructor from the list of elements. */
3147 tmp = build_constructor (type, v);
3148 TREE_CONSTANT (tmp) = 1;
3149 TREE_INVARIANT (tmp) = 1;
3154 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3155 returns the size (in elements) of the array. */
3158 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3159 stmtblock_t * pblock)
3174 size = gfc_index_one_node;
3175 offset = gfc_index_zero_node;
3176 for (dim = 0; dim < as->rank; dim++)
3178 /* Evaluate non-constant array bound expressions. */
3179 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3180 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3182 gfc_init_se (&se, NULL);
3183 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3184 gfc_add_block_to_block (pblock, &se.pre);
3185 gfc_add_modify_expr (pblock, lbound, se.expr);
3187 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3188 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3190 gfc_init_se (&se, NULL);
3191 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3192 gfc_add_block_to_block (pblock, &se.pre);
3193 gfc_add_modify_expr (pblock, ubound, se.expr);
3195 /* The offset of this dimension. offset = offset - lbound * stride. */
3196 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3197 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3199 /* The size of this dimension, and the stride of the next. */
3200 if (dim + 1 < as->rank)
3201 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3205 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3207 /* Calculate stride = size * (ubound + 1 - lbound). */
3208 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3209 gfc_index_one_node, lbound);
3210 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3211 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3213 gfc_add_modify_expr (pblock, stride, tmp);
3215 stride = gfc_evaluate_now (tmp, pblock);
3226 /* Generate code to initialize/allocate an array variable. */
3229 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3239 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3241 /* Do nothing for USEd variables. */
3242 if (sym->attr.use_assoc)
3245 type = TREE_TYPE (decl);
3246 gcc_assert (GFC_ARRAY_TYPE_P (type));
3247 onstack = TREE_CODE (type) != POINTER_TYPE;
3249 gfc_start_block (&block);
3251 /* Evaluate character string length. */
3252 if (sym->ts.type == BT_CHARACTER
3253 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3255 gfc_trans_init_string_length (sym->ts.cl, &block);
3257 /* Emit a DECL_EXPR for this variable, which will cause the
3258 gimplifier to allocate storage, and all that good stuff. */
3259 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3260 gfc_add_expr_to_block (&block, tmp);
3265 gfc_add_expr_to_block (&block, fnbody);
3266 return gfc_finish_block (&block);
3269 type = TREE_TYPE (type);
3271 gcc_assert (!sym->attr.use_assoc);
3272 gcc_assert (!TREE_STATIC (decl));
3273 gcc_assert (!sym->module);
3275 if (sym->ts.type == BT_CHARACTER
3276 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3277 gfc_trans_init_string_length (sym->ts.cl, &block);
3279 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3281 /* The size is the number of elements in the array, so multiply by the
3282 size of an element to get the total size. */
3283 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3284 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3286 /* Allocate memory to hold the data. */
3287 tmp = gfc_chainon_list (NULL_TREE, size);
3289 if (gfc_index_integer_kind == 4)
3290 fndecl = gfor_fndecl_internal_malloc;
3291 else if (gfc_index_integer_kind == 8)
3292 fndecl = gfor_fndecl_internal_malloc64;
3295 tmp = gfc_build_function_call (fndecl, tmp);
3296 tmp = fold (convert (TREE_TYPE (decl), tmp));
3297 gfc_add_modify_expr (&block, decl, tmp);
3299 /* Set offset of the array. */
3300 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3301 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3304 /* Automatic arrays should not have initializers. */
3305 gcc_assert (!sym->value);
3307 gfc_add_expr_to_block (&block, fnbody);
3309 /* Free the temporary. */
3310 tmp = convert (pvoid_type_node, decl);
3311 tmp = gfc_chainon_list (NULL_TREE, tmp);
3312 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3313 gfc_add_expr_to_block (&block, tmp);
3315 return gfc_finish_block (&block);
3319 /* Generate entry and exit code for g77 calling convention arrays. */
3322 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3331 gfc_get_backend_locus (&loc);
3332 gfc_set_backend_locus (&sym->declared_at);
3334 /* Descriptor type. */
3335 parm = sym->backend_decl;
3336 type = TREE_TYPE (parm);
3337 gcc_assert (GFC_ARRAY_TYPE_P (type));
3339 gfc_start_block (&block);
3341 if (sym->ts.type == BT_CHARACTER
3342 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3343 gfc_trans_init_string_length (sym->ts.cl, &block);
3345 /* Evaluate the bounds of the array. */
3346 gfc_trans_array_bounds (type, sym, &offset, &block);
3348 /* Set the offset. */
3349 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3350 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3352 /* Set the pointer itself if we aren't using the parameter directly. */
3353 if (TREE_CODE (parm) != PARM_DECL)
3355 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3356 gfc_add_modify_expr (&block, parm, tmp);
3358 tmp = gfc_finish_block (&block);
3360 gfc_set_backend_locus (&loc);
3362 gfc_start_block (&block);
3363 /* Add the initialization code to the start of the function. */
3364 gfc_add_expr_to_block (&block, tmp);
3365 gfc_add_expr_to_block (&block, body);
3367 return gfc_finish_block (&block);
3371 /* Modify the descriptor of an array parameter so that it has the
3372 correct lower bound. Also move the upper bound accordingly.
3373 If the array is not packed, it will be copied into a temporary.
3374 For each dimension we set the new lower and upper bounds. Then we copy the
3375 stride and calculate the offset for this dimension. We also work out
3376 what the stride of a packed array would be, and see it the two match.
3377 If the array need repacking, we set the stride to the values we just
3378 calculated, recalculate the offset and copy the array data.
3379 Code is also added to copy the data back at the end of the function.
3383 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3390 stmtblock_t cleanup;
3408 /* Do nothing for pointer and allocatable arrays. */
3409 if (sym->attr.pointer || sym->attr.allocatable)
3412 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3413 return gfc_trans_g77_array (sym, body);
3415 gfc_get_backend_locus (&loc);
3416 gfc_set_backend_locus (&sym->declared_at);
3418 /* Descriptor type. */
3419 type = TREE_TYPE (tmpdesc);
3420 gcc_assert (GFC_ARRAY_TYPE_P (type));
3421 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3422 dumdesc = gfc_build_indirect_ref (dumdesc);
3423 gfc_start_block (&block);
3425 if (sym->ts.type == BT_CHARACTER
3426 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3427 gfc_trans_init_string_length (sym->ts.cl, &block);
3429 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3431 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3432 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3434 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3436 /* For non-constant shape arrays we only check if the first dimension
3437 is contiguous. Repacking higher dimensions wouldn't gain us
3438 anything as we still don't know the array stride. */
3439 partial = gfc_create_var (boolean_type_node, "partial");
3440 TREE_USED (partial) = 1;
3441 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3442 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3443 gfc_add_modify_expr (&block, partial, tmp);
3447 partial = NULL_TREE;
3450 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3451 here, however I think it does the right thing. */
3454 /* Set the first stride. */
3455 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3456 stride = gfc_evaluate_now (stride, &block);
3458 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3459 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3460 gfc_index_one_node, stride);
3461 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3462 gfc_add_modify_expr (&block, stride, tmp);
3464 /* Allow the user to disable array repacking. */
3465 stmt_unpacked = NULL_TREE;
3469 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3470 /* A library call to repack the array if necessary. */
3471 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3472 tmp = gfc_chainon_list (NULL_TREE, tmp);
3473 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3475 stride = gfc_index_one_node;
3478 /* This is for the case where the array data is used directly without
3479 calling the repack function. */
3480 if (no_repack || partial != NULL_TREE)
3481 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3483 stmt_packed = NULL_TREE;
3485 /* Assign the data pointer. */
3486 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3488 /* Don't repack unknown shape arrays when the first stride is 1. */
3489 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3490 stmt_packed, stmt_unpacked);
3493 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3494 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3496 offset = gfc_index_zero_node;
3497 size = gfc_index_one_node;
3499 /* Evaluate the bounds of the array. */
3500 for (n = 0; n < sym->as->rank; n++)
3502 if (checkparm || !sym->as->upper[n])
3504 /* Get the bounds of the actual parameter. */
3505 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3506 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3510 dubound = NULL_TREE;
3511 dlbound = NULL_TREE;
3514 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3515 if (!INTEGER_CST_P (lbound))
3517 gfc_init_se (&se, NULL);
3518 gfc_conv_expr_type (&se, sym->as->upper[n],
3519 gfc_array_index_type);
3520 gfc_add_block_to_block (&block, &se.pre);
3521 gfc_add_modify_expr (&block, lbound, se.expr);
3524 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3525 /* Set the desired upper bound. */
3526 if (sym->as->upper[n])
3528 /* We know what we want the upper bound to be. */
3529 if (!INTEGER_CST_P (ubound))
3531 gfc_init_se (&se, NULL);
3532 gfc_conv_expr_type (&se, sym->as->upper[n],
3533 gfc_array_index_type);
3534 gfc_add_block_to_block (&block, &se.pre);
3535 gfc_add_modify_expr (&block, ubound, se.expr);
3538 /* Check the sizes match. */
3541 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3543 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3545 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3547 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3548 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3553 /* For assumed shape arrays move the upper bound by the same amount
3554 as the lower bound. */
3555 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3556 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3557 gfc_add_modify_expr (&block, ubound, tmp);
3559 /* The offset of this dimension. offset = offset - lbound * stride. */
3560 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3561 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3563 /* The size of this dimension, and the stride of the next. */
3564 if (n + 1 < sym->as->rank)
3566 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3568 if (no_repack || partial != NULL_TREE)
3571 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3574 /* Figure out the stride if not a known constant. */
3575 if (!INTEGER_CST_P (stride))
3578 stmt_packed = NULL_TREE;
3581 /* Calculate stride = size * (ubound + 1 - lbound). */
3582 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3583 gfc_index_one_node, lbound);
3584 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3586 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3591 /* Assign the stride. */
3592 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3593 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3594 stmt_unpacked, stmt_packed);
3596 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3597 gfc_add_modify_expr (&block, stride, tmp);
3602 /* Set the offset. */
3603 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3604 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3606 stmt = gfc_finish_block (&block);
3608 gfc_start_block (&block);
3610 /* Only do the entry/initialization code if the arg is present. */
3611 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3612 optional_arg = (sym->attr.optional
3613 || (sym->ns->proc_name->attr.entry_master
3614 && sym->attr.dummy));
3617 tmp = gfc_conv_expr_present (sym);
3618 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3620 gfc_add_expr_to_block (&block, stmt);
3622 /* Add the main function body. */
3623 gfc_add_expr_to_block (&block, body);
3628 gfc_start_block (&cleanup);
3630 if (sym->attr.intent != INTENT_IN)
3632 /* Copy the data back. */
3633 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3634 tmp = gfc_chainon_list (tmp, tmpdesc);
3635 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3636 gfc_add_expr_to_block (&cleanup, tmp);
3639 /* Free the temporary. */
3640 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3641 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3642 gfc_add_expr_to_block (&cleanup, tmp);
3644 stmt = gfc_finish_block (&cleanup);
3646 /* Only do the cleanup if the array was repacked. */
3647 tmp = gfc_build_indirect_ref (dumdesc);
3648 tmp = gfc_conv_descriptor_data_get (tmp);
3649 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3650 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3654 tmp = gfc_conv_expr_present (sym);
3655 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3657 gfc_add_expr_to_block (&block, stmt);
3659 /* We don't need to free any memory allocated by internal_pack as it will
3660 be freed at the end of the function by pop_context. */
3661 return gfc_finish_block (&block);
3665 /* Convert an array for passing as an actual parameter. Expressions and
3666 vector subscripts are evaluated and stored in a temporary, which is then
3667 passed. For whole arrays the descriptor is passed. For array sections
3668 a modified copy of the descriptor is passed, but using the original data.
3669 Also used for array pointer assignments by setting se->direct_byref. */
3672 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3688 gcc_assert (ss != gfc_ss_terminator);
3690 /* TODO: Pass constant array constructors without a temporary. */
3691 /* Special case things we know we can pass easily. */
3692 switch (expr->expr_type)
3695 /* If we have a linear array section, we can pass it directly.
3696 Otherwise we need to copy it into a temporary. */
3698 /* Find the SS for the array section. */
3700 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3701 secss = secss->next;
3703 gcc_assert (secss != gfc_ss_terminator);
3706 for (n = 0; n < secss->data.info.dimen; n++)
3708 vss = secss->data.info.subscript[secss->data.info.dim[n]];
3709 if (vss && vss->type == GFC_SS_VECTOR)
3713 info = &secss->data.info;
3715 /* Get the descriptor for the array. */
3716 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3717 desc = info->descriptor;
3718 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3720 /* Create a new descriptor if the array doesn't have one. */
3723 else if (info->ref->u.ar.type == AR_FULL)
3725 else if (se->direct_byref)
3730 gcc_assert (ref->u.ar.type == AR_SECTION);
3733 for (n = 0; n < ref->u.ar.dimen; n++)
3735 /* Detect passing the full array as a section. This could do
3736 even more checking, but it doesn't seem worth it. */
3737 if (ref->u.ar.start[n]
3739 || (ref->u.ar.stride[n]
3740 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3748 /* Check for substring references. */
3750 if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
3754 if (ref->type == REF_SUBSTRING)
3756 /* In general character substrings need a copy. Character
3757 array strides are expressed as multiples of the element
3758 size (consistent with other array types), not in
3767 if (se->direct_byref)
3769 /* Copy the descriptor for pointer assignments. */
3770 gfc_add_modify_expr (&se->pre, se->expr, desc);
3772 else if (se->want_pointer)
3774 /* We pass full arrays directly. This means that pointers and
3775 allocatable arrays should also work. */
3776 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3783 if (expr->ts.type == BT_CHARACTER)
3784 se->string_length = gfc_get_expr_charlen (expr);
3791 /* A transformational function return value will be a temporary
3792 array descriptor. We still need to go through the scalarizer
3793 to create the descriptor. Elemental functions ar handled as
3794 arbitrary expressions, i.e. copy to a temporary. */
3796 /* Look for the SS for this function. */
3797 while (secss != gfc_ss_terminator
3798 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3799 secss = secss->next;
3801 if (se->direct_byref)
3803 gcc_assert (secss != gfc_ss_terminator);
3805 /* For pointer assignments pass the descriptor directly. */
3807 se->expr = gfc_build_addr_expr (NULL, se->expr);
3808 gfc_conv_expr (se, expr);
3812 if (secss == gfc_ss_terminator)
3814 /* Elemental function. */
3820 /* Transformational function. */
3821 info = &secss->data.info;
3827 /* Something complicated. Copy it into a temporary. */
3835 gfc_init_loopinfo (&loop);
3837 /* Associate the SS with the loop. */
3838 gfc_add_ss_to_loop (&loop, ss);
3840 /* Tell the scalarizer not to bother creating loop variables, etc. */
3842 loop.array_parameter = 1;
3844 gcc_assert (se->want_pointer && !se->direct_byref);
3846 /* Setup the scalarizing loops and bounds. */
3847 gfc_conv_ss_startstride (&loop);
3851 /* Tell the scalarizer to make a temporary. */
3852 loop.temp_ss = gfc_get_ss ();
3853 loop.temp_ss->type = GFC_SS_TEMP;
3854 loop.temp_ss->next = gfc_ss_terminator;
3855 if (expr->ts.type == BT_CHARACTER)
3857 gcc_assert (expr->ts.cl && expr->ts.cl->length
3858 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3859 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3860 (expr->ts.cl->length->value.integer,
3861 expr->ts.cl->length->ts.kind);
3862 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3864 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3866 /* ... which can hold our string, if present. */
3867 if (expr->ts.type == BT_CHARACTER)
3869 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3870 se->string_length = loop.temp_ss->string_length;
3873 loop.temp_ss->string_length = NULL;
3874 loop.temp_ss->data.temp.dimen = loop.dimen;
3875 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3878 gfc_conv_loop_setup (&loop);
3882 /* Copy into a temporary and pass that. We don't need to copy the data
3883 back because expressions and vector subscripts must be INTENT_IN. */
3884 /* TODO: Optimize passing function return values. */
3888 /* Start the copying loops. */
3889 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3890 gfc_mark_ss_chain_used (ss, 1);
3891 gfc_start_scalarized_body (&loop, &block);
3893 /* Copy each data element. */
3894 gfc_init_se (&lse, NULL);
3895 gfc_copy_loopinfo_to_se (&lse, &loop);
3896 gfc_init_se (&rse, NULL);
3897 gfc_copy_loopinfo_to_se (&rse, &loop);
3899 lse.ss = loop.temp_ss;
3902 gfc_conv_scalarized_array_ref (&lse, NULL);
3903 if (expr->ts.type == BT_CHARACTER)
3905 gfc_conv_expr (&rse, expr);
3906 rse.expr = gfc_build_indirect_ref (rse.expr);
3909 gfc_conv_expr_val (&rse, expr);
3911 gfc_add_block_to_block (&block, &rse.pre);
3912 gfc_add_block_to_block (&block, &lse.pre);
3914 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3916 /* Finish the copying loops. */
3917 gfc_trans_scalarizing_loops (&loop, &block);
3919 /* Set the first stride component to zero to indicate a temporary. */
3920 desc = loop.temp_ss->data.info.descriptor;
3921 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3922 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3924 gcc_assert (is_gimple_lvalue (desc));
3925 se->expr = gfc_build_addr_expr (NULL, desc);
3927 else if (expr->expr_type == EXPR_FUNCTION)
3929 desc = info->descriptor;
3931 if (se->want_pointer)
3932 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3936 if (expr->ts.type == BT_CHARACTER)
3937 se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
3941 /* We pass sections without copying to a temporary. Make a new
3942 descriptor and point it at the section we want. The loop variable
3943 limits will be the limits of the section.
3944 A function may decide to repack the array to speed up access, but
3945 we're not bothered about that here. */
3954 /* Set the string_length for a character array. */
3955 if (expr->ts.type == BT_CHARACTER)
3956 se->string_length = gfc_get_expr_charlen (expr);
3958 desc = info->descriptor;
3959 gcc_assert (secss && secss != gfc_ss_terminator);
3960 if (se->direct_byref)
3962 /* For pointer assignments we fill in the destination. */
3964 parmtype = TREE_TYPE (parm);
3968 /* Otherwise make a new one. */
3969 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3970 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3971 loop.from, loop.to, 0);
3972 parm = gfc_create_var (parmtype, "parm");
3975 offset = gfc_index_zero_node;
3978 /* The following can be somewhat confusing. We have two
3979 descriptors, a new one and the original array.
3980 {parm, parmtype, dim} refer to the new one.
3981 {desc, type, n, secss, loop} refer to the original, which maybe
3982 a descriptorless array.
3983 The bounds of the scalarization are the bounds of the section.
3984 We don't have to worry about numeric overflows when calculating
3985 the offsets because all elements are within the array data. */
3987 /* Set the dtype. */
3988 tmp = gfc_conv_descriptor_dtype (parm);
3989 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
3991 if (se->direct_byref)
3992 base = gfc_index_zero_node;
3996 for (n = 0; n < info->ref->u.ar.dimen; n++)
3998 stride = gfc_conv_array_stride (desc, n);
4000 /* Work out the offset. */
4001 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4003 gcc_assert (info->subscript[n]
4004 && info->subscript[n]->type == GFC_SS_SCALAR);
4005 start = info->subscript[n]->data.scalar.expr;
4009 /* Check we haven't somehow got out of sync. */
4010 gcc_assert (info->dim[dim] == n);
4012 /* Evaluate and remember the start of the section. */
4013 start = info->start[dim];
4014 stride = gfc_evaluate_now (stride, &loop.pre);
4017 tmp = gfc_conv_array_lbound (desc, n);
4018 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4020 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4021 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4023 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4025 /* For elemental dimensions, we only need the offset. */
4029 /* Vector subscripts need copying and are handled elsewhere. */
4030 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4032 /* Set the new lower bound. */
4033 from = loop.from[dim];
4035 if (!integer_onep (from))
4037 /* Make sure the new section starts at 1. */
4038 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4039 gfc_index_one_node, from);
4040 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4041 from = gfc_index_one_node;
4043 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4044 gfc_add_modify_expr (&loop.pre, tmp, from);
4046 /* Set the new upper bound. */
4047 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4048 gfc_add_modify_expr (&loop.pre, tmp, to);
4050 /* Multiply the stride by the section stride to get the
4052 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4053 stride, info->stride[dim]);
4055 if (se->direct_byref)
4056 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4059 /* Store the new stride. */
4060 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4061 gfc_add_modify_expr (&loop.pre, tmp, stride);
4066 /* Point the data pointer at the first element in the section. */
4067 tmp = gfc_conv_array_data (desc);
4068 tmp = gfc_build_indirect_ref (tmp);
4069 tmp = gfc_build_array_ref (tmp, offset);
4070 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4071 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4073 if (se->direct_byref)
4075 /* Set the offset. */
4076 tmp = gfc_conv_descriptor_offset (parm);
4077 gfc_add_modify_expr (&loop.pre, tmp, base);
4081 /* Only the callee knows what the correct offset it, so just set
4083 tmp = gfc_conv_descriptor_offset (parm);
4084 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4087 if (!se->direct_byref)
4089 /* Get a pointer to the new descriptor. */
4090 if (se->want_pointer)
4091 se->expr = gfc_build_addr_expr (NULL, parm);
4097 gfc_add_block_to_block (&se->pre, &loop.pre);
4098 gfc_add_block_to_block (&se->post, &loop.post);
4100 /* Cleanup the scalarizer. */
4101 gfc_cleanup_loop (&loop);
4105 /* Convert an array for passing as an actual parameter. */
4106 /* TODO: Optimize passing g77 arrays. */
4109 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4118 /* Passing address of the array if it is not pointer or assumed-shape. */
4119 if (expr->expr_type == EXPR_VARIABLE
4120 && expr->ref->u.ar.type == AR_FULL && g77)
4122 sym = expr->symtree->n.sym;
4123 tmp = gfc_get_symbol_decl (sym);
4124 if (sym->ts.type == BT_CHARACTER)
4125 se->string_length = sym->ts.cl->backend_decl;
4126 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4127 && !sym->attr.allocatable)
4129 /* Some variables are declared directly, others are declared as
4130 pointers and allocated on the heap. */
4131 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4134 se->expr = gfc_build_addr_expr (NULL, tmp);
4137 if (sym->attr.allocatable)
4139 se->expr = gfc_conv_array_data (tmp);
4144 se->want_pointer = 1;
4145 gfc_conv_expr_descriptor (se, expr, ss);
4150 /* Repack the array. */
4151 tmp = gfc_chainon_list (NULL_TREE, desc);
4152 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
4153 ptr = gfc_evaluate_now (ptr, &se->pre);
4156 gfc_start_block (&block);
4158 /* Copy the data back. */
4159 tmp = gfc_chainon_list (NULL_TREE, desc);
4160 tmp = gfc_chainon_list (tmp, ptr);
4161 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
4162 gfc_add_expr_to_block (&block, tmp);
4164 /* Free the temporary. */
4165 tmp = convert (pvoid_type_node, ptr);
4166 tmp = gfc_chainon_list (NULL_TREE, tmp);
4167 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
4168 gfc_add_expr_to_block (&block, tmp);
4170 stmt = gfc_finish_block (&block);
4172 gfc_init_block (&block);
4173 /* Only if it was repacked. This code needs to be executed before the
4174 loop cleanup code. */
4175 tmp = gfc_build_indirect_ref (desc);
4176 tmp = gfc_conv_array_data (tmp);
4177 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4178 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4180 gfc_add_expr_to_block (&block, tmp);
4181 gfc_add_block_to_block (&block, &se->post);
4183 gfc_init_block (&se->post);
4184 gfc_add_block_to_block (&se->post, &block);
4189 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4192 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4199 stmtblock_t fnblock;
4202 /* Make sure the frontend gets these right. */
4203 if (!(sym->attr.pointer || sym->attr.allocatable))
4205 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4207 gfc_init_block (&fnblock);
4209 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
4210 if (sym->ts.type == BT_CHARACTER
4211 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4212 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4214 /* Dummy and use associated variables don't need anything special. */
4215 if (sym->attr.dummy || sym->attr.use_assoc)
4217 gfc_add_expr_to_block (&fnblock, body);
4219 return gfc_finish_block (&fnblock);
4222 gfc_get_backend_locus (&loc);
4223 gfc_set_backend_locus (&sym->declared_at);
4224 descriptor = sym->backend_decl;
4226 if (TREE_STATIC (descriptor))
4228 /* SAVEd variables are not freed on exit. */
4229 gfc_trans_static_array_pointer (sym);
4233 /* Get the descriptor type. */
4234 type = TREE_TYPE (sym->backend_decl);
4235 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4237 /* NULLIFY the data pointer. */
4238 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4240 gfc_add_expr_to_block (&fnblock, body);
4242 gfc_set_backend_locus (&loc);
4243 /* Allocatable arrays need to be freed when they go out of scope. */
4244 if (sym->attr.allocatable)
4246 gfc_start_block (&block);
4248 /* Deallocate if still allocated at the end of the procedure. */
4249 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4251 tmp = gfc_conv_descriptor_data_get (descriptor);
4252 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4253 build_int_cst (TREE_TYPE (tmp), 0));
4254 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4255 gfc_add_expr_to_block (&block, tmp);
4257 tmp = gfc_finish_block (&block);
4258 gfc_add_expr_to_block (&fnblock, tmp);
4261 return gfc_finish_block (&fnblock);
4264 /************ Expression Walking Functions ******************/
4266 /* Walk a variable reference.
4268 Possible extension - multiple component subscripts.
4269 x(:,:) = foo%a(:)%b(:)
4271 forall (i=..., j=...)
4272 x(i,j) = foo%a(j)%b(i)
4274 This adds a fair amout of complexity because you need to deal with more
4275 than one ref. Maybe handle in a similar manner to vector subscripts.
4276 Maybe not worth the effort. */
4280 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4288 for (ref = expr->ref; ref; ref = ref->next)
4289 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4292 for (; ref; ref = ref->next)
4294 if (ref->type == REF_SUBSTRING)
4296 newss = gfc_get_ss ();
4297 newss->type = GFC_SS_SCALAR;
4298 newss->expr = ref->u.ss.start;
4302 newss = gfc_get_ss ();
4303 newss->type = GFC_SS_SCALAR;
4304 newss->expr = ref->u.ss.end;
4309 /* We're only interested in array sections from now on. */
4310 if (ref->type != REF_ARRAY)
4317 for (n = 0; n < ar->dimen; n++)
4319 newss = gfc_get_ss ();
4320 newss->type = GFC_SS_SCALAR;
4321 newss->expr = ar->start[n];
4328 newss = gfc_get_ss ();
4329 newss->type = GFC_SS_SECTION;
4332 newss->data.info.dimen = ar->as->rank;
4333 newss->data.info.ref = ref;
4335 /* Make sure array is the same as array(:,:), this way
4336 we don't need to special case all the time. */
4337 ar->dimen = ar->as->rank;
4338 for (n = 0; n < ar->dimen; n++)
4340 newss->data.info.dim[n] = n;
4341 ar->dimen_type[n] = DIMEN_RANGE;
4343 gcc_assert (ar->start[n] == NULL);
4344 gcc_assert (ar->end[n] == NULL);
4345 gcc_assert (ar->stride[n] == NULL);
4351 newss = gfc_get_ss ();
4352 newss->type = GFC_SS_SECTION;
4355 newss->data.info.dimen = 0;
4356 newss->data.info.ref = ref;
4360 /* We add SS chains for all the subscripts in the section. */
4361 for (n = 0; n < ar->dimen; n++)
4365 switch (ar->dimen_type[n])
4368 /* Add SS for elemental (scalar) subscripts. */
4369 gcc_assert (ar->start[n]);
4370 indexss = gfc_get_ss ();
4371 indexss->type = GFC_SS_SCALAR;
4372 indexss->expr = ar->start[n];
4373 indexss->next = gfc_ss_terminator;
4374 indexss->loop_chain = gfc_ss_terminator;
4375 newss->data.info.subscript[n] = indexss;
4379 /* We don't add anything for sections, just remember this
4380 dimension for later. */
4381 newss->data.info.dim[newss->data.info.dimen] = n;
4382 newss->data.info.dimen++;
4386 /* Get a SS for the vector. This will not be added to the
4388 indexss = gfc_walk_expr (ar->start[n]);
4389 if (indexss == gfc_ss_terminator)
4390 internal_error ("scalar vector subscript???");
4392 /* We currently only handle really simple vector
4394 if (indexss->next != gfc_ss_terminator)
4395 gfc_todo_error ("vector subscript expressions");
4396 indexss->loop_chain = gfc_ss_terminator;
4398 /* Mark this as a vector subscript. We don't add this
4399 directly into the chain, but as a subscript of the
4400 existing SS for this term. */
4401 indexss->type = GFC_SS_VECTOR;
4402 newss->data.info.subscript[n] = indexss;
4403 /* Also remember this dimension. */
4404 newss->data.info.dim[newss->data.info.dimen] = n;
4405 newss->data.info.dimen++;
4409 /* We should know what sort of section it is by now. */
4413 /* We should have at least one non-elemental dimension. */
4414 gcc_assert (newss->data.info.dimen > 0);
4419 /* We should know what sort of section it is by now. */
4428 /* Walk an expression operator. If only one operand of a binary expression is
4429 scalar, we must also add the scalar term to the SS chain. */
4432 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4438 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4439 if (expr->value.op.op2 == NULL)
4442 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4444 /* All operands are scalar. Pass back and let the caller deal with it. */
4448 /* All operands require scalarization. */
4449 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4452 /* One of the operands needs scalarization, the other is scalar.
4453 Create a gfc_ss for the scalar expression. */
4454 newss = gfc_get_ss ();
4455 newss->type = GFC_SS_SCALAR;
4458 /* First operand is scalar. We build the chain in reverse order, so
4459 add the scarar SS after the second operand. */
4461 while (head && head->next != ss)
4463 /* Check we haven't somehow broken the chain. */
4467 newss->expr = expr->value.op.op1;
4469 else /* head2 == head */
4471 gcc_assert (head2 == head);
4472 /* Second operand is scalar. */
4473 newss->next = head2;
4475 newss->expr = expr->value.op.op2;
4482 /* Reverse a SS chain. */
4485 gfc_reverse_ss (gfc_ss * ss)
4490 gcc_assert (ss != NULL);
4492 head = gfc_ss_terminator;
4493 while (ss != gfc_ss_terminator)
4496 /* Check we didn't somehow break the chain. */
4497 gcc_assert (next != NULL);
4507 /* Walk the arguments of an elemental function. */
4510 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4513 gfc_actual_arglist *arg;
4519 head = gfc_ss_terminator;
4522 for (arg = expr->value.function.actual; arg; arg = arg->next)
4527 newss = gfc_walk_subexpr (head, arg->expr);
4530 /* Scalar argument. */
4531 newss = gfc_get_ss ();
4533 newss->expr = arg->expr;
4543 while (tail->next != gfc_ss_terminator)
4550 /* If all the arguments are scalar we don't need the argument SS. */
4551 gfc_free_ss_chain (head);
4556 /* Add it onto the existing chain. */
4562 /* Walk a function call. Scalar functions are passed back, and taken out of
4563 scalarization loops. For elemental functions we walk their arguments.
4564 The result of functions returning arrays is stored in a temporary outside
4565 the loop, so that the function is only called once. Hence we do not need
4566 to walk their arguments. */
4569 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4572 gfc_intrinsic_sym *isym;
4575 isym = expr->value.function.isym;
4577 /* Handle intrinsic functions separately. */
4579 return gfc_walk_intrinsic_function (ss, expr, isym);
4581 sym = expr->value.function.esym;
4583 sym = expr->symtree->n.sym;
4585 /* A function that returns arrays. */
4586 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4588 newss = gfc_get_ss ();
4589 newss->type = GFC_SS_FUNCTION;
4592 newss->data.info.dimen = expr->rank;
4596 /* Walk the parameters of an elemental function. For now we always pass
4598 if (sym->attr.elemental)
4599 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4601 /* Scalar functions are OK as these are evaluated outside the scalarization
4602 loop. Pass back and let the caller deal with it. */
4607 /* An array temporary is constructed for array constructors. */
4610 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4615 newss = gfc_get_ss ();
4616 newss->type = GFC_SS_CONSTRUCTOR;
4619 newss->data.info.dimen = expr->rank;
4620 for (n = 0; n < expr->rank; n++)
4621 newss->data.info.dim[n] = n;
4627 /* Walk an expression. Add walked expressions to the head of the SS chain.
4628 A wholly scalar expression will not be added. */
4631 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4635 switch (expr->expr_type)
4638 head = gfc_walk_variable_expr (ss, expr);
4642 head = gfc_walk_op_expr (ss, expr);
4646 head = gfc_walk_function_expr (ss, expr);
4651 case EXPR_STRUCTURE:
4652 /* Pass back and let the caller deal with it. */
4656 head = gfc_walk_array_constructor (ss, expr);
4659 case EXPR_SUBSTRING:
4660 /* Pass back and let the caller deal with it. */
4664 internal_error ("bad expression type during walk (%d)",
4671 /* Entry point for expression walking.
4672 A return value equal to the passed chain means this is
4673 a scalar expression. It is up to the caller to take whatever action is
4674 necessary to translate these. */
4677 gfc_walk_expr (gfc_expr * expr)
4681 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4682 return gfc_reverse_ss (res);