1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field. */
161 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
165 type = TREE_TYPE (desc);
166 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
168 field = TYPE_FIELDS (type);
169 gcc_assert (DATA_FIELD == 0);
171 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
172 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
176 /* This provides address access to the data field. This should only be
177 used by array allocation, passing this on to the runtime. */
180 gfc_conv_descriptor_data_addr (tree desc)
184 type = TREE_TYPE (desc);
185 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
187 field = TYPE_FIELDS (type);
188 gcc_assert (DATA_FIELD == 0);
190 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
191 return gfc_build_addr_expr (NULL, t);
195 gfc_conv_descriptor_offset (tree desc)
200 type = TREE_TYPE (desc);
201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
203 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
204 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
206 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
210 gfc_conv_descriptor_dtype (tree desc)
215 type = TREE_TYPE (desc);
216 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
218 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
219 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
221 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
225 gfc_conv_descriptor_dimension (tree desc, tree dim)
231 type = TREE_TYPE (desc);
232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
234 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
235 gcc_assert (field != NULL_TREE
236 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
237 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
239 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
240 tmp = gfc_build_array_ref (tmp, dim);
245 gfc_conv_descriptor_stride (tree desc, tree dim)
250 tmp = gfc_conv_descriptor_dimension (desc, dim);
251 field = TYPE_FIELDS (TREE_TYPE (tmp));
252 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
253 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
255 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
260 gfc_conv_descriptor_lbound (tree desc, tree dim)
265 tmp = gfc_conv_descriptor_dimension (desc, dim);
266 field = TYPE_FIELDS (TREE_TYPE (tmp));
267 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
268 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
270 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
275 gfc_conv_descriptor_ubound (tree desc, tree dim)
280 tmp = gfc_conv_descriptor_dimension (desc, dim);
281 field = TYPE_FIELDS (TREE_TYPE (tmp));
282 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
285 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
290 /* Build a null array descriptor constructor. */
293 gfc_build_null_descriptor (tree type)
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
299 gcc_assert (DATA_FIELD == 0);
300 field = TYPE_FIELDS (type);
302 /* Set a NULL data pointer. */
303 tmp = build_constructor_single (type, field, null_pointer_node);
304 TREE_CONSTANT (tmp) = 1;
305 TREE_INVARIANT (tmp) = 1;
306 /* All other fields are ignored. */
312 /* Cleanup those #defines. */
317 #undef DIMENSION_FIELD
318 #undef STRIDE_SUBFIELD
319 #undef LBOUND_SUBFIELD
320 #undef UBOUND_SUBFIELD
323 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
324 flags & 1 = Main loop body.
325 flags & 2 = temp copy loop. */
328 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
330 for (; ss != gfc_ss_terminator; ss = ss->next)
331 ss->useflags = flags;
334 static void gfc_free_ss (gfc_ss *);
337 /* Free a gfc_ss chain. */
340 gfc_free_ss_chain (gfc_ss * ss)
344 while (ss != gfc_ss_terminator)
346 gcc_assert (ss != NULL);
357 gfc_free_ss (gfc_ss * ss)
364 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
366 if (ss->data.info.subscript[n])
367 gfc_free_ss_chain (ss->data.info.subscript[n]);
379 /* Free all the SS associated with a loop. */
382 gfc_cleanup_loop (gfc_loopinfo * loop)
388 while (ss != gfc_ss_terminator)
390 gcc_assert (ss != NULL);
391 next = ss->loop_chain;
398 /* Associate a SS chain with a loop. */
401 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
405 if (head == gfc_ss_terminator)
409 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
411 if (ss->next == gfc_ss_terminator)
412 ss->loop_chain = loop->ss;
414 ss->loop_chain = ss->next;
416 gcc_assert (ss == gfc_ss_terminator);
421 /* Generate an initializer for a static pointer or allocatable array. */
424 gfc_trans_static_array_pointer (gfc_symbol * sym)
428 gcc_assert (TREE_STATIC (sym->backend_decl));
429 /* Just zero the data member. */
430 type = TREE_TYPE (sym->backend_decl);
431 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
435 /* If the bounds of SE's loop have not yet been set, see if they can be
436 determined from array spec AS, which is the array spec of a called
437 function. MAPPING maps the callee's dummy arguments to the values
438 that the caller is passing. Add any initialization and finalization
442 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
443 gfc_se * se, gfc_array_spec * as)
451 if (as && as->type == AS_EXPLICIT)
452 for (dim = 0; dim < se->loop->dimen; dim++)
454 n = se->loop->order[dim];
455 if (se->loop->to[n] == NULL_TREE)
457 /* Evaluate the lower bound. */
458 gfc_init_se (&tmpse, NULL);
459 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
460 gfc_add_block_to_block (&se->pre, &tmpse.pre);
461 gfc_add_block_to_block (&se->post, &tmpse.post);
464 /* ...and the upper bound. */
465 gfc_init_se (&tmpse, NULL);
466 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
467 gfc_add_block_to_block (&se->pre, &tmpse.pre);
468 gfc_add_block_to_block (&se->post, &tmpse.post);
471 /* Set the upper bound of the loop to UPPER - LOWER. */
472 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
473 tmp = gfc_evaluate_now (tmp, &se->pre);
474 se->loop->to[n] = tmp;
480 /* Generate code to allocate an array temporary, or create a variable to
481 hold the data. If size is NULL zero the descriptor so that so that the
482 callee will allocate the array. Also generates code to free the array
485 Initialization code is added to PRE and finalization code to POST.
486 DYNAMIC is true if the caller may want to extend the array later
487 using realloc. This prevents us from putting the array on the stack. */
490 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
491 gfc_ss_info * info, tree size, tree nelem,
499 desc = info->descriptor;
500 info->offset = gfc_index_zero_node;
501 if (size == NULL_TREE || integer_zerop (size))
503 /* A callee allocated array. */
504 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
509 /* Allocate the temporary. */
510 onstack = !dynamic && gfc_can_put_var_on_stack (size);
514 /* Make a temporary variable to hold the data. */
515 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
517 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
519 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
521 tmp = gfc_create_var (tmp, "A");
522 tmp = gfc_build_addr_expr (NULL, tmp);
523 gfc_conv_descriptor_data_set (pre, desc, tmp);
527 /* Allocate memory to hold the data. */
528 args = gfc_chainon_list (NULL_TREE, size);
530 if (gfc_index_integer_kind == 4)
531 tmp = gfor_fndecl_internal_malloc;
532 else if (gfc_index_integer_kind == 8)
533 tmp = gfor_fndecl_internal_malloc64;
536 tmp = gfc_build_function_call (tmp, args);
537 tmp = gfc_evaluate_now (tmp, pre);
538 gfc_conv_descriptor_data_set (pre, desc, tmp);
541 info->data = gfc_conv_descriptor_data_get (desc);
543 /* The offset is zero because we create temporaries with a zero
545 tmp = gfc_conv_descriptor_offset (desc);
546 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
550 /* Free the temporary. */
551 tmp = gfc_conv_descriptor_data_get (desc);
552 tmp = fold_convert (pvoid_type_node, tmp);
553 tmp = gfc_chainon_list (NULL_TREE, tmp);
554 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
555 gfc_add_expr_to_block (post, tmp);
560 /* Generate code to allocate and initialize the descriptor for a temporary
561 array. This is used for both temporaries needed by the scalarizer, and
562 functions returning arrays. Adjusts the loop variables to be zero-based,
563 and calculates the loop bounds for callee allocated arrays.
564 Also fills in the descriptor, data and offset fields of info if known.
565 Returns the size of the array, or NULL for a callee allocated array.
567 PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage. */
570 gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
571 gfc_loopinfo * loop, gfc_ss_info * info,
572 tree eltype, bool dynamic)
582 gcc_assert (info->dimen > 0);
583 /* Set the lower bound to zero. */
584 for (dim = 0; dim < info->dimen; dim++)
586 n = loop->order[dim];
587 if (n < loop->temp_dim)
588 gcc_assert (integer_zerop (loop->from[n]));
591 /* Callee allocated arrays may not have a known bound yet. */
593 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
594 loop->to[n], loop->from[n]);
595 loop->from[n] = gfc_index_zero_node;
598 info->delta[dim] = gfc_index_zero_node;
599 info->start[dim] = gfc_index_zero_node;
600 info->stride[dim] = gfc_index_one_node;
601 info->dim[dim] = dim;
604 /* Initialize the descriptor. */
606 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
607 desc = gfc_create_var (type, "atmp");
608 GFC_DECL_PACKED_ARRAY (desc) = 1;
610 info->descriptor = desc;
611 size = gfc_index_one_node;
613 /* Fill in the array dtype. */
614 tmp = gfc_conv_descriptor_dtype (desc);
615 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
618 Fill in the bounds and stride. This is a packed array, so:
621 for (n = 0; n < rank; n++)
624 delta = ubound[n] + 1 - lbound[n];
627 size = size * sizeof(element);
630 for (n = 0; n < info->dimen; n++)
632 if (loop->to[n] == NULL_TREE)
634 /* For a callee allocated array express the loop bounds in terms
635 of the descriptor fields. */
636 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
637 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
638 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
644 /* Store the stride and bound components in the descriptor. */
645 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
646 gfc_add_modify_expr (pre, tmp, size);
648 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
649 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
651 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
652 gfc_add_modify_expr (pre, tmp, loop->to[n]);
654 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
655 loop->to[n], gfc_index_one_node);
657 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
658 size = gfc_evaluate_now (size, pre);
661 /* Get the size of the array. */
664 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
665 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
667 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
669 if (info->dimen > loop->temp_dim)
670 loop->temp_dim = info->dimen;
676 /* Return the number of iterations in a loop that starts at START,
677 ends at END, and has step STEP. */
680 gfc_get_iteration_count (tree start, tree end, tree step)
685 type = TREE_TYPE (step);
686 tmp = fold_build2 (MINUS_EXPR, type, end, start);
687 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
688 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
689 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
690 return fold_convert (gfc_array_index_type, tmp);
694 /* Extend the data in array DESC by EXTRA elements. */
697 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
704 if (integer_zerop (extra))
707 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
709 /* Add EXTRA to the upper bound. */
710 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
711 gfc_add_modify_expr (pblock, ubound, tmp);
713 /* Get the value of the current data pointer. */
714 tmp = gfc_conv_descriptor_data_get (desc);
715 args = gfc_chainon_list (NULL_TREE, tmp);
717 /* Calculate the new array size. */
718 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
719 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
720 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
721 args = gfc_chainon_list (args, tmp);
723 /* Pick the appropriate realloc function. */
724 if (gfc_index_integer_kind == 4)
725 tmp = gfor_fndecl_internal_realloc;
726 else if (gfc_index_integer_kind == 8)
727 tmp = gfor_fndecl_internal_realloc64;
731 /* Set the new data pointer. */
732 tmp = gfc_build_function_call (tmp, args);
733 gfc_conv_descriptor_data_set (pblock, desc, tmp);
737 /* Return true if the bounds of iterator I can only be determined
741 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
743 return (i->start->expr_type != EXPR_CONSTANT
744 || i->end->expr_type != EXPR_CONSTANT
745 || i->step->expr_type != EXPR_CONSTANT);
749 /* Split the size of constructor element EXPR into the sum of two terms,
750 one of which can be determined at compile time and one of which must
751 be calculated at run time. Set *SIZE to the former and return true
752 if the latter might be nonzero. */
755 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
757 if (expr->expr_type == EXPR_ARRAY)
758 return gfc_get_array_constructor_size (size, expr->value.constructor);
759 else if (expr->rank > 0)
761 /* Calculate everything at run time. */
762 mpz_set_ui (*size, 0);
767 /* A single element. */
768 mpz_set_ui (*size, 1);
774 /* Like gfc_get_array_constructor_element_size, but applied to the whole
775 of array constructor C. */
778 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
785 mpz_set_ui (*size, 0);
790 for (; c; c = c->next)
793 if (i && gfc_iterator_has_dynamic_bounds (i))
797 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
800 /* Multiply the static part of the element size by the
801 number of iterations. */
802 mpz_sub (val, i->end->value.integer, i->start->value.integer);
803 mpz_fdiv_q (val, val, i->step->value.integer);
804 mpz_add_ui (val, val, 1);
805 if (mpz_sgn (val) > 0)
806 mpz_mul (len, len, val);
810 mpz_add (*size, *size, len);
819 /* Make sure offset is a variable. */
822 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
825 /* We should have already created the offset variable. We cannot
826 create it here because we may be in an inner scope. */
827 gcc_assert (*offsetvar != NULL_TREE);
828 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
829 *poffset = *offsetvar;
830 TREE_USED (*offsetvar) = 1;
834 /* Assign an element of an array constructor. */
837 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
838 tree offset, gfc_se * se, gfc_expr * expr)
843 gfc_conv_expr (se, expr);
845 /* Store the value. */
846 tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
847 tmp = gfc_build_array_ref (tmp, offset);
848 if (expr->ts.type == BT_CHARACTER)
850 gfc_conv_string_parameter (se);
851 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
853 /* The temporary is an array of pointers. */
854 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
855 gfc_add_modify_expr (&se->pre, tmp, se->expr);
859 /* The temporary is an array of string values. */
860 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
861 /* We know the temporary and the value will be the same length,
862 so can use memcpy. */
863 args = gfc_chainon_list (NULL_TREE, tmp);
864 args = gfc_chainon_list (args, se->expr);
865 args = gfc_chainon_list (args, se->string_length);
866 tmp = built_in_decls[BUILT_IN_MEMCPY];
867 tmp = gfc_build_function_call (tmp, args);
868 gfc_add_expr_to_block (&se->pre, tmp);
873 /* TODO: Should the frontend already have done this conversion? */
874 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
875 gfc_add_modify_expr (&se->pre, tmp, se->expr);
878 gfc_add_block_to_block (pblock, &se->pre);
879 gfc_add_block_to_block (pblock, &se->post);
883 /* Add the contents of an array to the constructor. DYNAMIC is as for
884 gfc_trans_array_constructor_value. */
887 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
888 tree type ATTRIBUTE_UNUSED,
889 tree desc, gfc_expr * expr,
890 tree * poffset, tree * offsetvar,
901 /* We need this to be a variable so we can increment it. */
902 gfc_put_offset_into_var (pblock, poffset, offsetvar);
904 gfc_init_se (&se, NULL);
906 /* Walk the array expression. */
907 ss = gfc_walk_expr (expr);
908 gcc_assert (ss != gfc_ss_terminator);
910 /* Initialize the scalarizer. */
911 gfc_init_loopinfo (&loop);
912 gfc_add_ss_to_loop (&loop, ss);
914 /* Initialize the loop. */
915 gfc_conv_ss_startstride (&loop);
916 gfc_conv_loop_setup (&loop);
918 /* Make sure the constructed array has room for the new data. */
921 /* Set SIZE to the total number of elements in the subarray. */
922 size = gfc_index_one_node;
923 for (n = 0; n < loop.dimen; n++)
925 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
927 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
930 /* Grow the constructed array by SIZE elements. */
931 gfc_grow_array (&loop.pre, desc, size);
934 /* Make the loop body. */
935 gfc_mark_ss_chain_used (ss, 1);
936 gfc_start_scalarized_body (&loop, &body);
937 gfc_copy_loopinfo_to_se (&se, &loop);
940 if (expr->ts.type == BT_CHARACTER)
941 gfc_todo_error ("character arrays in constructors");
943 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
944 gcc_assert (se.ss == gfc_ss_terminator);
946 /* Increment the offset. */
947 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
948 gfc_add_modify_expr (&body, *poffset, tmp);
950 /* Finish the loop. */
951 gfc_trans_scalarizing_loops (&loop, &body);
952 gfc_add_block_to_block (&loop.pre, &loop.post);
953 tmp = gfc_finish_block (&loop.pre);
954 gfc_add_expr_to_block (pblock, tmp);
956 gfc_cleanup_loop (&loop);
960 /* Assign the values to the elements of an array constructor. DYNAMIC
961 is true if descriptor DESC only contains enough data for the static
962 size calculated by gfc_get_array_constructor_size. When true, memory
963 for the dynamic parts must be allocated using realloc. */
966 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
967 tree desc, gfc_constructor * c,
968 tree * poffset, tree * offsetvar,
977 for (; c; c = c->next)
979 /* If this is an iterator or an array, the offset must be a variable. */
980 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
981 gfc_put_offset_into_var (pblock, poffset, offsetvar);
983 gfc_start_block (&body);
985 if (c->expr->expr_type == EXPR_ARRAY)
987 /* Array constructors can be nested. */
988 gfc_trans_array_constructor_value (&body, type, desc,
989 c->expr->value.constructor,
990 poffset, offsetvar, dynamic);
992 else if (c->expr->rank > 0)
994 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
995 poffset, offsetvar, dynamic);
999 /* This code really upsets the gimplifier so don't bother for now. */
1006 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1013 /* Scalar values. */
1014 gfc_init_se (&se, NULL);
1015 gfc_trans_array_ctor_element (&body, desc, *poffset,
1018 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1019 *poffset, gfc_index_one_node);
1023 /* Collect multiple scalar constants into a constructor. */
1031 /* Count the number of consecutive scalar constants. */
1032 while (p && !(p->iterator
1033 || p->expr->expr_type != EXPR_CONSTANT))
1035 gfc_init_se (&se, NULL);
1036 gfc_conv_constant (&se, p->expr);
1037 if (p->expr->ts.type == BT_CHARACTER
1038 && POINTER_TYPE_P (type))
1040 /* For constant character array constructors we build
1041 an array of pointers. */
1042 se.expr = gfc_build_addr_expr (pchar_type_node,
1046 list = tree_cons (NULL_TREE, se.expr, list);
1051 bound = build_int_cst (NULL_TREE, n - 1);
1052 /* Create an array type to hold them. */
1053 tmptype = build_range_type (gfc_array_index_type,
1054 gfc_index_zero_node, bound);
1055 tmptype = build_array_type (type, tmptype);
1057 init = build_constructor_from_list (tmptype, nreverse (list));
1058 TREE_CONSTANT (init) = 1;
1059 TREE_INVARIANT (init) = 1;
1060 TREE_STATIC (init) = 1;
1061 /* Create a static variable to hold the data. */
1062 tmp = gfc_create_var (tmptype, "data");
1063 TREE_STATIC (tmp) = 1;
1064 TREE_CONSTANT (tmp) = 1;
1065 TREE_INVARIANT (tmp) = 1;
1066 DECL_INITIAL (tmp) = init;
1069 /* Use BUILTIN_MEMCPY to assign the values. */
1070 tmp = gfc_conv_descriptor_data_get (desc);
1071 tmp = gfc_build_indirect_ref (tmp);
1072 tmp = gfc_build_array_ref (tmp, *poffset);
1073 tmp = gfc_build_addr_expr (NULL, tmp);
1074 init = gfc_build_addr_expr (NULL, init);
1076 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1077 bound = build_int_cst (NULL_TREE, n * size);
1078 tmp = gfc_chainon_list (NULL_TREE, tmp);
1079 tmp = gfc_chainon_list (tmp, init);
1080 tmp = gfc_chainon_list (tmp, bound);
1081 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
1083 gfc_add_expr_to_block (&body, tmp);
1085 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1086 *poffset, build_int_cst (NULL_TREE, n));
1088 if (!INTEGER_CST_P (*poffset))
1090 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1091 *poffset = *offsetvar;
1095 /* The frontend should already have done any expansions possible
1099 /* Pass the code as is. */
1100 tmp = gfc_finish_block (&body);
1101 gfc_add_expr_to_block (pblock, tmp);
1105 /* Build the implied do-loop. */
1114 loopbody = gfc_finish_block (&body);
1116 gfc_init_se (&se, NULL);
1117 gfc_conv_expr (&se, c->iterator->var);
1118 gfc_add_block_to_block (pblock, &se.pre);
1121 /* Initialize the loop. */
1122 gfc_init_se (&se, NULL);
1123 gfc_conv_expr_val (&se, c->iterator->start);
1124 gfc_add_block_to_block (pblock, &se.pre);
1125 gfc_add_modify_expr (pblock, loopvar, se.expr);
1127 gfc_init_se (&se, NULL);
1128 gfc_conv_expr_val (&se, c->iterator->end);
1129 gfc_add_block_to_block (pblock, &se.pre);
1130 end = gfc_evaluate_now (se.expr, pblock);
1132 gfc_init_se (&se, NULL);
1133 gfc_conv_expr_val (&se, c->iterator->step);
1134 gfc_add_block_to_block (pblock, &se.pre);
1135 step = gfc_evaluate_now (se.expr, pblock);
1137 /* If this array expands dynamically, and the number of iterations
1138 is not constant, we won't have allocated space for the static
1139 part of C->EXPR's size. Do that now. */
1140 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1142 /* Get the number of iterations. */
1143 tmp = gfc_get_iteration_count (loopvar, end, step);
1145 /* Get the static part of C->EXPR's size. */
1146 gfc_get_array_constructor_element_size (&size, c->expr);
1147 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1149 /* Grow the array by TMP * TMP2 elements. */
1150 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1151 gfc_grow_array (pblock, desc, tmp);
1154 /* Generate the loop body. */
1155 exit_label = gfc_build_label_decl (NULL_TREE);
1156 gfc_start_block (&body);
1158 /* Generate the exit condition. Depending on the sign of
1159 the step variable we have to generate the correct
1161 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1162 build_int_cst (TREE_TYPE (step), 0));
1163 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1164 build2 (GT_EXPR, boolean_type_node,
1166 build2 (LT_EXPR, boolean_type_node,
1168 tmp = build1_v (GOTO_EXPR, exit_label);
1169 TREE_USED (exit_label) = 1;
1170 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1171 gfc_add_expr_to_block (&body, tmp);
1173 /* The main loop body. */
1174 gfc_add_expr_to_block (&body, loopbody);
1176 /* Increase loop variable by step. */
1177 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1178 gfc_add_modify_expr (&body, loopvar, tmp);
1180 /* Finish the loop. */
1181 tmp = gfc_finish_block (&body);
1182 tmp = build1_v (LOOP_EXPR, tmp);
1183 gfc_add_expr_to_block (pblock, tmp);
1185 /* Add the exit label. */
1186 tmp = build1_v (LABEL_EXPR, exit_label);
1187 gfc_add_expr_to_block (pblock, tmp);
1194 /* Figure out the string length of a variable reference expression.
1195 Used by get_array_ctor_strlen. */
1198 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1203 /* Don't bother if we already know the length is a constant. */
1204 if (*len && INTEGER_CST_P (*len))
1207 ts = &expr->symtree->n.sym->ts;
1208 for (ref = expr->ref; ref; ref = ref->next)
1213 /* Array references don't change the string length. */
1217 /* Use the length of the component. */
1218 ts = &ref->u.c.component->ts;
1222 /* TODO: Substrings are tricky because we can't evaluate the
1223 expression more than once. For now we just give up, and hope
1224 we can figure it out elsewhere. */
1229 *len = ts->cl->backend_decl;
1233 /* Figure out the string length of a character array constructor.
1234 Returns TRUE if all elements are character constants. */
1237 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1242 for (; c; c = c->next)
1244 switch (c->expr->expr_type)
1247 if (!(*len && INTEGER_CST_P (*len)))
1248 *len = build_int_cstu (gfc_charlen_type_node,
1249 c->expr->value.character.length);
1253 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1259 get_array_ctor_var_strlen (c->expr, len);
1264 /* TODO: For now we just ignore anything we don't know how to
1265 handle, and hope we can figure it out a different way. */
1274 /* Array constructors are handled by constructing a temporary, then using that
1275 within the scalarization loop. This is not optimal, but seems by far the
1279 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1289 ss->data.info.dimen = loop->dimen;
1291 c = ss->expr->value.constructor;
1292 if (ss->expr->ts.type == BT_CHARACTER)
1294 const_string = get_array_ctor_strlen (c, &ss->string_length);
1295 if (!ss->string_length)
1296 gfc_todo_error ("complex character array constructors");
1298 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1300 type = build_pointer_type (type);
1304 const_string = TRUE;
1305 type = gfc_typenode_for_spec (&ss->expr->ts);
1308 /* See if the constructor determines the loop bounds. */
1310 if (loop->to[0] == NULL_TREE)
1314 /* We should have a 1-dimensional, zero-based loop. */
1315 gcc_assert (loop->dimen == 1);
1316 gcc_assert (integer_zerop (loop->from[0]));
1318 /* Split the constructor size into a static part and a dynamic part.
1319 Allocate the static size up-front and record whether the dynamic
1320 size might be nonzero. */
1322 dynamic = gfc_get_array_constructor_size (&size, c);
1323 mpz_sub_ui (size, size, 1);
1324 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1328 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
1329 &ss->data.info, type, dynamic);
1331 desc = ss->data.info.descriptor;
1332 offset = gfc_index_zero_node;
1333 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1334 TREE_USED (offsetvar) = 0;
1335 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1336 &offset, &offsetvar, dynamic);
1338 /* If the array grows dynamically, the upper bound of the loop variable
1339 is determined by the array's final upper bound. */
1341 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1343 if (TREE_USED (offsetvar))
1344 pushdecl (offsetvar);
1346 gcc_assert (INTEGER_CST_P (offset));
1348 /* Disable bound checking for now because it's probably broken. */
1349 if (flag_bounds_check)
1357 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1358 called after evaluating all of INFO's vector dimensions. Go through
1359 each such vector dimension and see if we can now fill in any missing
1363 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1372 for (n = 0; n < loop->dimen; n++)
1375 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1376 && loop->to[n] == NULL)
1378 /* Loop variable N indexes vector dimension DIM, and we don't
1379 yet know the upper bound of loop variable N. Set it to the
1380 difference between the vector's upper and lower bounds. */
1381 gcc_assert (loop->from[n] == gfc_index_zero_node);
1382 gcc_assert (info->subscript[dim]
1383 && info->subscript[dim]->type == GFC_SS_VECTOR);
1385 gfc_init_se (&se, NULL);
1386 desc = info->subscript[dim]->data.info.descriptor;
1387 zero = gfc_rank_cst[0];
1388 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1389 gfc_conv_descriptor_ubound (desc, zero),
1390 gfc_conv_descriptor_lbound (desc, zero));
1391 tmp = gfc_evaluate_now (tmp, &loop->pre);
1398 /* Add the pre and post chains for all the scalar expressions in a SS chain
1399 to loop. This is called after the loop parameters have been calculated,
1400 but before the actual scalarizing loops. */
1403 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1408 /* TODO: This can generate bad code if there are ordering dependencies.
1409 eg. a callee allocated function and an unknown size constructor. */
1410 gcc_assert (ss != NULL);
1412 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1419 /* Scalar expression. Evaluate this now. This includes elemental
1420 dimension indices, but not array section bounds. */
1421 gfc_init_se (&se, NULL);
1422 gfc_conv_expr (&se, ss->expr);
1423 gfc_add_block_to_block (&loop->pre, &se.pre);
1425 if (ss->expr->ts.type != BT_CHARACTER)
1427 /* Move the evaluation of scalar expressions outside the
1428 scalarization loop. */
1430 se.expr = convert(gfc_array_index_type, se.expr);
1431 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1432 gfc_add_block_to_block (&loop->pre, &se.post);
1435 gfc_add_block_to_block (&loop->post, &se.post);
1437 ss->data.scalar.expr = se.expr;
1438 ss->string_length = se.string_length;
1441 case GFC_SS_REFERENCE:
1442 /* Scalar reference. Evaluate this now. */
1443 gfc_init_se (&se, NULL);
1444 gfc_conv_expr_reference (&se, ss->expr);
1445 gfc_add_block_to_block (&loop->pre, &se.pre);
1446 gfc_add_block_to_block (&loop->post, &se.post);
1448 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1449 ss->string_length = se.string_length;
1452 case GFC_SS_SECTION:
1453 /* Add the expressions for scalar and vector subscripts. */
1454 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1455 if (ss->data.info.subscript[n])
1456 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1458 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1462 /* Get the vector's descriptor and store it in SS. */
1463 gfc_init_se (&se, NULL);
1464 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1465 gfc_add_block_to_block (&loop->pre, &se.pre);
1466 gfc_add_block_to_block (&loop->post, &se.post);
1467 ss->data.info.descriptor = se.expr;
1470 case GFC_SS_INTRINSIC:
1471 gfc_add_intrinsic_ss_code (loop, ss);
1474 case GFC_SS_FUNCTION:
1475 /* Array function return value. We call the function and save its
1476 result in a temporary for use inside the loop. */
1477 gfc_init_se (&se, NULL);
1480 gfc_conv_expr (&se, ss->expr);
1481 gfc_add_block_to_block (&loop->pre, &se.pre);
1482 gfc_add_block_to_block (&loop->post, &se.post);
1483 ss->string_length = se.string_length;
1486 case GFC_SS_CONSTRUCTOR:
1487 gfc_trans_array_constructor (loop, ss);
1491 case GFC_SS_COMPONENT:
1492 /* Do nothing. These are handled elsewhere. */
1502 /* Translate expressions for the descriptor and data pointer of a SS. */
1506 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1511 /* Get the descriptor for the array to be scalarized. */
1512 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1513 gfc_init_se (&se, NULL);
1514 se.descriptor_only = 1;
1515 gfc_conv_expr_lhs (&se, ss->expr);
1516 gfc_add_block_to_block (block, &se.pre);
1517 ss->data.info.descriptor = se.expr;
1518 ss->string_length = se.string_length;
1522 /* Also the data pointer. */
1523 tmp = gfc_conv_array_data (se.expr);
1524 /* If this is a variable or address of a variable we use it directly.
1525 Otherwise we must evaluate it now to avoid breaking dependency
1526 analysis by pulling the expressions for elemental array indices
1529 || (TREE_CODE (tmp) == ADDR_EXPR
1530 && DECL_P (TREE_OPERAND (tmp, 0)))))
1531 tmp = gfc_evaluate_now (tmp, block);
1532 ss->data.info.data = tmp;
1534 tmp = gfc_conv_array_offset (se.expr);
1535 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1540 /* Initialize a gfc_loopinfo structure. */
1543 gfc_init_loopinfo (gfc_loopinfo * loop)
1547 memset (loop, 0, sizeof (gfc_loopinfo));
1548 gfc_init_block (&loop->pre);
1549 gfc_init_block (&loop->post);
1551 /* Initially scalarize in order. */
1552 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1555 loop->ss = gfc_ss_terminator;
1559 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1563 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1569 /* Return an expression for the data pointer of an array. */
1572 gfc_conv_array_data (tree descriptor)
1576 type = TREE_TYPE (descriptor);
1577 if (GFC_ARRAY_TYPE_P (type))
1579 if (TREE_CODE (type) == POINTER_TYPE)
1583 /* Descriptorless arrays. */
1584 return gfc_build_addr_expr (NULL, descriptor);
1588 return gfc_conv_descriptor_data_get (descriptor);
1592 /* Return an expression for the base offset of an array. */
1595 gfc_conv_array_offset (tree descriptor)
1599 type = TREE_TYPE (descriptor);
1600 if (GFC_ARRAY_TYPE_P (type))
1601 return GFC_TYPE_ARRAY_OFFSET (type);
1603 return gfc_conv_descriptor_offset (descriptor);
1607 /* Get an expression for the array stride. */
1610 gfc_conv_array_stride (tree descriptor, int dim)
1615 type = TREE_TYPE (descriptor);
1617 /* For descriptorless arrays use the array size. */
1618 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1619 if (tmp != NULL_TREE)
1622 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1627 /* Like gfc_conv_array_stride, but for the lower bound. */
1630 gfc_conv_array_lbound (tree descriptor, int dim)
1635 type = TREE_TYPE (descriptor);
1637 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1638 if (tmp != NULL_TREE)
1641 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1646 /* Like gfc_conv_array_stride, but for the upper bound. */
1649 gfc_conv_array_ubound (tree descriptor, int dim)
1654 type = TREE_TYPE (descriptor);
1656 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1657 if (tmp != NULL_TREE)
1660 /* This should only ever happen when passing an assumed shape array
1661 as an actual parameter. The value will never be used. */
1662 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1663 return gfc_index_zero_node;
1665 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1670 /* Generate code to perform an array index bound check. */
1673 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1679 if (!flag_bounds_check)
1682 index = gfc_evaluate_now (index, &se->pre);
1683 /* Check lower bound. */
1684 tmp = gfc_conv_array_lbound (descriptor, n);
1685 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1686 /* Check upper bound. */
1687 tmp = gfc_conv_array_ubound (descriptor, n);
1688 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1689 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1691 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1697 /* Return the offset for an index. Performs bound checking for elemental
1698 dimensions. Single element references are processed separately. */
1701 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1702 gfc_array_ref * ar, tree stride)
1708 /* Get the index into the array for this dimension. */
1711 gcc_assert (ar->type != AR_ELEMENT);
1712 switch (ar->dimen_type[dim])
1715 gcc_assert (i == -1);
1716 /* Elemental dimension. */
1717 gcc_assert (info->subscript[dim]
1718 && info->subscript[dim]->type == GFC_SS_SCALAR);
1719 /* We've already translated this value outside the loop. */
1720 index = info->subscript[dim]->data.scalar.expr;
1723 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1727 gcc_assert (info && se->loop);
1728 gcc_assert (info->subscript[dim]
1729 && info->subscript[dim]->type == GFC_SS_VECTOR);
1730 desc = info->subscript[dim]->data.info.descriptor;
1732 /* Get a zero-based index into the vector. */
1733 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1734 se->loop->loopvar[i], se->loop->from[i]);
1736 /* Multiply the index by the stride. */
1737 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1738 index, gfc_conv_array_stride (desc, 0));
1740 /* Read the vector to get an index into info->descriptor. */
1741 data = gfc_build_indirect_ref (gfc_conv_array_data (desc));
1742 index = gfc_build_array_ref (data, index);
1743 index = gfc_evaluate_now (index, &se->pre);
1745 /* Do any bounds checking on the final info->descriptor index. */
1746 index = gfc_trans_array_bound_check (se, info->descriptor,
1751 /* Scalarized dimension. */
1752 gcc_assert (info && se->loop);
1754 /* Multiply the loop variable by the stride and delta. */
1755 index = se->loop->loopvar[i];
1756 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1758 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1768 /* Temporary array or derived type component. */
1769 gcc_assert (se->loop);
1770 index = se->loop->loopvar[se->loop->order[i]];
1771 if (!integer_zerop (info->delta[i]))
1772 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1773 index, info->delta[i]);
1776 /* Multiply by the stride. */
1777 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1783 /* Build a scalarized reference to an array. */
1786 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1793 info = &se->ss->data.info;
1795 n = se->loop->order[0];
1799 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1801 /* Add the offset for this dimension to the stored offset for all other
1803 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1805 tmp = gfc_build_indirect_ref (info->data);
1806 se->expr = gfc_build_array_ref (tmp, index);
1810 /* Translate access of temporary array. */
1813 gfc_conv_tmp_array_ref (gfc_se * se)
1815 se->string_length = se->ss->string_length;
1816 gfc_conv_scalarized_array_ref (se, NULL);
1820 /* Build an array reference. se->expr already holds the array descriptor.
1821 This should be either a variable, indirect variable reference or component
1822 reference. For arrays which do not have a descriptor, se->expr will be
1824 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1827 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1836 /* Handle scalarized references separately. */
1837 if (ar->type != AR_ELEMENT)
1839 gfc_conv_scalarized_array_ref (se, ar);
1840 gfc_advance_se_ss_chain (se);
1844 index = gfc_index_zero_node;
1846 fault = gfc_index_zero_node;
1848 /* Calculate the offsets from all the dimensions. */
1849 for (n = 0; n < ar->dimen; n++)
1851 /* Calculate the index for this dimension. */
1852 gfc_init_se (&indexse, se);
1853 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1854 gfc_add_block_to_block (&se->pre, &indexse.pre);
1856 if (flag_bounds_check)
1858 /* Check array bounds. */
1861 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1863 tmp = gfc_conv_array_lbound (se->expr, n);
1864 cond = fold_build2 (LT_EXPR, boolean_type_node,
1867 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1869 tmp = gfc_conv_array_ubound (se->expr, n);
1870 cond = fold_build2 (GT_EXPR, boolean_type_node,
1873 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1876 /* Multiply the index by the stride. */
1877 stride = gfc_conv_array_stride (se->expr, n);
1878 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1881 /* And add it to the total. */
1882 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1885 if (flag_bounds_check)
1886 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1888 tmp = gfc_conv_array_offset (se->expr);
1889 if (!integer_zerop (tmp))
1890 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1892 /* Access the calculated element. */
1893 tmp = gfc_conv_array_data (se->expr);
1894 tmp = gfc_build_indirect_ref (tmp);
1895 se->expr = gfc_build_array_ref (tmp, index);
1899 /* Generate the code to be executed immediately before entering a
1900 scalarization loop. */
1903 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1904 stmtblock_t * pblock)
1913 /* This code will be executed before entering the scalarization loop
1914 for this dimension. */
1915 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1917 if ((ss->useflags & flag) == 0)
1920 if (ss->type != GFC_SS_SECTION
1921 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1922 && ss->type != GFC_SS_COMPONENT)
1925 info = &ss->data.info;
1927 if (dim >= info->dimen)
1930 if (dim == info->dimen - 1)
1932 /* For the outermost loop calculate the offset due to any
1933 elemental dimensions. It will have been initialized with the
1934 base offset of the array. */
1937 for (i = 0; i < info->ref->u.ar.dimen; i++)
1939 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1942 gfc_init_se (&se, NULL);
1944 se.expr = info->descriptor;
1945 stride = gfc_conv_array_stride (info->descriptor, i);
1946 index = gfc_conv_array_index_offset (&se, info, i, -1,
1949 gfc_add_block_to_block (pblock, &se.pre);
1951 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1952 info->offset, index);
1953 info->offset = gfc_evaluate_now (info->offset, pblock);
1957 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1960 stride = gfc_conv_array_stride (info->descriptor, 0);
1962 /* Calculate the stride of the innermost loop. Hopefully this will
1963 allow the backend optimizers to do their stuff more effectively.
1965 info->stride0 = gfc_evaluate_now (stride, pblock);
1969 /* Add the offset for the previous loop dimension. */
1974 ar = &info->ref->u.ar;
1975 i = loop->order[dim + 1];
1983 gfc_init_se (&se, NULL);
1985 se.expr = info->descriptor;
1986 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1987 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
1989 gfc_add_block_to_block (pblock, &se.pre);
1990 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1991 info->offset, index);
1992 info->offset = gfc_evaluate_now (info->offset, pblock);
1995 /* Remember this offset for the second loop. */
1996 if (dim == loop->temp_dim - 1)
1997 info->saved_offset = info->offset;
2002 /* Start a scalarized expression. Creates a scope and declares loop
2006 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2012 gcc_assert (!loop->array_parameter);
2014 for (dim = loop->dimen - 1; dim >= 0; dim--)
2016 n = loop->order[dim];
2018 gfc_start_block (&loop->code[n]);
2020 /* Create the loop variable. */
2021 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2023 if (dim < loop->temp_dim)
2027 /* Calculate values that will be constant within this loop. */
2028 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2030 gfc_start_block (pbody);
2034 /* Generates the actual loop code for a scalarization loop. */
2037 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2038 stmtblock_t * pbody)
2046 loopbody = gfc_finish_block (pbody);
2048 /* Initialize the loopvar. */
2049 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2051 exit_label = gfc_build_label_decl (NULL_TREE);
2053 /* Generate the loop body. */
2054 gfc_init_block (&block);
2056 /* The exit condition. */
2057 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2058 tmp = build1_v (GOTO_EXPR, exit_label);
2059 TREE_USED (exit_label) = 1;
2060 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2061 gfc_add_expr_to_block (&block, tmp);
2063 /* The main body. */
2064 gfc_add_expr_to_block (&block, loopbody);
2066 /* Increment the loopvar. */
2067 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2068 loop->loopvar[n], gfc_index_one_node);
2069 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2071 /* Build the loop. */
2072 tmp = gfc_finish_block (&block);
2073 tmp = build1_v (LOOP_EXPR, tmp);
2074 gfc_add_expr_to_block (&loop->code[n], tmp);
2076 /* Add the exit label. */
2077 tmp = build1_v (LABEL_EXPR, exit_label);
2078 gfc_add_expr_to_block (&loop->code[n], tmp);
2082 /* Finishes and generates the loops for a scalarized expression. */
2085 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2090 stmtblock_t *pblock;
2094 /* Generate the loops. */
2095 for (dim = 0; dim < loop->dimen; dim++)
2097 n = loop->order[dim];
2098 gfc_trans_scalarized_loop_end (loop, n, pblock);
2099 loop->loopvar[n] = NULL_TREE;
2100 pblock = &loop->code[n];
2103 tmp = gfc_finish_block (pblock);
2104 gfc_add_expr_to_block (&loop->pre, tmp);
2106 /* Clear all the used flags. */
2107 for (ss = loop->ss; ss; ss = ss->loop_chain)
2112 /* Finish the main body of a scalarized expression, and start the secondary
2116 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2120 stmtblock_t *pblock;
2124 /* We finish as many loops as are used by the temporary. */
2125 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2127 n = loop->order[dim];
2128 gfc_trans_scalarized_loop_end (loop, n, pblock);
2129 loop->loopvar[n] = NULL_TREE;
2130 pblock = &loop->code[n];
2133 /* We don't want to finish the outermost loop entirely. */
2134 n = loop->order[loop->temp_dim - 1];
2135 gfc_trans_scalarized_loop_end (loop, n, pblock);
2137 /* Restore the initial offsets. */
2138 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2140 if ((ss->useflags & 2) == 0)
2143 if (ss->type != GFC_SS_SECTION
2144 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2145 && ss->type != GFC_SS_COMPONENT)
2148 ss->data.info.offset = ss->data.info.saved_offset;
2151 /* Restart all the inner loops we just finished. */
2152 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2154 n = loop->order[dim];
2156 gfc_start_block (&loop->code[n]);
2158 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2160 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2163 /* Start a block for the secondary copying code. */
2164 gfc_start_block (body);
2168 /* Calculate the upper bound of an array section. */
2171 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2180 gcc_assert (ss->type == GFC_SS_SECTION);
2182 info = &ss->data.info;
2185 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2186 /* We'll calculate the upper bound once we have access to the
2187 vector's descriptor. */
2190 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2191 desc = info->descriptor;
2192 end = info->ref->u.ar.end[dim];
2196 /* The upper bound was specified. */
2197 gfc_init_se (&se, NULL);
2198 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2199 gfc_add_block_to_block (pblock, &se.pre);
2204 /* No upper bound was specified, so use the bound of the array. */
2205 bound = gfc_conv_array_ubound (desc, dim);
2212 /* Calculate the lower bound of an array section. */
2215 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2224 gcc_assert (ss->type == GFC_SS_SECTION);
2226 info = &ss->data.info;
2229 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2231 /* We use a zero-based index to access the vector. */
2232 info->start[n] = gfc_index_zero_node;
2233 info->stride[n] = gfc_index_one_node;
2237 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2238 desc = info->descriptor;
2239 start = info->ref->u.ar.start[dim];
2240 stride = info->ref->u.ar.stride[dim];
2242 /* Calculate the start of the range. For vector subscripts this will
2243 be the range of the vector. */
2246 /* Specified section start. */
2247 gfc_init_se (&se, NULL);
2248 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2249 gfc_add_block_to_block (&loop->pre, &se.pre);
2250 info->start[n] = se.expr;
2254 /* No lower bound specified so use the bound of the array. */
2255 info->start[n] = gfc_conv_array_lbound (desc, dim);
2257 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2259 /* Calculate the stride. */
2261 info->stride[n] = gfc_index_one_node;
2264 gfc_init_se (&se, NULL);
2265 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2266 gfc_add_block_to_block (&loop->pre, &se.pre);
2267 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2272 /* Calculates the range start and stride for a SS chain. Also gets the
2273 descriptor and data pointer. The range of vector subscripts is the size
2274 of the vector. Array bounds are also checked. */
2277 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2285 /* Determine the rank of the loop. */
2287 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2291 case GFC_SS_SECTION:
2292 case GFC_SS_CONSTRUCTOR:
2293 case GFC_SS_FUNCTION:
2294 case GFC_SS_COMPONENT:
2295 loop->dimen = ss->data.info.dimen;
2303 if (loop->dimen == 0)
2304 gfc_todo_error ("Unable to determine rank of expression");
2307 /* Loop over all the SS in the chain. */
2308 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2310 if (ss->expr && ss->expr->shape && !ss->shape)
2311 ss->shape = ss->expr->shape;
2315 case GFC_SS_SECTION:
2316 /* Get the descriptor for the array. */
2317 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2319 for (n = 0; n < ss->data.info.dimen; n++)
2320 gfc_conv_section_startstride (loop, ss, n);
2323 case GFC_SS_CONSTRUCTOR:
2324 case GFC_SS_FUNCTION:
2325 for (n = 0; n < ss->data.info.dimen; n++)
2327 ss->data.info.start[n] = gfc_index_zero_node;
2328 ss->data.info.stride[n] = gfc_index_one_node;
2337 /* The rest is just runtime bound checking. */
2338 if (flag_bounds_check)
2344 tree size[GFC_MAX_DIMENSIONS];
2348 gfc_start_block (&block);
2350 fault = integer_zero_node;
2351 for (n = 0; n < loop->dimen; n++)
2352 size[n] = NULL_TREE;
2354 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2356 if (ss->type != GFC_SS_SECTION)
2359 /* TODO: range checking for mapped dimensions. */
2360 info = &ss->data.info;
2362 /* This code only checks ranges. Elemental and vector
2363 dimensions are checked later. */
2364 for (n = 0; n < loop->dimen; n++)
2367 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2370 desc = ss->data.info.descriptor;
2372 /* Check lower bound. */
2373 bound = gfc_conv_array_lbound (desc, dim);
2374 tmp = info->start[n];
2375 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2376 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2379 /* Check the upper bound. */
2380 bound = gfc_conv_array_ubound (desc, dim);
2381 end = gfc_conv_section_upper_bound (ss, n, &block);
2382 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2383 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2386 /* Check the section sizes match. */
2387 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2389 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2391 /* We remember the size of the first section, and check all the
2392 others against this. */
2396 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2398 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2401 size[n] = gfc_evaluate_now (tmp, &block);
2404 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2406 tmp = gfc_finish_block (&block);
2407 gfc_add_expr_to_block (&loop->pre, tmp);
2412 /* Return true if the two SS could be aliased, i.e. both point to the same data
2414 /* TODO: resolve aliases based on frontend expressions. */
2417 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2424 lsym = lss->expr->symtree->n.sym;
2425 rsym = rss->expr->symtree->n.sym;
2426 if (gfc_symbols_could_alias (lsym, rsym))
2429 if (rsym->ts.type != BT_DERIVED
2430 && lsym->ts.type != BT_DERIVED)
2433 /* For derived types we must check all the component types. We can ignore
2434 array references as these will have the same base type as the previous
2436 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2438 if (lref->type != REF_COMPONENT)
2441 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2444 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2447 if (rref->type != REF_COMPONENT)
2450 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2455 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2457 if (rref->type != REF_COMPONENT)
2460 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2468 /* Resolve array data dependencies. Creates a temporary if required. */
2469 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2473 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2483 loop->temp_ss = NULL;
2484 aref = dest->data.info.ref;
2487 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2489 if (ss->type != GFC_SS_SECTION)
2492 if (gfc_could_be_alias (dest, ss))
2498 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2500 lref = dest->expr->ref;
2501 rref = ss->expr->ref;
2503 nDepend = gfc_dep_resolver (lref, rref);
2505 /* TODO : loop shifting. */
2508 /* Mark the dimensions for LOOP SHIFTING */
2509 for (n = 0; n < loop->dimen; n++)
2511 int dim = dest->data.info.dim[n];
2513 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2515 else if (! gfc_is_same_range (&lref->u.ar,
2516 &rref->u.ar, dim, 0))
2520 /* Put all the dimensions with dependencies in the
2523 for (n = 0; n < loop->dimen; n++)
2525 gcc_assert (loop->order[n] == n);
2527 loop->order[dim++] = n;
2530 for (n = 0; n < loop->dimen; n++)
2533 loop->order[dim++] = n;
2536 gcc_assert (dim == loop->dimen);
2545 loop->temp_ss = gfc_get_ss ();
2546 loop->temp_ss->type = GFC_SS_TEMP;
2547 loop->temp_ss->data.temp.type =
2548 gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
2549 loop->temp_ss->string_length = dest->string_length;
2550 loop->temp_ss->data.temp.dimen = loop->dimen;
2551 loop->temp_ss->next = gfc_ss_terminator;
2552 gfc_add_ss_to_loop (loop, loop->temp_ss);
2555 loop->temp_ss = NULL;
2559 /* Initialize the scalarization loop. Creates the loop variables. Determines
2560 the range of the loop variables. Creates a temporary if required.
2561 Calculates how to transform from loop variables to array indices for each
2562 expression. Also generates code for scalar expressions which have been
2563 moved outside the loop. */
2566 gfc_conv_loop_setup (gfc_loopinfo * loop)
2571 gfc_ss_info *specinfo;
2575 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2576 bool dynamic[GFC_MAX_DIMENSIONS];
2582 for (n = 0; n < loop->dimen; n++)
2586 /* We use one SS term, and use that to determine the bounds of the
2587 loop for this dimension. We try to pick the simplest term. */
2588 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2592 /* The frontend has worked out the size for us. */
2597 if (ss->type == GFC_SS_CONSTRUCTOR)
2599 /* An unknown size constructor will always be rank one.
2600 Higher rank constructors will either have known shape,
2601 or still be wrapped in a call to reshape. */
2602 gcc_assert (loop->dimen == 1);
2604 /* Always prefer to use the constructor bounds if the size
2605 can be determined at compile time. Prefer not to otherwise,
2606 since the general case involves realloc, and it's better to
2607 avoid that overhead if possible. */
2608 c = ss->expr->value.constructor;
2609 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2610 if (!dynamic[n] || !loopspec[n])
2615 /* TODO: Pick the best bound if we have a choice between a
2616 function and something else. */
2617 if (ss->type == GFC_SS_FUNCTION)
2623 if (ss->type != GFC_SS_SECTION)
2627 specinfo = &loopspec[n]->data.info;
2630 info = &ss->data.info;
2634 /* Criteria for choosing a loop specifier (most important first):
2635 doesn't need realloc
2641 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2643 else if (integer_onep (info->stride[n])
2644 && !integer_onep (specinfo->stride[n]))
2646 else if (INTEGER_CST_P (info->stride[n])
2647 && !INTEGER_CST_P (specinfo->stride[n]))
2649 else if (INTEGER_CST_P (info->start[n])
2650 && !INTEGER_CST_P (specinfo->start[n]))
2652 /* We don't work out the upper bound.
2653 else if (INTEGER_CST_P (info->finish[n])
2654 && ! INTEGER_CST_P (specinfo->finish[n]))
2655 loopspec[n] = ss; */
2659 gfc_todo_error ("Unable to find scalarization loop specifier");
2661 info = &loopspec[n]->data.info;
2663 /* Set the extents of this range. */
2664 cshape = loopspec[n]->shape;
2665 if (cshape && INTEGER_CST_P (info->start[n])
2666 && INTEGER_CST_P (info->stride[n]))
2668 loop->from[n] = info->start[n];
2669 mpz_set (i, cshape[n]);
2670 mpz_sub_ui (i, i, 1);
2671 /* To = from + (size - 1) * stride. */
2672 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2673 if (!integer_onep (info->stride[n]))
2674 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2675 tmp, info->stride[n]);
2676 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2677 loop->from[n], tmp);
2681 loop->from[n] = info->start[n];
2682 switch (loopspec[n]->type)
2684 case GFC_SS_CONSTRUCTOR:
2685 /* The upper bound is calculated when we expand the
2687 gcc_assert (loop->to[n] == NULL_TREE);
2690 case GFC_SS_SECTION:
2691 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2695 case GFC_SS_FUNCTION:
2696 /* The loop bound will be set when we generate the call. */
2697 gcc_assert (loop->to[n] == NULL_TREE);
2705 /* Transform everything so we have a simple incrementing variable. */
2706 if (integer_onep (info->stride[n]))
2707 info->delta[n] = gfc_index_zero_node;
2710 /* Set the delta for this section. */
2711 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2712 /* Number of iterations is (end - start + step) / step.
2713 with start = 0, this simplifies to
2715 for (i = 0; i<=last; i++){...}; */
2716 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2717 loop->to[n], loop->from[n]);
2718 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2719 tmp, info->stride[n]);
2720 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2721 /* Make the loop variable start at 0. */
2722 loop->from[n] = gfc_index_zero_node;
2726 /* Add all the scalar code that can be taken out of the loops.
2727 This may include calculating the loop bounds, so do it before
2728 allocating the temporary. */
2729 gfc_add_loop_ss_code (loop, loop->ss, false);
2731 /* If we want a temporary then create it. */
2732 if (loop->temp_ss != NULL)
2734 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2735 tmp = loop->temp_ss->data.temp.type;
2736 len = loop->temp_ss->string_length;
2737 n = loop->temp_ss->data.temp.dimen;
2738 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2739 loop->temp_ss->type = GFC_SS_SECTION;
2740 loop->temp_ss->data.info.dimen = n;
2741 gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
2742 &loop->temp_ss->data.info, tmp, false);
2745 for (n = 0; n < loop->temp_dim; n++)
2746 loopspec[loop->order[n]] = NULL;
2750 /* For array parameters we don't have loop variables, so don't calculate the
2752 if (loop->array_parameter)
2755 /* Calculate the translation from loop variables to array indices. */
2756 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2758 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2761 info = &ss->data.info;
2763 for (n = 0; n < info->dimen; n++)
2767 /* If we are specifying the range the delta is already set. */
2768 if (loopspec[n] != ss)
2770 /* Calculate the offset relative to the loop variable.
2771 First multiply by the stride. */
2772 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2773 loop->from[n], info->stride[n]);
2775 /* Then subtract this from our starting value. */
2776 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2777 info->start[n], tmp);
2779 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2786 /* Fills in an array descriptor, and returns the size of the array. The size
2787 will be a simple_val, ie a variable or a constant. Also calculates the
2788 offset of the base. Returns the size of the array.
2792 for (n = 0; n < rank; n++)
2794 a.lbound[n] = specified_lower_bound;
2795 offset = offset + a.lbond[n] * stride;
2797 a.ubound[n] = specified_upper_bound;
2798 a.stride[n] = stride;
2799 size = ubound + size; //size = ubound + 1 - lbound
2800 stride = stride * size;
2807 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2808 gfc_expr ** lower, gfc_expr ** upper,
2809 stmtblock_t * pblock)
2820 type = TREE_TYPE (descriptor);
2822 stride = gfc_index_one_node;
2823 offset = gfc_index_zero_node;
2825 /* Set the dtype. */
2826 tmp = gfc_conv_descriptor_dtype (descriptor);
2827 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2829 for (n = 0; n < rank; n++)
2831 /* We have 3 possibilities for determining the size of the array:
2832 lower == NULL => lbound = 1, ubound = upper[n]
2833 upper[n] = NULL => lbound = 1, ubound = lower[n]
2834 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2837 /* Set lower bound. */
2838 gfc_init_se (&se, NULL);
2840 se.expr = gfc_index_one_node;
2843 gcc_assert (lower[n]);
2846 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2847 gfc_add_block_to_block (pblock, &se.pre);
2851 se.expr = gfc_index_one_node;
2855 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2856 gfc_add_modify_expr (pblock, tmp, se.expr);
2858 /* Work out the offset for this component. */
2859 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2860 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2862 /* Start the calculation for the size of this dimension. */
2863 size = build2 (MINUS_EXPR, gfc_array_index_type,
2864 gfc_index_one_node, se.expr);
2866 /* Set upper bound. */
2867 gfc_init_se (&se, NULL);
2868 gcc_assert (ubound);
2869 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2870 gfc_add_block_to_block (pblock, &se.pre);
2872 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2873 gfc_add_modify_expr (pblock, tmp, se.expr);
2875 /* Store the stride. */
2876 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2877 gfc_add_modify_expr (pblock, tmp, stride);
2879 /* Calculate the size of this dimension. */
2880 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2882 /* Multiply the stride by the number of elements in this dimension. */
2883 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2884 stride = gfc_evaluate_now (stride, pblock);
2887 /* The stride is the number of elements in the array, so multiply by the
2888 size of an element to get the total size. */
2889 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2890 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2892 if (poffset != NULL)
2894 offset = gfc_evaluate_now (offset, pblock);
2898 size = gfc_evaluate_now (size, pblock);
2903 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2904 the work for an ALLOCATE statement. */
2908 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2918 /* Figure out the size of the array. */
2919 switch (ref->u.ar.type)
2923 upper = ref->u.ar.start;
2927 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2929 lower = ref->u.ar.as->lower;
2930 upper = ref->u.ar.as->upper;
2934 lower = ref->u.ar.start;
2935 upper = ref->u.ar.end;
2943 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2944 lower, upper, &se->pre);
2946 /* Allocate memory to store the data. */
2947 tmp = gfc_conv_descriptor_data_addr (se->expr);
2948 pointer = gfc_evaluate_now (tmp, &se->pre);
2950 if (TYPE_PRECISION (gfc_array_index_type) == 32)
2951 allocate = gfor_fndecl_allocate;
2952 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2953 allocate = gfor_fndecl_allocate64;
2957 tmp = gfc_chainon_list (NULL_TREE, pointer);
2958 tmp = gfc_chainon_list (tmp, size);
2959 tmp = gfc_chainon_list (tmp, pstat);
2960 tmp = gfc_build_function_call (allocate, tmp);
2961 gfc_add_expr_to_block (&se->pre, tmp);
2963 tmp = gfc_conv_descriptor_offset (se->expr);
2964 gfc_add_modify_expr (&se->pre, tmp, offset);
2968 /* Deallocate an array variable. Also used when an allocated variable goes
2973 gfc_array_deallocate (tree descriptor, tree pstat)
2979 gfc_start_block (&block);
2980 /* Get a pointer to the data. */
2981 tmp = gfc_conv_descriptor_data_addr (descriptor);
2982 var = gfc_evaluate_now (tmp, &block);
2984 /* Parameter is the address of the data component. */
2985 tmp = gfc_chainon_list (NULL_TREE, var);
2986 tmp = gfc_chainon_list (tmp, pstat);
2987 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2988 gfc_add_expr_to_block (&block, tmp);
2990 return gfc_finish_block (&block);
2994 /* Create an array constructor from an initialization expression.
2995 We assume the frontend already did any expansions and conversions. */
2998 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3005 unsigned HOST_WIDE_INT lo;
3007 VEC(constructor_elt,gc) *v = NULL;
3009 switch (expr->expr_type)
3012 case EXPR_STRUCTURE:
3013 /* A single scalar or derived type value. Create an array with all
3014 elements equal to that value. */
3015 gfc_init_se (&se, NULL);
3017 if (expr->expr_type == EXPR_CONSTANT)
3018 gfc_conv_constant (&se, expr);
3020 gfc_conv_structure (&se, expr, 1);
3022 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3023 gcc_assert (tmp && INTEGER_CST_P (tmp));
3024 hi = TREE_INT_CST_HIGH (tmp);
3025 lo = TREE_INT_CST_LOW (tmp);
3029 /* This will probably eat buckets of memory for large arrays. */
3030 while (hi != 0 || lo != 0)
3032 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3040 /* Create a vector of all the elements. */
3041 for (c = expr->value.constructor; c; c = c->next)
3045 /* Problems occur when we get something like
3046 integer :: a(lots) = (/(i, i=1,lots)/) */
3047 /* TODO: Unexpanded array initializers. */
3049 ("Possible frontend bug: array constructor not expanded");
3051 if (mpz_cmp_si (c->n.offset, 0) != 0)
3052 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3056 if (mpz_cmp_si (c->repeat, 0) != 0)
3060 mpz_set (maxval, c->repeat);
3061 mpz_add (maxval, c->n.offset, maxval);
3062 mpz_sub_ui (maxval, maxval, 1);
3063 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3064 if (mpz_cmp_si (c->n.offset, 0) != 0)
3066 mpz_add_ui (maxval, c->n.offset, 1);
3067 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3070 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3072 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3078 gfc_init_se (&se, NULL);
3079 switch (c->expr->expr_type)
3082 gfc_conv_constant (&se, c->expr);
3083 if (range == NULL_TREE)
3084 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3087 if (index != NULL_TREE)
3088 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3089 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3093 case EXPR_STRUCTURE:
3094 gfc_conv_structure (&se, c->expr, 1);
3095 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3108 /* Create a constructor from the list of elements. */
3109 tmp = build_constructor (type, v);
3110 TREE_CONSTANT (tmp) = 1;
3111 TREE_INVARIANT (tmp) = 1;
3116 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3117 returns the size (in elements) of the array. */
3120 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3121 stmtblock_t * pblock)
3136 size = gfc_index_one_node;
3137 offset = gfc_index_zero_node;
3138 for (dim = 0; dim < as->rank; dim++)
3140 /* Evaluate non-constant array bound expressions. */
3141 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3142 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3144 gfc_init_se (&se, NULL);
3145 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3146 gfc_add_block_to_block (pblock, &se.pre);
3147 gfc_add_modify_expr (pblock, lbound, se.expr);
3149 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3150 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3152 gfc_init_se (&se, NULL);
3153 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3154 gfc_add_block_to_block (pblock, &se.pre);
3155 gfc_add_modify_expr (pblock, ubound, se.expr);
3157 /* The offset of this dimension. offset = offset - lbound * stride. */
3158 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3159 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3161 /* The size of this dimension, and the stride of the next. */
3162 if (dim + 1 < as->rank)
3163 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3167 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3169 /* Calculate stride = size * (ubound + 1 - lbound). */
3170 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3171 gfc_index_one_node, lbound);
3172 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3173 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3175 gfc_add_modify_expr (pblock, stride, tmp);
3177 stride = gfc_evaluate_now (tmp, pblock);
3188 /* Generate code to initialize/allocate an array variable. */
3191 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3201 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3203 /* Do nothing for USEd variables. */
3204 if (sym->attr.use_assoc)
3207 type = TREE_TYPE (decl);
3208 gcc_assert (GFC_ARRAY_TYPE_P (type));
3209 onstack = TREE_CODE (type) != POINTER_TYPE;
3211 gfc_start_block (&block);
3213 /* Evaluate character string length. */
3214 if (sym->ts.type == BT_CHARACTER
3215 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3217 gfc_trans_init_string_length (sym->ts.cl, &block);
3219 /* Emit a DECL_EXPR for this variable, which will cause the
3220 gimplifier to allocate storage, and all that good stuff. */
3221 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3222 gfc_add_expr_to_block (&block, tmp);
3227 gfc_add_expr_to_block (&block, fnbody);
3228 return gfc_finish_block (&block);
3231 type = TREE_TYPE (type);
3233 gcc_assert (!sym->attr.use_assoc);
3234 gcc_assert (!TREE_STATIC (decl));
3235 gcc_assert (!sym->module);
3237 if (sym->ts.type == BT_CHARACTER
3238 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3239 gfc_trans_init_string_length (sym->ts.cl, &block);
3241 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3243 /* The size is the number of elements in the array, so multiply by the
3244 size of an element to get the total size. */
3245 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3246 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3248 /* Allocate memory to hold the data. */
3249 tmp = gfc_chainon_list (NULL_TREE, size);
3251 if (gfc_index_integer_kind == 4)
3252 fndecl = gfor_fndecl_internal_malloc;
3253 else if (gfc_index_integer_kind == 8)
3254 fndecl = gfor_fndecl_internal_malloc64;
3257 tmp = gfc_build_function_call (fndecl, tmp);
3258 tmp = fold (convert (TREE_TYPE (decl), tmp));
3259 gfc_add_modify_expr (&block, decl, tmp);
3261 /* Set offset of the array. */
3262 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3263 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3266 /* Automatic arrays should not have initializers. */
3267 gcc_assert (!sym->value);
3269 gfc_add_expr_to_block (&block, fnbody);
3271 /* Free the temporary. */
3272 tmp = convert (pvoid_type_node, decl);
3273 tmp = gfc_chainon_list (NULL_TREE, tmp);
3274 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3275 gfc_add_expr_to_block (&block, tmp);
3277 return gfc_finish_block (&block);
3281 /* Generate entry and exit code for g77 calling convention arrays. */
3284 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3293 gfc_get_backend_locus (&loc);
3294 gfc_set_backend_locus (&sym->declared_at);
3296 /* Descriptor type. */
3297 parm = sym->backend_decl;
3298 type = TREE_TYPE (parm);
3299 gcc_assert (GFC_ARRAY_TYPE_P (type));
3301 gfc_start_block (&block);
3303 if (sym->ts.type == BT_CHARACTER
3304 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3305 gfc_trans_init_string_length (sym->ts.cl, &block);
3307 /* Evaluate the bounds of the array. */
3308 gfc_trans_array_bounds (type, sym, &offset, &block);
3310 /* Set the offset. */
3311 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3312 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3314 /* Set the pointer itself if we aren't using the parameter directly. */
3315 if (TREE_CODE (parm) != PARM_DECL)
3317 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3318 gfc_add_modify_expr (&block, parm, tmp);
3320 tmp = gfc_finish_block (&block);
3322 gfc_set_backend_locus (&loc);
3324 gfc_start_block (&block);
3325 /* Add the initialization code to the start of the function. */
3326 gfc_add_expr_to_block (&block, tmp);
3327 gfc_add_expr_to_block (&block, body);
3329 return gfc_finish_block (&block);
3333 /* Modify the descriptor of an array parameter so that it has the
3334 correct lower bound. Also move the upper bound accordingly.
3335 If the array is not packed, it will be copied into a temporary.
3336 For each dimension we set the new lower and upper bounds. Then we copy the
3337 stride and calculate the offset for this dimension. We also work out
3338 what the stride of a packed array would be, and see it the two match.
3339 If the array need repacking, we set the stride to the values we just
3340 calculated, recalculate the offset and copy the array data.
3341 Code is also added to copy the data back at the end of the function.
3345 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3352 stmtblock_t cleanup;
3370 /* Do nothing for pointer and allocatable arrays. */
3371 if (sym->attr.pointer || sym->attr.allocatable)
3374 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3375 return gfc_trans_g77_array (sym, body);
3377 gfc_get_backend_locus (&loc);
3378 gfc_set_backend_locus (&sym->declared_at);
3380 /* Descriptor type. */
3381 type = TREE_TYPE (tmpdesc);
3382 gcc_assert (GFC_ARRAY_TYPE_P (type));
3383 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3384 dumdesc = gfc_build_indirect_ref (dumdesc);
3385 gfc_start_block (&block);
3387 if (sym->ts.type == BT_CHARACTER
3388 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3389 gfc_trans_init_string_length (sym->ts.cl, &block);
3391 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3393 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3394 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3396 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3398 /* For non-constant shape arrays we only check if the first dimension
3399 is contiguous. Repacking higher dimensions wouldn't gain us
3400 anything as we still don't know the array stride. */
3401 partial = gfc_create_var (boolean_type_node, "partial");
3402 TREE_USED (partial) = 1;
3403 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3404 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3405 gfc_add_modify_expr (&block, partial, tmp);
3409 partial = NULL_TREE;
3412 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3413 here, however I think it does the right thing. */
3416 /* Set the first stride. */
3417 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3418 stride = gfc_evaluate_now (stride, &block);
3420 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3421 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3422 gfc_index_one_node, stride);
3423 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3424 gfc_add_modify_expr (&block, stride, tmp);
3426 /* Allow the user to disable array repacking. */
3427 stmt_unpacked = NULL_TREE;
3431 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3432 /* A library call to repack the array if necessary. */
3433 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3434 tmp = gfc_chainon_list (NULL_TREE, tmp);
3435 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3437 stride = gfc_index_one_node;
3440 /* This is for the case where the array data is used directly without
3441 calling the repack function. */
3442 if (no_repack || partial != NULL_TREE)
3443 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3445 stmt_packed = NULL_TREE;
3447 /* Assign the data pointer. */
3448 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3450 /* Don't repack unknown shape arrays when the first stride is 1. */
3451 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3452 stmt_packed, stmt_unpacked);
3455 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3456 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3458 offset = gfc_index_zero_node;
3459 size = gfc_index_one_node;
3461 /* Evaluate the bounds of the array. */
3462 for (n = 0; n < sym->as->rank; n++)
3464 if (checkparm || !sym->as->upper[n])
3466 /* Get the bounds of the actual parameter. */
3467 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3468 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3472 dubound = NULL_TREE;
3473 dlbound = NULL_TREE;
3476 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3477 if (!INTEGER_CST_P (lbound))
3479 gfc_init_se (&se, NULL);
3480 gfc_conv_expr_type (&se, sym->as->upper[n],
3481 gfc_array_index_type);
3482 gfc_add_block_to_block (&block, &se.pre);
3483 gfc_add_modify_expr (&block, lbound, se.expr);
3486 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3487 /* Set the desired upper bound. */
3488 if (sym->as->upper[n])
3490 /* We know what we want the upper bound to be. */
3491 if (!INTEGER_CST_P (ubound))
3493 gfc_init_se (&se, NULL);
3494 gfc_conv_expr_type (&se, sym->as->upper[n],
3495 gfc_array_index_type);
3496 gfc_add_block_to_block (&block, &se.pre);
3497 gfc_add_modify_expr (&block, ubound, se.expr);
3500 /* Check the sizes match. */
3503 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3505 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3507 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3509 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3510 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3515 /* For assumed shape arrays move the upper bound by the same amount
3516 as the lower bound. */
3517 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3518 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3519 gfc_add_modify_expr (&block, ubound, tmp);
3521 /* The offset of this dimension. offset = offset - lbound * stride. */
3522 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3523 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3525 /* The size of this dimension, and the stride of the next. */
3526 if (n + 1 < sym->as->rank)
3528 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3530 if (no_repack || partial != NULL_TREE)
3533 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3536 /* Figure out the stride if not a known constant. */
3537 if (!INTEGER_CST_P (stride))
3540 stmt_packed = NULL_TREE;
3543 /* Calculate stride = size * (ubound + 1 - lbound). */
3544 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3545 gfc_index_one_node, lbound);
3546 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3548 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3553 /* Assign the stride. */
3554 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3555 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3556 stmt_unpacked, stmt_packed);
3558 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3559 gfc_add_modify_expr (&block, stride, tmp);
3564 /* Set the offset. */
3565 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3566 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3568 stmt = gfc_finish_block (&block);
3570 gfc_start_block (&block);
3572 /* Only do the entry/initialization code if the arg is present. */
3573 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3574 optional_arg = (sym->attr.optional
3575 || (sym->ns->proc_name->attr.entry_master
3576 && sym->attr.dummy));
3579 tmp = gfc_conv_expr_present (sym);
3580 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3582 gfc_add_expr_to_block (&block, stmt);
3584 /* Add the main function body. */
3585 gfc_add_expr_to_block (&block, body);
3590 gfc_start_block (&cleanup);
3592 if (sym->attr.intent != INTENT_IN)
3594 /* Copy the data back. */
3595 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3596 tmp = gfc_chainon_list (tmp, tmpdesc);
3597 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3598 gfc_add_expr_to_block (&cleanup, tmp);
3601 /* Free the temporary. */
3602 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3603 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3604 gfc_add_expr_to_block (&cleanup, tmp);
3606 stmt = gfc_finish_block (&cleanup);
3608 /* Only do the cleanup if the array was repacked. */
3609 tmp = gfc_build_indirect_ref (dumdesc);
3610 tmp = gfc_conv_descriptor_data_get (tmp);
3611 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3612 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3616 tmp = gfc_conv_expr_present (sym);
3617 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3619 gfc_add_expr_to_block (&block, stmt);
3621 /* We don't need to free any memory allocated by internal_pack as it will
3622 be freed at the end of the function by pop_context. */
3623 return gfc_finish_block (&block);
3627 /* Convert an array for passing as an actual argument. Expressions and
3628 vector subscripts are evaluated and stored in a temporary, which is then
3629 passed. For whole arrays the descriptor is passed. For array sections
3630 a modified copy of the descriptor is passed, but using the original data.
3632 This function is also used for array pointer assignments, and there
3635 - want_pointer && !se->direct_byref
3636 EXPR is an actual argument. On exit, se->expr contains a
3637 pointer to the array descriptor.
3639 - !want_pointer && !se->direct_byref
3640 EXPR is an actual argument to an intrinsic function or the
3641 left-hand side of a pointer assignment. On exit, se->expr
3642 contains the descriptor for EXPR.
3644 - !want_pointer && se->direct_byref
3645 EXPR is the right-hand side of a pointer assignment and
3646 se->expr is the descriptor for the previously-evaluated
3647 left-hand side. The function creates an assignment from
3648 EXPR to se->expr. */
3651 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3666 gcc_assert (ss != gfc_ss_terminator);
3668 /* TODO: Pass constant array constructors without a temporary. */
3669 /* Special case things we know we can pass easily. */
3670 switch (expr->expr_type)
3673 /* If we have a linear array section, we can pass it directly.
3674 Otherwise we need to copy it into a temporary. */
3676 /* Find the SS for the array section. */
3678 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3679 secss = secss->next;
3681 gcc_assert (secss != gfc_ss_terminator);
3682 info = &secss->data.info;
3684 /* Get the descriptor for the array. */
3685 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3686 desc = info->descriptor;
3688 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
3691 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3693 /* Create a new descriptor if the array doesn't have one. */
3696 else if (info->ref->u.ar.type == AR_FULL)
3698 else if (se->direct_byref)
3703 gcc_assert (ref->u.ar.type == AR_SECTION);
3706 for (n = 0; n < ref->u.ar.dimen; n++)
3708 /* Detect passing the full array as a section. This could do
3709 even more checking, but it doesn't seem worth it. */
3710 if (ref->u.ar.start[n]
3712 || (ref->u.ar.stride[n]
3713 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3723 if (se->direct_byref)
3725 /* Copy the descriptor for pointer assignments. */
3726 gfc_add_modify_expr (&se->pre, se->expr, desc);
3728 else if (se->want_pointer)
3730 /* We pass full arrays directly. This means that pointers and
3731 allocatable arrays should also work. */
3732 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3739 if (expr->ts.type == BT_CHARACTER)
3740 se->string_length = gfc_get_expr_charlen (expr);
3747 /* A transformational function return value will be a temporary
3748 array descriptor. We still need to go through the scalarizer
3749 to create the descriptor. Elemental functions ar handled as
3750 arbitrary expressions, i.e. copy to a temporary. */
3752 /* Look for the SS for this function. */
3753 while (secss != gfc_ss_terminator
3754 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3755 secss = secss->next;
3757 if (se->direct_byref)
3759 gcc_assert (secss != gfc_ss_terminator);
3761 /* For pointer assignments pass the descriptor directly. */
3763 se->expr = gfc_build_addr_expr (NULL, se->expr);
3764 gfc_conv_expr (se, expr);
3768 if (secss == gfc_ss_terminator)
3770 /* Elemental function. */
3776 /* Transformational function. */
3777 info = &secss->data.info;
3783 /* Something complicated. Copy it into a temporary. */
3791 gfc_init_loopinfo (&loop);
3793 /* Associate the SS with the loop. */
3794 gfc_add_ss_to_loop (&loop, ss);
3796 /* Tell the scalarizer not to bother creating loop variables, etc. */
3798 loop.array_parameter = 1;
3800 /* The right-hand side of a pointer assignment mustn't use a temporary. */
3801 gcc_assert (!se->direct_byref);
3803 /* Setup the scalarizing loops and bounds. */
3804 gfc_conv_ss_startstride (&loop);
3808 /* Tell the scalarizer to make a temporary. */
3809 loop.temp_ss = gfc_get_ss ();
3810 loop.temp_ss->type = GFC_SS_TEMP;
3811 loop.temp_ss->next = gfc_ss_terminator;
3812 if (expr->ts.type == BT_CHARACTER)
3814 gcc_assert (expr->ts.cl && expr->ts.cl->length
3815 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3816 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3817 (expr->ts.cl->length->value.integer,
3818 expr->ts.cl->length->ts.kind);
3819 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3821 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3823 /* ... which can hold our string, if present. */
3824 if (expr->ts.type == BT_CHARACTER)
3826 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3827 se->string_length = loop.temp_ss->string_length;
3830 loop.temp_ss->string_length = NULL;
3831 loop.temp_ss->data.temp.dimen = loop.dimen;
3832 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3835 gfc_conv_loop_setup (&loop);
3839 /* Copy into a temporary and pass that. We don't need to copy the data
3840 back because expressions and vector subscripts must be INTENT_IN. */
3841 /* TODO: Optimize passing function return values. */
3845 /* Start the copying loops. */
3846 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3847 gfc_mark_ss_chain_used (ss, 1);
3848 gfc_start_scalarized_body (&loop, &block);
3850 /* Copy each data element. */
3851 gfc_init_se (&lse, NULL);
3852 gfc_copy_loopinfo_to_se (&lse, &loop);
3853 gfc_init_se (&rse, NULL);
3854 gfc_copy_loopinfo_to_se (&rse, &loop);
3856 lse.ss = loop.temp_ss;
3859 gfc_conv_scalarized_array_ref (&lse, NULL);
3860 if (expr->ts.type == BT_CHARACTER)
3862 gfc_conv_expr (&rse, expr);
3863 rse.expr = gfc_build_indirect_ref (rse.expr);
3866 gfc_conv_expr_val (&rse, expr);
3868 gfc_add_block_to_block (&block, &rse.pre);
3869 gfc_add_block_to_block (&block, &lse.pre);
3871 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3873 /* Finish the copying loops. */
3874 gfc_trans_scalarizing_loops (&loop, &block);
3876 /* Set the first stride component to zero to indicate a temporary. */
3877 desc = loop.temp_ss->data.info.descriptor;
3878 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3879 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3881 gcc_assert (is_gimple_lvalue (desc));
3883 else if (expr->expr_type == EXPR_FUNCTION)
3885 desc = info->descriptor;
3886 se->string_length = ss->string_length;
3890 /* We pass sections without copying to a temporary. Make a new
3891 descriptor and point it at the section we want. The loop variable
3892 limits will be the limits of the section.
3893 A function may decide to repack the array to speed up access, but
3894 we're not bothered about that here. */
3903 /* Set the string_length for a character array. */
3904 if (expr->ts.type == BT_CHARACTER)
3905 se->string_length = gfc_get_expr_charlen (expr);
3907 desc = info->descriptor;
3908 gcc_assert (secss && secss != gfc_ss_terminator);
3909 if (se->direct_byref)
3911 /* For pointer assignments we fill in the destination. */
3913 parmtype = TREE_TYPE (parm);
3917 /* Otherwise make a new one. */
3918 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3919 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3920 loop.from, loop.to, 0);
3921 parm = gfc_create_var (parmtype, "parm");
3924 offset = gfc_index_zero_node;
3927 /* The following can be somewhat confusing. We have two
3928 descriptors, a new one and the original array.
3929 {parm, parmtype, dim} refer to the new one.
3930 {desc, type, n, secss, loop} refer to the original, which maybe
3931 a descriptorless array.
3932 The bounds of the scalarization are the bounds of the section.
3933 We don't have to worry about numeric overflows when calculating
3934 the offsets because all elements are within the array data. */
3936 /* Set the dtype. */
3937 tmp = gfc_conv_descriptor_dtype (parm);
3938 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
3940 if (se->direct_byref)
3941 base = gfc_index_zero_node;
3945 for (n = 0; n < info->ref->u.ar.dimen; n++)
3947 stride = gfc_conv_array_stride (desc, n);
3949 /* Work out the offset. */
3950 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3952 gcc_assert (info->subscript[n]
3953 && info->subscript[n]->type == GFC_SS_SCALAR);
3954 start = info->subscript[n]->data.scalar.expr;
3958 /* Check we haven't somehow got out of sync. */
3959 gcc_assert (info->dim[dim] == n);
3961 /* Evaluate and remember the start of the section. */
3962 start = info->start[dim];
3963 stride = gfc_evaluate_now (stride, &loop.pre);
3966 tmp = gfc_conv_array_lbound (desc, n);
3967 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
3969 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
3970 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
3972 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3974 /* For elemental dimensions, we only need the offset. */
3978 /* Vector subscripts need copying and are handled elsewhere. */
3979 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
3981 /* Set the new lower bound. */
3982 from = loop.from[dim];
3984 if (!integer_onep (from))
3986 /* Make sure the new section starts at 1. */
3987 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3988 gfc_index_one_node, from);
3989 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
3990 from = gfc_index_one_node;
3992 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
3993 gfc_add_modify_expr (&loop.pre, tmp, from);
3995 /* Set the new upper bound. */
3996 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
3997 gfc_add_modify_expr (&loop.pre, tmp, to);
3999 /* Multiply the stride by the section stride to get the
4001 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4002 stride, info->stride[dim]);
4004 if (se->direct_byref)
4005 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4008 /* Store the new stride. */
4009 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4010 gfc_add_modify_expr (&loop.pre, tmp, stride);
4015 /* Point the data pointer at the first element in the section. */
4016 tmp = gfc_conv_array_data (desc);
4017 tmp = gfc_build_indirect_ref (tmp);
4018 tmp = gfc_build_array_ref (tmp, offset);
4019 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4020 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4022 if (se->direct_byref)
4024 /* Set the offset. */
4025 tmp = gfc_conv_descriptor_offset (parm);
4026 gfc_add_modify_expr (&loop.pre, tmp, base);
4030 /* Only the callee knows what the correct offset it, so just set
4032 tmp = gfc_conv_descriptor_offset (parm);
4033 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4038 if (!se->direct_byref)
4040 /* Get a pointer to the new descriptor. */
4041 if (se->want_pointer)
4042 se->expr = gfc_build_addr_expr (NULL, desc);
4047 gfc_add_block_to_block (&se->pre, &loop.pre);
4048 gfc_add_block_to_block (&se->post, &loop.post);
4050 /* Cleanup the scalarizer. */
4051 gfc_cleanup_loop (&loop);
4055 /* Convert an array for passing as an actual parameter. */
4056 /* TODO: Optimize passing g77 arrays. */
4059 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4068 /* Passing address of the array if it is not pointer or assumed-shape. */
4069 if (expr->expr_type == EXPR_VARIABLE
4070 && expr->ref->u.ar.type == AR_FULL && g77)
4072 sym = expr->symtree->n.sym;
4073 tmp = gfc_get_symbol_decl (sym);
4074 if (sym->ts.type == BT_CHARACTER)
4075 se->string_length = sym->ts.cl->backend_decl;
4076 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4077 && !sym->attr.allocatable)
4079 /* Some variables are declared directly, others are declared as
4080 pointers and allocated on the heap. */
4081 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4084 se->expr = gfc_build_addr_expr (NULL, tmp);
4087 if (sym->attr.allocatable)
4089 se->expr = gfc_conv_array_data (tmp);
4094 se->want_pointer = 1;
4095 gfc_conv_expr_descriptor (se, expr, ss);
4100 /* Repack the array. */
4101 tmp = gfc_chainon_list (NULL_TREE, desc);
4102 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
4103 ptr = gfc_evaluate_now (ptr, &se->pre);
4106 gfc_start_block (&block);
4108 /* Copy the data back. */
4109 tmp = gfc_chainon_list (NULL_TREE, desc);
4110 tmp = gfc_chainon_list (tmp, ptr);
4111 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
4112 gfc_add_expr_to_block (&block, tmp);
4114 /* Free the temporary. */
4115 tmp = convert (pvoid_type_node, ptr);
4116 tmp = gfc_chainon_list (NULL_TREE, tmp);
4117 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
4118 gfc_add_expr_to_block (&block, tmp);
4120 stmt = gfc_finish_block (&block);
4122 gfc_init_block (&block);
4123 /* Only if it was repacked. This code needs to be executed before the
4124 loop cleanup code. */
4125 tmp = gfc_build_indirect_ref (desc);
4126 tmp = gfc_conv_array_data (tmp);
4127 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4128 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4130 gfc_add_expr_to_block (&block, tmp);
4131 gfc_add_block_to_block (&block, &se->post);
4133 gfc_init_block (&se->post);
4134 gfc_add_block_to_block (&se->post, &block);
4139 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4142 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4149 stmtblock_t fnblock;
4152 /* Make sure the frontend gets these right. */
4153 if (!(sym->attr.pointer || sym->attr.allocatable))
4155 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4157 gfc_init_block (&fnblock);
4159 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
4160 if (sym->ts.type == BT_CHARACTER
4161 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4162 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4164 /* Dummy and use associated variables don't need anything special. */
4165 if (sym->attr.dummy || sym->attr.use_assoc)
4167 gfc_add_expr_to_block (&fnblock, body);
4169 return gfc_finish_block (&fnblock);
4172 gfc_get_backend_locus (&loc);
4173 gfc_set_backend_locus (&sym->declared_at);
4174 descriptor = sym->backend_decl;
4176 if (TREE_STATIC (descriptor))
4178 /* SAVEd variables are not freed on exit. */
4179 gfc_trans_static_array_pointer (sym);
4183 /* Get the descriptor type. */
4184 type = TREE_TYPE (sym->backend_decl);
4185 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4187 /* NULLIFY the data pointer. */
4188 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4190 gfc_add_expr_to_block (&fnblock, body);
4192 gfc_set_backend_locus (&loc);
4193 /* Allocatable arrays need to be freed when they go out of scope. */
4194 if (sym->attr.allocatable)
4196 gfc_start_block (&block);
4198 /* Deallocate if still allocated at the end of the procedure. */
4199 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4201 tmp = gfc_conv_descriptor_data_get (descriptor);
4202 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4203 build_int_cst (TREE_TYPE (tmp), 0));
4204 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4205 gfc_add_expr_to_block (&block, tmp);
4207 tmp = gfc_finish_block (&block);
4208 gfc_add_expr_to_block (&fnblock, tmp);
4211 return gfc_finish_block (&fnblock);
4214 /************ Expression Walking Functions ******************/
4216 /* Walk a variable reference.
4218 Possible extension - multiple component subscripts.
4219 x(:,:) = foo%a(:)%b(:)
4221 forall (i=..., j=...)
4222 x(i,j) = foo%a(j)%b(i)
4224 This adds a fair amout of complexity because you need to deal with more
4225 than one ref. Maybe handle in a similar manner to vector subscripts.
4226 Maybe not worth the effort. */
4230 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4238 for (ref = expr->ref; ref; ref = ref->next)
4239 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4242 for (; ref; ref = ref->next)
4244 if (ref->type == REF_SUBSTRING)
4246 newss = gfc_get_ss ();
4247 newss->type = GFC_SS_SCALAR;
4248 newss->expr = ref->u.ss.start;
4252 newss = gfc_get_ss ();
4253 newss->type = GFC_SS_SCALAR;
4254 newss->expr = ref->u.ss.end;
4259 /* We're only interested in array sections from now on. */
4260 if (ref->type != REF_ARRAY)
4267 for (n = 0; n < ar->dimen; n++)
4269 newss = gfc_get_ss ();
4270 newss->type = GFC_SS_SCALAR;
4271 newss->expr = ar->start[n];
4278 newss = gfc_get_ss ();
4279 newss->type = GFC_SS_SECTION;
4282 newss->data.info.dimen = ar->as->rank;
4283 newss->data.info.ref = ref;
4285 /* Make sure array is the same as array(:,:), this way
4286 we don't need to special case all the time. */
4287 ar->dimen = ar->as->rank;
4288 for (n = 0; n < ar->dimen; n++)
4290 newss->data.info.dim[n] = n;
4291 ar->dimen_type[n] = DIMEN_RANGE;
4293 gcc_assert (ar->start[n] == NULL);
4294 gcc_assert (ar->end[n] == NULL);
4295 gcc_assert (ar->stride[n] == NULL);
4301 newss = gfc_get_ss ();
4302 newss->type = GFC_SS_SECTION;
4305 newss->data.info.dimen = 0;
4306 newss->data.info.ref = ref;
4310 /* We add SS chains for all the subscripts in the section. */
4311 for (n = 0; n < ar->dimen; n++)
4315 switch (ar->dimen_type[n])
4318 /* Add SS for elemental (scalar) subscripts. */
4319 gcc_assert (ar->start[n]);
4320 indexss = gfc_get_ss ();
4321 indexss->type = GFC_SS_SCALAR;
4322 indexss->expr = ar->start[n];
4323 indexss->next = gfc_ss_terminator;
4324 indexss->loop_chain = gfc_ss_terminator;
4325 newss->data.info.subscript[n] = indexss;
4329 /* We don't add anything for sections, just remember this
4330 dimension for later. */
4331 newss->data.info.dim[newss->data.info.dimen] = n;
4332 newss->data.info.dimen++;
4336 /* Create a GFC_SS_VECTOR index in which we can store
4337 the vector's descriptor. */
4338 indexss = gfc_get_ss ();
4339 indexss->type = GFC_SS_VECTOR;
4340 indexss->expr = ar->start[n];
4341 indexss->next = gfc_ss_terminator;
4342 indexss->loop_chain = gfc_ss_terminator;
4343 newss->data.info.subscript[n] = indexss;
4344 newss->data.info.dim[newss->data.info.dimen] = n;
4345 newss->data.info.dimen++;
4349 /* We should know what sort of section it is by now. */
4353 /* We should have at least one non-elemental dimension. */
4354 gcc_assert (newss->data.info.dimen > 0);
4359 /* We should know what sort of section it is by now. */
4368 /* Walk an expression operator. If only one operand of a binary expression is
4369 scalar, we must also add the scalar term to the SS chain. */
4372 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4378 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4379 if (expr->value.op.op2 == NULL)
4382 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4384 /* All operands are scalar. Pass back and let the caller deal with it. */
4388 /* All operands require scalarization. */
4389 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4392 /* One of the operands needs scalarization, the other is scalar.
4393 Create a gfc_ss for the scalar expression. */
4394 newss = gfc_get_ss ();
4395 newss->type = GFC_SS_SCALAR;
4398 /* First operand is scalar. We build the chain in reverse order, so
4399 add the scarar SS after the second operand. */
4401 while (head && head->next != ss)
4403 /* Check we haven't somehow broken the chain. */
4407 newss->expr = expr->value.op.op1;
4409 else /* head2 == head */
4411 gcc_assert (head2 == head);
4412 /* Second operand is scalar. */
4413 newss->next = head2;
4415 newss->expr = expr->value.op.op2;
4422 /* Reverse a SS chain. */
4425 gfc_reverse_ss (gfc_ss * ss)
4430 gcc_assert (ss != NULL);
4432 head = gfc_ss_terminator;
4433 while (ss != gfc_ss_terminator)
4436 /* Check we didn't somehow break the chain. */
4437 gcc_assert (next != NULL);
4447 /* Walk the arguments of an elemental function. */
4450 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4453 gfc_actual_arglist *arg;
4459 head = gfc_ss_terminator;
4462 for (arg = expr->value.function.actual; arg; arg = arg->next)
4467 newss = gfc_walk_subexpr (head, arg->expr);
4470 /* Scalar argument. */
4471 newss = gfc_get_ss ();
4473 newss->expr = arg->expr;
4483 while (tail->next != gfc_ss_terminator)
4490 /* If all the arguments are scalar we don't need the argument SS. */
4491 gfc_free_ss_chain (head);
4496 /* Add it onto the existing chain. */
4502 /* Walk a function call. Scalar functions are passed back, and taken out of
4503 scalarization loops. For elemental functions we walk their arguments.
4504 The result of functions returning arrays is stored in a temporary outside
4505 the loop, so that the function is only called once. Hence we do not need
4506 to walk their arguments. */
4509 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4512 gfc_intrinsic_sym *isym;
4515 isym = expr->value.function.isym;
4517 /* Handle intrinsic functions separately. */
4519 return gfc_walk_intrinsic_function (ss, expr, isym);
4521 sym = expr->value.function.esym;
4523 sym = expr->symtree->n.sym;
4525 /* A function that returns arrays. */
4526 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4528 newss = gfc_get_ss ();
4529 newss->type = GFC_SS_FUNCTION;
4532 newss->data.info.dimen = expr->rank;
4536 /* Walk the parameters of an elemental function. For now we always pass
4538 if (sym->attr.elemental)
4539 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4541 /* Scalar functions are OK as these are evaluated outside the scalarization
4542 loop. Pass back and let the caller deal with it. */
4547 /* An array temporary is constructed for array constructors. */
4550 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4555 newss = gfc_get_ss ();
4556 newss->type = GFC_SS_CONSTRUCTOR;
4559 newss->data.info.dimen = expr->rank;
4560 for (n = 0; n < expr->rank; n++)
4561 newss->data.info.dim[n] = n;
4567 /* Walk an expression. Add walked expressions to the head of the SS chain.
4568 A wholly scalar expression will not be added. */
4571 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4575 switch (expr->expr_type)
4578 head = gfc_walk_variable_expr (ss, expr);
4582 head = gfc_walk_op_expr (ss, expr);
4586 head = gfc_walk_function_expr (ss, expr);
4591 case EXPR_STRUCTURE:
4592 /* Pass back and let the caller deal with it. */
4596 head = gfc_walk_array_constructor (ss, expr);
4599 case EXPR_SUBSTRING:
4600 /* Pass back and let the caller deal with it. */
4604 internal_error ("bad expression type during walk (%d)",
4611 /* Entry point for expression walking.
4612 A return value equal to the passed chain means this is
4613 a scalar expression. It is up to the caller to take whatever action is
4614 necessary to translate these. */
4617 gfc_walk_expr (gfc_expr * expr)
4621 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4622 return gfc_reverse_ss (res);