1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subecripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "tree-gimple.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
106 gfc_array_dataptr_type (tree desc)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc)
147 type = TREE_TYPE (desc);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
150 field = TYPE_FIELDS (type);
151 gcc_assert (DATA_FIELD == 0);
153 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set_tuples. */
168 gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
169 tree desc, tree value,
174 type = TREE_TYPE (desc);
175 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
177 field = TYPE_FIELDS (type);
178 gcc_assert (DATA_FIELD == 0);
180 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
181 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
185 /* This provides address access to the data field. This should only be
186 used by array allocation, passing this on to the runtime. */
189 gfc_conv_descriptor_data_addr (tree desc)
193 type = TREE_TYPE (desc);
194 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
196 field = TYPE_FIELDS (type);
197 gcc_assert (DATA_FIELD == 0);
199 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
200 return build_fold_addr_expr (t);
204 gfc_conv_descriptor_offset (tree desc)
209 type = TREE_TYPE (desc);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
212 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
213 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
215 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
219 gfc_conv_descriptor_dtype (tree desc)
224 type = TREE_TYPE (desc);
225 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
227 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
228 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
230 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
234 gfc_conv_descriptor_dimension (tree desc, tree dim)
240 type = TREE_TYPE (desc);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
243 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
244 gcc_assert (field != NULL_TREE
245 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
246 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
248 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
249 tmp = gfc_build_array_ref (tmp, dim);
254 gfc_conv_descriptor_stride (tree desc, tree dim)
259 tmp = gfc_conv_descriptor_dimension (desc, dim);
260 field = TYPE_FIELDS (TREE_TYPE (tmp));
261 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
262 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
264 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
269 gfc_conv_descriptor_lbound (tree desc, tree dim)
274 tmp = gfc_conv_descriptor_dimension (desc, dim);
275 field = TYPE_FIELDS (TREE_TYPE (tmp));
276 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
277 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
279 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
284 gfc_conv_descriptor_ubound (tree desc, tree dim)
289 tmp = gfc_conv_descriptor_dimension (desc, dim);
290 field = TYPE_FIELDS (TREE_TYPE (tmp));
291 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
292 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
294 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
299 /* Build a null array descriptor constructor. */
302 gfc_build_null_descriptor (tree type)
307 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
308 gcc_assert (DATA_FIELD == 0);
309 field = TYPE_FIELDS (type);
311 /* Set a NULL data pointer. */
312 tmp = build_constructor_single (type, field, null_pointer_node);
313 TREE_CONSTANT (tmp) = 1;
314 TREE_INVARIANT (tmp) = 1;
315 /* All other fields are ignored. */
321 /* Cleanup those #defines. */
326 #undef DIMENSION_FIELD
327 #undef STRIDE_SUBFIELD
328 #undef LBOUND_SUBFIELD
329 #undef UBOUND_SUBFIELD
332 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
333 flags & 1 = Main loop body.
334 flags & 2 = temp copy loop. */
337 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
339 for (; ss != gfc_ss_terminator; ss = ss->next)
340 ss->useflags = flags;
343 static void gfc_free_ss (gfc_ss *);
346 /* Free a gfc_ss chain. */
349 gfc_free_ss_chain (gfc_ss * ss)
353 while (ss != gfc_ss_terminator)
355 gcc_assert (ss != NULL);
366 gfc_free_ss (gfc_ss * ss)
373 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
375 if (ss->data.info.subscript[n])
376 gfc_free_ss_chain (ss->data.info.subscript[n]);
388 /* Free all the SS associated with a loop. */
391 gfc_cleanup_loop (gfc_loopinfo * loop)
397 while (ss != gfc_ss_terminator)
399 gcc_assert (ss != NULL);
400 next = ss->loop_chain;
407 /* Associate a SS chain with a loop. */
410 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
414 if (head == gfc_ss_terminator)
418 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
420 if (ss->next == gfc_ss_terminator)
421 ss->loop_chain = loop->ss;
423 ss->loop_chain = ss->next;
425 gcc_assert (ss == gfc_ss_terminator);
430 /* Generate an initializer for a static pointer or allocatable array. */
433 gfc_trans_static_array_pointer (gfc_symbol * sym)
437 gcc_assert (TREE_STATIC (sym->backend_decl));
438 /* Just zero the data member. */
439 type = TREE_TYPE (sym->backend_decl);
440 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
444 /* If the bounds of SE's loop have not yet been set, see if they can be
445 determined from array spec AS, which is the array spec of a called
446 function. MAPPING maps the callee's dummy arguments to the values
447 that the caller is passing. Add any initialization and finalization
451 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
452 gfc_se * se, gfc_array_spec * as)
460 if (as && as->type == AS_EXPLICIT)
461 for (dim = 0; dim < se->loop->dimen; dim++)
463 n = se->loop->order[dim];
464 if (se->loop->to[n] == NULL_TREE)
466 /* Evaluate the lower bound. */
467 gfc_init_se (&tmpse, NULL);
468 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
469 gfc_add_block_to_block (&se->pre, &tmpse.pre);
470 gfc_add_block_to_block (&se->post, &tmpse.post);
473 /* ...and the upper bound. */
474 gfc_init_se (&tmpse, NULL);
475 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
476 gfc_add_block_to_block (&se->pre, &tmpse.pre);
477 gfc_add_block_to_block (&se->post, &tmpse.post);
480 /* Set the upper bound of the loop to UPPER - LOWER. */
481 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
482 tmp = gfc_evaluate_now (tmp, &se->pre);
483 se->loop->to[n] = tmp;
489 /* Generate code to allocate an array temporary, or create a variable to
490 hold the data. If size is NULL, zero the descriptor so that the
491 callee will allocate the array. If DEALLOC is true, also generate code to
492 free the array afterwards.
494 Initialization code is added to PRE and finalization code to POST.
495 DYNAMIC is true if the caller may want to extend the array later
496 using realloc. This prevents us from putting the array on the stack. */
499 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
500 gfc_ss_info * info, tree size, tree nelem,
501 bool dynamic, bool dealloc)
508 desc = info->descriptor;
509 info->offset = gfc_index_zero_node;
510 if (size == NULL_TREE || integer_zerop (size))
512 /* A callee allocated array. */
513 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
518 /* Allocate the temporary. */
519 onstack = !dynamic && gfc_can_put_var_on_stack (size);
523 /* Make a temporary variable to hold the data. */
524 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
526 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
528 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
530 tmp = gfc_create_var (tmp, "A");
531 tmp = build_fold_addr_expr (tmp);
532 gfc_conv_descriptor_data_set (pre, desc, tmp);
536 /* Allocate memory to hold the data. */
537 args = gfc_chainon_list (NULL_TREE, size);
539 if (gfc_index_integer_kind == 4)
540 tmp = gfor_fndecl_internal_malloc;
541 else if (gfc_index_integer_kind == 8)
542 tmp = gfor_fndecl_internal_malloc64;
545 tmp = build_function_call_expr (tmp, args);
546 tmp = gfc_evaluate_now (tmp, pre);
547 gfc_conv_descriptor_data_set (pre, desc, tmp);
550 info->data = gfc_conv_descriptor_data_get (desc);
552 /* The offset is zero because we create temporaries with a zero
554 tmp = gfc_conv_descriptor_offset (desc);
555 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
557 if (dealloc && !onstack)
559 /* Free the temporary. */
560 tmp = gfc_conv_descriptor_data_get (desc);
561 tmp = fold_convert (pvoid_type_node, tmp);
562 tmp = gfc_chainon_list (NULL_TREE, tmp);
563 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
564 gfc_add_expr_to_block (post, tmp);
569 /* Generate code to create and initialize the descriptor for a temporary
570 array. This is used for both temporaries needed by the scalarizer, and
571 functions returning arrays. Adjusts the loop variables to be
572 zero-based, and calculates the loop bounds for callee allocated arrays.
573 Allocate the array unless it's callee allocated (we have a callee
574 allocated array if 'callee_alloc' is true, or if loop->to[n] is
575 NULL_TREE for any n). Also fills in the descriptor, data and offset
576 fields of info if known. Returns the size of the array, or NULL for a
577 callee allocated array.
579 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
583 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
584 gfc_loopinfo * loop, gfc_ss_info * info,
585 tree eltype, bool dynamic, bool dealloc,
598 gcc_assert (info->dimen > 0);
599 /* Set the lower bound to zero. */
600 for (dim = 0; dim < info->dimen; dim++)
602 n = loop->order[dim];
603 if (n < loop->temp_dim)
604 gcc_assert (integer_zerop (loop->from[n]));
607 /* Callee allocated arrays may not have a known bound yet. */
609 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
610 loop->to[n], loop->from[n]);
611 loop->from[n] = gfc_index_zero_node;
614 info->delta[dim] = gfc_index_zero_node;
615 info->start[dim] = gfc_index_zero_node;
616 info->end[dim] = gfc_index_zero_node;
617 info->stride[dim] = gfc_index_one_node;
618 info->dim[dim] = dim;
621 /* Initialize the descriptor. */
623 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
624 desc = gfc_create_var (type, "atmp");
625 GFC_DECL_PACKED_ARRAY (desc) = 1;
627 info->descriptor = desc;
628 size = gfc_index_one_node;
630 /* Fill in the array dtype. */
631 tmp = gfc_conv_descriptor_dtype (desc);
632 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
635 Fill in the bounds and stride. This is a packed array, so:
638 for (n = 0; n < rank; n++)
641 delta = ubound[n] + 1 - lbound[n];
644 size = size * sizeof(element);
649 for (n = 0; n < info->dimen; n++)
651 if (loop->to[n] == NULL_TREE)
653 /* For a callee allocated array express the loop bounds in terms
654 of the descriptor fields. */
655 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
656 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
657 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
663 /* Store the stride and bound components in the descriptor. */
664 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
665 gfc_add_modify_expr (pre, tmp, size);
667 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
668 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
670 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
671 gfc_add_modify_expr (pre, tmp, loop->to[n]);
673 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
674 loop->to[n], gfc_index_one_node);
676 /* Check whether the size for this dimension is negative. */
677 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
678 gfc_index_zero_node);
679 cond = gfc_evaluate_now (cond, pre);
684 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
686 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
687 size = gfc_evaluate_now (size, pre);
690 /* Get the size of the array. */
692 if (size && !callee_alloc)
694 /* If or_expr is true, then the extent in at least one
695 dimension is zero and the size is set to zero. */
696 size = fold_build3 (COND_EXPR, gfc_array_index_type,
697 or_expr, gfc_index_zero_node, size);
700 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
701 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
709 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
712 if (info->dimen > loop->temp_dim)
713 loop->temp_dim = info->dimen;
719 /* Generate code to transpose array EXPR by creating a new descriptor
720 in which the dimension specifications have been reversed. */
723 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
725 tree dest, src, dest_index, src_index;
727 gfc_ss_info *dest_info, *src_info;
728 gfc_ss *dest_ss, *src_ss;
734 src_ss = gfc_walk_expr (expr);
737 src_info = &src_ss->data.info;
738 dest_info = &dest_ss->data.info;
739 gcc_assert (dest_info->dimen == 2);
740 gcc_assert (src_info->dimen == 2);
742 /* Get a descriptor for EXPR. */
743 gfc_init_se (&src_se, NULL);
744 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
745 gfc_add_block_to_block (&se->pre, &src_se.pre);
746 gfc_add_block_to_block (&se->post, &src_se.post);
749 /* Allocate a new descriptor for the return value. */
750 dest = gfc_create_var (TREE_TYPE (src), "atmp");
751 dest_info->descriptor = dest;
754 /* Copy across the dtype field. */
755 gfc_add_modify_expr (&se->pre,
756 gfc_conv_descriptor_dtype (dest),
757 gfc_conv_descriptor_dtype (src));
759 /* Copy the dimension information, renumbering dimension 1 to 0 and
761 for (n = 0; n < 2; n++)
763 dest_info->delta[n] = gfc_index_zero_node;
764 dest_info->start[n] = gfc_index_zero_node;
765 dest_info->end[n] = gfc_index_zero_node;
766 dest_info->stride[n] = gfc_index_one_node;
767 dest_info->dim[n] = n;
769 dest_index = gfc_rank_cst[n];
770 src_index = gfc_rank_cst[1 - n];
772 gfc_add_modify_expr (&se->pre,
773 gfc_conv_descriptor_stride (dest, dest_index),
774 gfc_conv_descriptor_stride (src, src_index));
776 gfc_add_modify_expr (&se->pre,
777 gfc_conv_descriptor_lbound (dest, dest_index),
778 gfc_conv_descriptor_lbound (src, src_index));
780 gfc_add_modify_expr (&se->pre,
781 gfc_conv_descriptor_ubound (dest, dest_index),
782 gfc_conv_descriptor_ubound (src, src_index));
786 gcc_assert (integer_zerop (loop->from[n]));
787 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
788 gfc_conv_descriptor_ubound (dest, dest_index),
789 gfc_conv_descriptor_lbound (dest, dest_index));
793 /* Copy the data pointer. */
794 dest_info->data = gfc_conv_descriptor_data_get (src);
795 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
797 /* Copy the offset. This is not changed by transposition: the top-left
798 element is still at the same offset as before. */
799 dest_info->offset = gfc_conv_descriptor_offset (src);
800 gfc_add_modify_expr (&se->pre,
801 gfc_conv_descriptor_offset (dest),
804 if (dest_info->dimen > loop->temp_dim)
805 loop->temp_dim = dest_info->dimen;
809 /* Return the number of iterations in a loop that starts at START,
810 ends at END, and has step STEP. */
813 gfc_get_iteration_count (tree start, tree end, tree step)
818 type = TREE_TYPE (step);
819 tmp = fold_build2 (MINUS_EXPR, type, end, start);
820 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
821 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
822 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
823 return fold_convert (gfc_array_index_type, tmp);
827 /* Extend the data in array DESC by EXTRA elements. */
830 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
837 if (integer_zerop (extra))
840 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
842 /* Add EXTRA to the upper bound. */
843 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
844 gfc_add_modify_expr (pblock, ubound, tmp);
846 /* Get the value of the current data pointer. */
847 tmp = gfc_conv_descriptor_data_get (desc);
848 args = gfc_chainon_list (NULL_TREE, tmp);
850 /* Calculate the new array size. */
851 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
852 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
853 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
854 args = gfc_chainon_list (args, tmp);
856 /* Pick the appropriate realloc function. */
857 if (gfc_index_integer_kind == 4)
858 tmp = gfor_fndecl_internal_realloc;
859 else if (gfc_index_integer_kind == 8)
860 tmp = gfor_fndecl_internal_realloc64;
864 /* Set the new data pointer. */
865 tmp = build_function_call_expr (tmp, args);
866 gfc_conv_descriptor_data_set (pblock, desc, tmp);
870 /* Return true if the bounds of iterator I can only be determined
874 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
876 return (i->start->expr_type != EXPR_CONSTANT
877 || i->end->expr_type != EXPR_CONSTANT
878 || i->step->expr_type != EXPR_CONSTANT);
882 /* Split the size of constructor element EXPR into the sum of two terms,
883 one of which can be determined at compile time and one of which must
884 be calculated at run time. Set *SIZE to the former and return true
885 if the latter might be nonzero. */
888 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
890 if (expr->expr_type == EXPR_ARRAY)
891 return gfc_get_array_constructor_size (size, expr->value.constructor);
892 else if (expr->rank > 0)
894 /* Calculate everything at run time. */
895 mpz_set_ui (*size, 0);
900 /* A single element. */
901 mpz_set_ui (*size, 1);
907 /* Like gfc_get_array_constructor_element_size, but applied to the whole
908 of array constructor C. */
911 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
918 mpz_set_ui (*size, 0);
923 for (; c; c = c->next)
926 if (i && gfc_iterator_has_dynamic_bounds (i))
930 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
933 /* Multiply the static part of the element size by the
934 number of iterations. */
935 mpz_sub (val, i->end->value.integer, i->start->value.integer);
936 mpz_fdiv_q (val, val, i->step->value.integer);
937 mpz_add_ui (val, val, 1);
938 if (mpz_sgn (val) > 0)
939 mpz_mul (len, len, val);
943 mpz_add (*size, *size, len);
952 /* Make sure offset is a variable. */
955 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
958 /* We should have already created the offset variable. We cannot
959 create it here because we may be in an inner scope. */
960 gcc_assert (*offsetvar != NULL_TREE);
961 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
962 *poffset = *offsetvar;
963 TREE_USED (*offsetvar) = 1;
967 /* Assign an element of an array constructor. */
970 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
971 tree offset, gfc_se * se, gfc_expr * expr)
976 gfc_conv_expr (se, expr);
978 /* Store the value. */
979 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
980 tmp = gfc_build_array_ref (tmp, offset);
981 if (expr->ts.type == BT_CHARACTER)
983 gfc_conv_string_parameter (se);
984 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
986 /* The temporary is an array of pointers. */
987 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
988 gfc_add_modify_expr (&se->pre, tmp, se->expr);
992 /* The temporary is an array of string values. */
993 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
994 /* We know the temporary and the value will be the same length,
995 so can use memcpy. */
996 args = gfc_chainon_list (NULL_TREE, tmp);
997 args = gfc_chainon_list (args, se->expr);
998 args = gfc_chainon_list (args, se->string_length);
999 tmp = built_in_decls[BUILT_IN_MEMCPY];
1000 tmp = build_function_call_expr (tmp, args);
1001 gfc_add_expr_to_block (&se->pre, tmp);
1006 /* TODO: Should the frontend already have done this conversion? */
1007 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1008 gfc_add_modify_expr (&se->pre, tmp, se->expr);
1011 gfc_add_block_to_block (pblock, &se->pre);
1012 gfc_add_block_to_block (pblock, &se->post);
1016 /* Add the contents of an array to the constructor. DYNAMIC is as for
1017 gfc_trans_array_constructor_value. */
1020 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1021 tree type ATTRIBUTE_UNUSED,
1022 tree desc, gfc_expr * expr,
1023 tree * poffset, tree * offsetvar,
1034 /* We need this to be a variable so we can increment it. */
1035 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1037 gfc_init_se (&se, NULL);
1039 /* Walk the array expression. */
1040 ss = gfc_walk_expr (expr);
1041 gcc_assert (ss != gfc_ss_terminator);
1043 /* Initialize the scalarizer. */
1044 gfc_init_loopinfo (&loop);
1045 gfc_add_ss_to_loop (&loop, ss);
1047 /* Initialize the loop. */
1048 gfc_conv_ss_startstride (&loop);
1049 gfc_conv_loop_setup (&loop);
1051 /* Make sure the constructed array has room for the new data. */
1054 /* Set SIZE to the total number of elements in the subarray. */
1055 size = gfc_index_one_node;
1056 for (n = 0; n < loop.dimen; n++)
1058 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1059 gfc_index_one_node);
1060 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1063 /* Grow the constructed array by SIZE elements. */
1064 gfc_grow_array (&loop.pre, desc, size);
1067 /* Make the loop body. */
1068 gfc_mark_ss_chain_used (ss, 1);
1069 gfc_start_scalarized_body (&loop, &body);
1070 gfc_copy_loopinfo_to_se (&se, &loop);
1073 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1074 gcc_assert (se.ss == gfc_ss_terminator);
1076 /* Increment the offset. */
1077 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1078 gfc_add_modify_expr (&body, *poffset, tmp);
1080 /* Finish the loop. */
1081 gfc_trans_scalarizing_loops (&loop, &body);
1082 gfc_add_block_to_block (&loop.pre, &loop.post);
1083 tmp = gfc_finish_block (&loop.pre);
1084 gfc_add_expr_to_block (pblock, tmp);
1086 gfc_cleanup_loop (&loop);
1090 /* Assign the values to the elements of an array constructor. DYNAMIC
1091 is true if descriptor DESC only contains enough data for the static
1092 size calculated by gfc_get_array_constructor_size. When true, memory
1093 for the dynamic parts must be allocated using realloc. */
1096 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1097 tree desc, gfc_constructor * c,
1098 tree * poffset, tree * offsetvar,
1107 for (; c; c = c->next)
1109 /* If this is an iterator or an array, the offset must be a variable. */
1110 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1111 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1113 gfc_start_block (&body);
1115 if (c->expr->expr_type == EXPR_ARRAY)
1117 /* Array constructors can be nested. */
1118 gfc_trans_array_constructor_value (&body, type, desc,
1119 c->expr->value.constructor,
1120 poffset, offsetvar, dynamic);
1122 else if (c->expr->rank > 0)
1124 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1125 poffset, offsetvar, dynamic);
1129 /* This code really upsets the gimplifier so don't bother for now. */
1136 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1143 /* Scalar values. */
1144 gfc_init_se (&se, NULL);
1145 gfc_trans_array_ctor_element (&body, desc, *poffset,
1148 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1149 *poffset, gfc_index_one_node);
1153 /* Collect multiple scalar constants into a constructor. */
1161 /* Count the number of consecutive scalar constants. */
1162 while (p && !(p->iterator
1163 || p->expr->expr_type != EXPR_CONSTANT))
1165 gfc_init_se (&se, NULL);
1166 gfc_conv_constant (&se, p->expr);
1167 if (p->expr->ts.type == BT_CHARACTER
1168 && POINTER_TYPE_P (type))
1170 /* For constant character array constructors we build
1171 an array of pointers. */
1172 se.expr = gfc_build_addr_expr (pchar_type_node,
1176 list = tree_cons (NULL_TREE, se.expr, list);
1181 bound = build_int_cst (NULL_TREE, n - 1);
1182 /* Create an array type to hold them. */
1183 tmptype = build_range_type (gfc_array_index_type,
1184 gfc_index_zero_node, bound);
1185 tmptype = build_array_type (type, tmptype);
1187 init = build_constructor_from_list (tmptype, nreverse (list));
1188 TREE_CONSTANT (init) = 1;
1189 TREE_INVARIANT (init) = 1;
1190 TREE_STATIC (init) = 1;
1191 /* Create a static variable to hold the data. */
1192 tmp = gfc_create_var (tmptype, "data");
1193 TREE_STATIC (tmp) = 1;
1194 TREE_CONSTANT (tmp) = 1;
1195 TREE_INVARIANT (tmp) = 1;
1196 TREE_READONLY (tmp) = 1;
1197 DECL_INITIAL (tmp) = init;
1200 /* Use BUILTIN_MEMCPY to assign the values. */
1201 tmp = gfc_conv_descriptor_data_get (desc);
1202 tmp = build_fold_indirect_ref (tmp);
1203 tmp = gfc_build_array_ref (tmp, *poffset);
1204 tmp = build_fold_addr_expr (tmp);
1205 init = build_fold_addr_expr (init);
1207 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1208 bound = build_int_cst (NULL_TREE, n * size);
1209 tmp = gfc_chainon_list (NULL_TREE, tmp);
1210 tmp = gfc_chainon_list (tmp, init);
1211 tmp = gfc_chainon_list (tmp, bound);
1212 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
1214 gfc_add_expr_to_block (&body, tmp);
1216 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1217 *poffset, build_int_cst (NULL_TREE, n));
1219 if (!INTEGER_CST_P (*poffset))
1221 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1222 *poffset = *offsetvar;
1226 /* The frontend should already have done any expansions possible
1230 /* Pass the code as is. */
1231 tmp = gfc_finish_block (&body);
1232 gfc_add_expr_to_block (pblock, tmp);
1236 /* Build the implied do-loop. */
1246 loopbody = gfc_finish_block (&body);
1248 gfc_init_se (&se, NULL);
1249 gfc_conv_expr (&se, c->iterator->var);
1250 gfc_add_block_to_block (pblock, &se.pre);
1253 /* Make a temporary, store the current value in that
1254 and return it, once the loop is done. */
1255 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1256 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1258 /* Initialize the loop. */
1259 gfc_init_se (&se, NULL);
1260 gfc_conv_expr_val (&se, c->iterator->start);
1261 gfc_add_block_to_block (pblock, &se.pre);
1262 gfc_add_modify_expr (pblock, loopvar, se.expr);
1264 gfc_init_se (&se, NULL);
1265 gfc_conv_expr_val (&se, c->iterator->end);
1266 gfc_add_block_to_block (pblock, &se.pre);
1267 end = gfc_evaluate_now (se.expr, pblock);
1269 gfc_init_se (&se, NULL);
1270 gfc_conv_expr_val (&se, c->iterator->step);
1271 gfc_add_block_to_block (pblock, &se.pre);
1272 step = gfc_evaluate_now (se.expr, pblock);
1274 /* If this array expands dynamically, and the number of iterations
1275 is not constant, we won't have allocated space for the static
1276 part of C->EXPR's size. Do that now. */
1277 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1279 /* Get the number of iterations. */
1280 tmp = gfc_get_iteration_count (loopvar, end, step);
1282 /* Get the static part of C->EXPR's size. */
1283 gfc_get_array_constructor_element_size (&size, c->expr);
1284 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1286 /* Grow the array by TMP * TMP2 elements. */
1287 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1288 gfc_grow_array (pblock, desc, tmp);
1291 /* Generate the loop body. */
1292 exit_label = gfc_build_label_decl (NULL_TREE);
1293 gfc_start_block (&body);
1295 /* Generate the exit condition. Depending on the sign of
1296 the step variable we have to generate the correct
1298 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1299 build_int_cst (TREE_TYPE (step), 0));
1300 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1301 build2 (GT_EXPR, boolean_type_node,
1303 build2 (LT_EXPR, boolean_type_node,
1305 tmp = build1_v (GOTO_EXPR, exit_label);
1306 TREE_USED (exit_label) = 1;
1307 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1308 gfc_add_expr_to_block (&body, tmp);
1310 /* The main loop body. */
1311 gfc_add_expr_to_block (&body, loopbody);
1313 /* Increase loop variable by step. */
1314 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1315 gfc_add_modify_expr (&body, loopvar, tmp);
1317 /* Finish the loop. */
1318 tmp = gfc_finish_block (&body);
1319 tmp = build1_v (LOOP_EXPR, tmp);
1320 gfc_add_expr_to_block (pblock, tmp);
1322 /* Add the exit label. */
1323 tmp = build1_v (LABEL_EXPR, exit_label);
1324 gfc_add_expr_to_block (pblock, tmp);
1326 /* Restore the original value of the loop counter. */
1327 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1334 /* Figure out the string length of a variable reference expression.
1335 Used by get_array_ctor_strlen. */
1338 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1344 /* Don't bother if we already know the length is a constant. */
1345 if (*len && INTEGER_CST_P (*len))
1348 ts = &expr->symtree->n.sym->ts;
1349 for (ref = expr->ref; ref; ref = ref->next)
1354 /* Array references don't change the string length. */
1358 /* Use the length of the component. */
1359 ts = &ref->u.c.component->ts;
1363 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1364 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1366 mpz_init_set_ui (char_len, 1);
1367 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1368 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1369 *len = gfc_conv_mpz_to_tree (char_len,
1370 gfc_default_character_kind);
1371 *len = convert (gfc_charlen_type_node, *len);
1372 mpz_clear (char_len);
1376 /* TODO: Substrings are tricky because we can't evaluate the
1377 expression more than once. For now we just give up, and hope
1378 we can figure it out elsewhere. */
1383 *len = ts->cl->backend_decl;
1387 /* Figure out the string length of a character array constructor.
1388 Returns TRUE if all elements are character constants. */
1391 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1396 for (; c; c = c->next)
1398 switch (c->expr->expr_type)
1401 if (!(*len && INTEGER_CST_P (*len)))
1402 *len = build_int_cstu (gfc_charlen_type_node,
1403 c->expr->value.character.length);
1407 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1413 get_array_ctor_var_strlen (c->expr, len);
1419 /* Hope that whatever we have possesses a constant character
1421 if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl)
1423 gfc_conv_const_charlen (c->expr->ts.cl);
1424 *len = c->expr->ts.cl->backend_decl;
1426 /* TODO: For now we just ignore anything we don't know how to
1427 handle, and hope we can figure it out a different way. */
1435 /* Check whether the array constructor C consists entirely of constant
1436 elements, and if so returns the number of those elements, otherwise
1437 return zero. Note, an empty or NULL array constructor returns zero. */
1439 unsigned HOST_WIDE_INT
1440 gfc_constant_array_constructor_p (gfc_constructor * c)
1442 unsigned HOST_WIDE_INT nelem = 0;
1447 || c->expr->rank > 0
1448 || c->expr->expr_type != EXPR_CONSTANT)
1457 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1458 and the tree type of it's elements, TYPE, return a static constant
1459 variable that is compile-time initialized. */
1462 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1464 tree tmptype, list, init, tmp;
1465 HOST_WIDE_INT nelem;
1471 /* First traverse the constructor list, converting the constants
1472 to tree to build an initializer. */
1475 c = expr->value.constructor;
1478 gfc_init_se (&se, NULL);
1479 gfc_conv_constant (&se, c->expr);
1480 if (c->expr->ts.type == BT_CHARACTER
1481 && POINTER_TYPE_P (type))
1482 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1483 list = tree_cons (NULL_TREE, se.expr, list);
1488 /* Next determine the tree type for the array. We use the gfortran
1489 front-end's gfc_get_nodesc_array_type in order to create a suitable
1490 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1492 memset (&as, 0, sizeof (gfc_array_spec));
1495 as.type = AS_EXPLICIT;
1496 as.lower[0] = gfc_int_expr (0);
1497 as.upper[0] = gfc_int_expr (nelem - 1);
1498 tmptype = gfc_get_nodesc_array_type (type, &as, 3);
1500 init = build_constructor_from_list (tmptype, nreverse (list));
1502 TREE_CONSTANT (init) = 1;
1503 TREE_INVARIANT (init) = 1;
1504 TREE_STATIC (init) = 1;
1506 tmp = gfc_create_var (tmptype, "A");
1507 TREE_STATIC (tmp) = 1;
1508 TREE_CONSTANT (tmp) = 1;
1509 TREE_INVARIANT (tmp) = 1;
1510 TREE_READONLY (tmp) = 1;
1511 DECL_INITIAL (tmp) = init;
1517 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1518 This mostly initializes the scalarizer state info structure with the
1519 appropriate values to directly use the array created by the function
1520 gfc_build_constant_array_constructor. */
1523 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1524 gfc_ss * ss, tree type)
1529 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1531 info = &ss->data.info;
1533 info->descriptor = tmp;
1534 info->data = build_fold_addr_expr (tmp);
1535 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1538 info->delta[0] = gfc_index_zero_node;
1539 info->start[0] = gfc_index_zero_node;
1540 info->end[0] = gfc_index_zero_node;
1541 info->stride[0] = gfc_index_one_node;
1544 if (info->dimen > loop->temp_dim)
1545 loop->temp_dim = info->dimen;
1549 /* Array constructors are handled by constructing a temporary, then using that
1550 within the scalarization loop. This is not optimal, but seems by far the
1554 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1563 ss->data.info.dimen = loop->dimen;
1565 c = ss->expr->value.constructor;
1566 if (ss->expr->ts.type == BT_CHARACTER)
1568 bool const_string = get_array_ctor_strlen (c, &ss->string_length);
1569 if (!ss->string_length)
1570 gfc_todo_error ("complex character array constructors");
1572 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1574 type = build_pointer_type (type);
1577 type = gfc_typenode_for_spec (&ss->expr->ts);
1579 /* See if the constructor determines the loop bounds. */
1581 if (loop->to[0] == NULL_TREE)
1585 /* We should have a 1-dimensional, zero-based loop. */
1586 gcc_assert (loop->dimen == 1);
1587 gcc_assert (integer_zerop (loop->from[0]));
1589 /* Split the constructor size into a static part and a dynamic part.
1590 Allocate the static size up-front and record whether the dynamic
1591 size might be nonzero. */
1593 dynamic = gfc_get_array_constructor_size (&size, c);
1594 mpz_sub_ui (size, size, 1);
1595 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1599 /* Special case constant array constructors. */
1602 && INTEGER_CST_P (loop->from[0])
1603 && INTEGER_CST_P (loop->to[0]))
1605 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1608 tree diff = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1609 loop->to[0], loop->from[0]);
1610 if (compare_tree_int (diff, nelem - 1) == 0)
1612 gfc_trans_constant_array_constructor (loop, ss, type);
1618 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1619 type, dynamic, true, false);
1621 desc = ss->data.info.descriptor;
1622 offset = gfc_index_zero_node;
1623 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1624 TREE_USED (offsetvar) = 0;
1625 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1626 &offset, &offsetvar, dynamic);
1628 /* If the array grows dynamically, the upper bound of the loop variable
1629 is determined by the array's final upper bound. */
1631 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1633 if (TREE_USED (offsetvar))
1634 pushdecl (offsetvar);
1636 gcc_assert (INTEGER_CST_P (offset));
1638 /* Disable bound checking for now because it's probably broken. */
1639 if (flag_bounds_check)
1647 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1648 called after evaluating all of INFO's vector dimensions. Go through
1649 each such vector dimension and see if we can now fill in any missing
1653 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1662 for (n = 0; n < loop->dimen; n++)
1665 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1666 && loop->to[n] == NULL)
1668 /* Loop variable N indexes vector dimension DIM, and we don't
1669 yet know the upper bound of loop variable N. Set it to the
1670 difference between the vector's upper and lower bounds. */
1671 gcc_assert (loop->from[n] == gfc_index_zero_node);
1672 gcc_assert (info->subscript[dim]
1673 && info->subscript[dim]->type == GFC_SS_VECTOR);
1675 gfc_init_se (&se, NULL);
1676 desc = info->subscript[dim]->data.info.descriptor;
1677 zero = gfc_rank_cst[0];
1678 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1679 gfc_conv_descriptor_ubound (desc, zero),
1680 gfc_conv_descriptor_lbound (desc, zero));
1681 tmp = gfc_evaluate_now (tmp, &loop->pre);
1688 /* Add the pre and post chains for all the scalar expressions in a SS chain
1689 to loop. This is called after the loop parameters have been calculated,
1690 but before the actual scalarizing loops. */
1693 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1698 /* TODO: This can generate bad code if there are ordering dependencies.
1699 eg. a callee allocated function and an unknown size constructor. */
1700 gcc_assert (ss != NULL);
1702 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1709 /* Scalar expression. Evaluate this now. This includes elemental
1710 dimension indices, but not array section bounds. */
1711 gfc_init_se (&se, NULL);
1712 gfc_conv_expr (&se, ss->expr);
1713 gfc_add_block_to_block (&loop->pre, &se.pre);
1715 if (ss->expr->ts.type != BT_CHARACTER)
1717 /* Move the evaluation of scalar expressions outside the
1718 scalarization loop. */
1720 se.expr = convert(gfc_array_index_type, se.expr);
1721 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1722 gfc_add_block_to_block (&loop->pre, &se.post);
1725 gfc_add_block_to_block (&loop->post, &se.post);
1727 ss->data.scalar.expr = se.expr;
1728 ss->string_length = se.string_length;
1731 case GFC_SS_REFERENCE:
1732 /* Scalar reference. Evaluate this now. */
1733 gfc_init_se (&se, NULL);
1734 gfc_conv_expr_reference (&se, ss->expr);
1735 gfc_add_block_to_block (&loop->pre, &se.pre);
1736 gfc_add_block_to_block (&loop->post, &se.post);
1738 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1739 ss->string_length = se.string_length;
1742 case GFC_SS_SECTION:
1743 /* Add the expressions for scalar and vector subscripts. */
1744 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1745 if (ss->data.info.subscript[n])
1746 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1748 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1752 /* Get the vector's descriptor and store it in SS. */
1753 gfc_init_se (&se, NULL);
1754 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1755 gfc_add_block_to_block (&loop->pre, &se.pre);
1756 gfc_add_block_to_block (&loop->post, &se.post);
1757 ss->data.info.descriptor = se.expr;
1760 case GFC_SS_INTRINSIC:
1761 gfc_add_intrinsic_ss_code (loop, ss);
1764 case GFC_SS_FUNCTION:
1765 /* Array function return value. We call the function and save its
1766 result in a temporary for use inside the loop. */
1767 gfc_init_se (&se, NULL);
1770 gfc_conv_expr (&se, ss->expr);
1771 gfc_add_block_to_block (&loop->pre, &se.pre);
1772 gfc_add_block_to_block (&loop->post, &se.post);
1773 ss->string_length = se.string_length;
1776 case GFC_SS_CONSTRUCTOR:
1777 gfc_trans_array_constructor (loop, ss);
1781 case GFC_SS_COMPONENT:
1782 /* Do nothing. These are handled elsewhere. */
1792 /* Translate expressions for the descriptor and data pointer of a SS. */
1796 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1801 /* Get the descriptor for the array to be scalarized. */
1802 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1803 gfc_init_se (&se, NULL);
1804 se.descriptor_only = 1;
1805 gfc_conv_expr_lhs (&se, ss->expr);
1806 gfc_add_block_to_block (block, &se.pre);
1807 ss->data.info.descriptor = se.expr;
1808 ss->string_length = se.string_length;
1812 /* Also the data pointer. */
1813 tmp = gfc_conv_array_data (se.expr);
1814 /* If this is a variable or address of a variable we use it directly.
1815 Otherwise we must evaluate it now to avoid breaking dependency
1816 analysis by pulling the expressions for elemental array indices
1819 || (TREE_CODE (tmp) == ADDR_EXPR
1820 && DECL_P (TREE_OPERAND (tmp, 0)))))
1821 tmp = gfc_evaluate_now (tmp, block);
1822 ss->data.info.data = tmp;
1824 tmp = gfc_conv_array_offset (se.expr);
1825 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1830 /* Initialize a gfc_loopinfo structure. */
1833 gfc_init_loopinfo (gfc_loopinfo * loop)
1837 memset (loop, 0, sizeof (gfc_loopinfo));
1838 gfc_init_block (&loop->pre);
1839 gfc_init_block (&loop->post);
1841 /* Initially scalarize in order. */
1842 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1845 loop->ss = gfc_ss_terminator;
1849 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1853 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1859 /* Return an expression for the data pointer of an array. */
1862 gfc_conv_array_data (tree descriptor)
1866 type = TREE_TYPE (descriptor);
1867 if (GFC_ARRAY_TYPE_P (type))
1869 if (TREE_CODE (type) == POINTER_TYPE)
1873 /* Descriptorless arrays. */
1874 return build_fold_addr_expr (descriptor);
1878 return gfc_conv_descriptor_data_get (descriptor);
1882 /* Return an expression for the base offset of an array. */
1885 gfc_conv_array_offset (tree descriptor)
1889 type = TREE_TYPE (descriptor);
1890 if (GFC_ARRAY_TYPE_P (type))
1891 return GFC_TYPE_ARRAY_OFFSET (type);
1893 return gfc_conv_descriptor_offset (descriptor);
1897 /* Get an expression for the array stride. */
1900 gfc_conv_array_stride (tree descriptor, int dim)
1905 type = TREE_TYPE (descriptor);
1907 /* For descriptorless arrays use the array size. */
1908 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1909 if (tmp != NULL_TREE)
1912 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1917 /* Like gfc_conv_array_stride, but for the lower bound. */
1920 gfc_conv_array_lbound (tree descriptor, int dim)
1925 type = TREE_TYPE (descriptor);
1927 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1928 if (tmp != NULL_TREE)
1931 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1936 /* Like gfc_conv_array_stride, but for the upper bound. */
1939 gfc_conv_array_ubound (tree descriptor, int dim)
1944 type = TREE_TYPE (descriptor);
1946 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1947 if (tmp != NULL_TREE)
1950 /* This should only ever happen when passing an assumed shape array
1951 as an actual parameter. The value will never be used. */
1952 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1953 return gfc_index_zero_node;
1955 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1960 /* Generate code to perform an array index bound check. */
1963 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
1969 const char * name = NULL;
1971 if (!flag_bounds_check)
1974 index = gfc_evaluate_now (index, &se->pre);
1976 /* We find a name for the error message. */
1978 name = se->ss->expr->symtree->name;
1980 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
1981 && se->loop->ss->expr->symtree)
1982 name = se->loop->ss->expr->symtree->name;
1984 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
1985 && se->loop->ss->loop_chain->expr
1986 && se->loop->ss->loop_chain->expr->symtree)
1987 name = se->loop->ss->loop_chain->expr->symtree->name;
1989 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
1990 && se->loop->ss->loop_chain->expr->symtree)
1991 name = se->loop->ss->loop_chain->expr->symtree->name;
1993 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
1995 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
1996 && se->loop->ss->expr->value.function.name)
1997 name = se->loop->ss->expr->value.function.name;
1999 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2000 || se->loop->ss->type == GFC_SS_SCALAR)
2001 name = "unnamed constant";
2004 /* Check lower bound. */
2005 tmp = gfc_conv_array_lbound (descriptor, n);
2006 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2008 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2009 gfc_msg_fault, name, n+1);
2011 asprintf (&msg, "%s, lower bound of dimension %d exceeded",
2012 gfc_msg_fault, n+1);
2013 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2016 /* Check upper bound. */
2017 tmp = gfc_conv_array_ubound (descriptor, n);
2018 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2020 asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
2021 gfc_msg_fault, name, n+1);
2023 asprintf (&msg, "%s, upper bound of dimension %d exceeded",
2024 gfc_msg_fault, n+1);
2025 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2032 /* Return the offset for an index. Performs bound checking for elemental
2033 dimensions. Single element references are processed separately. */
2036 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2037 gfc_array_ref * ar, tree stride)
2043 /* Get the index into the array for this dimension. */
2046 gcc_assert (ar->type != AR_ELEMENT);
2047 switch (ar->dimen_type[dim])
2050 gcc_assert (i == -1);
2051 /* Elemental dimension. */
2052 gcc_assert (info->subscript[dim]
2053 && info->subscript[dim]->type == GFC_SS_SCALAR);
2054 /* We've already translated this value outside the loop. */
2055 index = info->subscript[dim]->data.scalar.expr;
2057 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2058 || dim < ar->dimen - 1)
2059 index = gfc_trans_array_bound_check (se, info->descriptor,
2060 index, dim, &ar->where);
2064 gcc_assert (info && se->loop);
2065 gcc_assert (info->subscript[dim]
2066 && info->subscript[dim]->type == GFC_SS_VECTOR);
2067 desc = info->subscript[dim]->data.info.descriptor;
2069 /* Get a zero-based index into the vector. */
2070 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2071 se->loop->loopvar[i], se->loop->from[i]);
2073 /* Multiply the index by the stride. */
2074 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2075 index, gfc_conv_array_stride (desc, 0));
2077 /* Read the vector to get an index into info->descriptor. */
2078 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2079 index = gfc_build_array_ref (data, index);
2080 index = gfc_evaluate_now (index, &se->pre);
2082 /* Do any bounds checking on the final info->descriptor index. */
2083 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2084 || dim < ar->dimen - 1)
2085 index = gfc_trans_array_bound_check (se, info->descriptor,
2086 index, dim, &ar->where);
2090 /* Scalarized dimension. */
2091 gcc_assert (info && se->loop);
2093 /* Multiply the loop variable by the stride and delta. */
2094 index = se->loop->loopvar[i];
2095 if (!integer_onep (info->stride[i]))
2096 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2098 if (!integer_zerop (info->delta[i]))
2099 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2109 /* Temporary array or derived type component. */
2110 gcc_assert (se->loop);
2111 index = se->loop->loopvar[se->loop->order[i]];
2112 if (!integer_zerop (info->delta[i]))
2113 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2114 index, info->delta[i]);
2117 /* Multiply by the stride. */
2118 if (!integer_onep (stride))
2119 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2125 /* Build a scalarized reference to an array. */
2128 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2135 info = &se->ss->data.info;
2137 n = se->loop->order[0];
2141 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2143 /* Add the offset for this dimension to the stored offset for all other
2145 if (!integer_zerop (info->offset))
2146 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2148 tmp = build_fold_indirect_ref (info->data);
2149 se->expr = gfc_build_array_ref (tmp, index);
2153 /* Translate access of temporary array. */
2156 gfc_conv_tmp_array_ref (gfc_se * se)
2158 se->string_length = se->ss->string_length;
2159 gfc_conv_scalarized_array_ref (se, NULL);
2163 /* Build an array reference. se->expr already holds the array descriptor.
2164 This should be either a variable, indirect variable reference or component
2165 reference. For arrays which do not have a descriptor, se->expr will be
2167 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2170 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2179 /* Handle scalarized references separately. */
2180 if (ar->type != AR_ELEMENT)
2182 gfc_conv_scalarized_array_ref (se, ar);
2183 gfc_advance_se_ss_chain (se);
2187 index = gfc_index_zero_node;
2189 /* Calculate the offsets from all the dimensions. */
2190 for (n = 0; n < ar->dimen; n++)
2192 /* Calculate the index for this dimension. */
2193 gfc_init_se (&indexse, se);
2194 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2195 gfc_add_block_to_block (&se->pre, &indexse.pre);
2197 if (flag_bounds_check &&
2198 ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2199 || n < ar->dimen - 1))
2201 /* Check array bounds. */
2205 tmp = gfc_conv_array_lbound (se->expr, n);
2206 cond = fold_build2 (LT_EXPR, boolean_type_node,
2208 asprintf (&msg, "%s for array '%s', "
2209 "lower bound of dimension %d exceeded", gfc_msg_fault,
2211 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2214 tmp = gfc_conv_array_ubound (se->expr, n);
2215 cond = fold_build2 (GT_EXPR, boolean_type_node,
2217 asprintf (&msg, "%s for array '%s', "
2218 "upper bound of dimension %d exceeded", gfc_msg_fault,
2220 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2224 /* Multiply the index by the stride. */
2225 stride = gfc_conv_array_stride (se->expr, n);
2226 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2229 /* And add it to the total. */
2230 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2233 tmp = gfc_conv_array_offset (se->expr);
2234 if (!integer_zerop (tmp))
2235 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2237 /* Access the calculated element. */
2238 tmp = gfc_conv_array_data (se->expr);
2239 tmp = build_fold_indirect_ref (tmp);
2240 se->expr = gfc_build_array_ref (tmp, index);
2244 /* Generate the code to be executed immediately before entering a
2245 scalarization loop. */
2248 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2249 stmtblock_t * pblock)
2258 /* This code will be executed before entering the scalarization loop
2259 for this dimension. */
2260 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2262 if ((ss->useflags & flag) == 0)
2265 if (ss->type != GFC_SS_SECTION
2266 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2267 && ss->type != GFC_SS_COMPONENT)
2270 info = &ss->data.info;
2272 if (dim >= info->dimen)
2275 if (dim == info->dimen - 1)
2277 /* For the outermost loop calculate the offset due to any
2278 elemental dimensions. It will have been initialized with the
2279 base offset of the array. */
2282 for (i = 0; i < info->ref->u.ar.dimen; i++)
2284 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2287 gfc_init_se (&se, NULL);
2289 se.expr = info->descriptor;
2290 stride = gfc_conv_array_stride (info->descriptor, i);
2291 index = gfc_conv_array_index_offset (&se, info, i, -1,
2294 gfc_add_block_to_block (pblock, &se.pre);
2296 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2297 info->offset, index);
2298 info->offset = gfc_evaluate_now (info->offset, pblock);
2302 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2305 stride = gfc_conv_array_stride (info->descriptor, 0);
2307 /* Calculate the stride of the innermost loop. Hopefully this will
2308 allow the backend optimizers to do their stuff more effectively.
2310 info->stride0 = gfc_evaluate_now (stride, pblock);
2314 /* Add the offset for the previous loop dimension. */
2319 ar = &info->ref->u.ar;
2320 i = loop->order[dim + 1];
2328 gfc_init_se (&se, NULL);
2330 se.expr = info->descriptor;
2331 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2332 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2334 gfc_add_block_to_block (pblock, &se.pre);
2335 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2336 info->offset, index);
2337 info->offset = gfc_evaluate_now (info->offset, pblock);
2340 /* Remember this offset for the second loop. */
2341 if (dim == loop->temp_dim - 1)
2342 info->saved_offset = info->offset;
2347 /* Start a scalarized expression. Creates a scope and declares loop
2351 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2357 gcc_assert (!loop->array_parameter);
2359 for (dim = loop->dimen - 1; dim >= 0; dim--)
2361 n = loop->order[dim];
2363 gfc_start_block (&loop->code[n]);
2365 /* Create the loop variable. */
2366 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2368 if (dim < loop->temp_dim)
2372 /* Calculate values that will be constant within this loop. */
2373 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2375 gfc_start_block (pbody);
2379 /* Generates the actual loop code for a scalarization loop. */
2382 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2383 stmtblock_t * pbody)
2391 loopbody = gfc_finish_block (pbody);
2393 /* Initialize the loopvar. */
2394 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2396 exit_label = gfc_build_label_decl (NULL_TREE);
2398 /* Generate the loop body. */
2399 gfc_init_block (&block);
2401 /* The exit condition. */
2402 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2403 tmp = build1_v (GOTO_EXPR, exit_label);
2404 TREE_USED (exit_label) = 1;
2405 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2406 gfc_add_expr_to_block (&block, tmp);
2408 /* The main body. */
2409 gfc_add_expr_to_block (&block, loopbody);
2411 /* Increment the loopvar. */
2412 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2413 loop->loopvar[n], gfc_index_one_node);
2414 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2416 /* Build the loop. */
2417 tmp = gfc_finish_block (&block);
2418 tmp = build1_v (LOOP_EXPR, tmp);
2419 gfc_add_expr_to_block (&loop->code[n], tmp);
2421 /* Add the exit label. */
2422 tmp = build1_v (LABEL_EXPR, exit_label);
2423 gfc_add_expr_to_block (&loop->code[n], tmp);
2427 /* Finishes and generates the loops for a scalarized expression. */
2430 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2435 stmtblock_t *pblock;
2439 /* Generate the loops. */
2440 for (dim = 0; dim < loop->dimen; dim++)
2442 n = loop->order[dim];
2443 gfc_trans_scalarized_loop_end (loop, n, pblock);
2444 loop->loopvar[n] = NULL_TREE;
2445 pblock = &loop->code[n];
2448 tmp = gfc_finish_block (pblock);
2449 gfc_add_expr_to_block (&loop->pre, tmp);
2451 /* Clear all the used flags. */
2452 for (ss = loop->ss; ss; ss = ss->loop_chain)
2457 /* Finish the main body of a scalarized expression, and start the secondary
2461 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2465 stmtblock_t *pblock;
2469 /* We finish as many loops as are used by the temporary. */
2470 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2472 n = loop->order[dim];
2473 gfc_trans_scalarized_loop_end (loop, n, pblock);
2474 loop->loopvar[n] = NULL_TREE;
2475 pblock = &loop->code[n];
2478 /* We don't want to finish the outermost loop entirely. */
2479 n = loop->order[loop->temp_dim - 1];
2480 gfc_trans_scalarized_loop_end (loop, n, pblock);
2482 /* Restore the initial offsets. */
2483 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2485 if ((ss->useflags & 2) == 0)
2488 if (ss->type != GFC_SS_SECTION
2489 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2490 && ss->type != GFC_SS_COMPONENT)
2493 ss->data.info.offset = ss->data.info.saved_offset;
2496 /* Restart all the inner loops we just finished. */
2497 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2499 n = loop->order[dim];
2501 gfc_start_block (&loop->code[n]);
2503 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2505 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2508 /* Start a block for the secondary copying code. */
2509 gfc_start_block (body);
2513 /* Calculate the upper bound of an array section. */
2516 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2525 gcc_assert (ss->type == GFC_SS_SECTION);
2527 info = &ss->data.info;
2530 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2531 /* We'll calculate the upper bound once we have access to the
2532 vector's descriptor. */
2535 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2536 desc = info->descriptor;
2537 end = info->ref->u.ar.end[dim];
2541 /* The upper bound was specified. */
2542 gfc_init_se (&se, NULL);
2543 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2544 gfc_add_block_to_block (pblock, &se.pre);
2549 /* No upper bound was specified, so use the bound of the array. */
2550 bound = gfc_conv_array_ubound (desc, dim);
2557 /* Calculate the lower bound of an array section. */
2560 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2570 gcc_assert (ss->type == GFC_SS_SECTION);
2572 info = &ss->data.info;
2575 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2577 /* We use a zero-based index to access the vector. */
2578 info->start[n] = gfc_index_zero_node;
2579 info->end[n] = gfc_index_zero_node;
2580 info->stride[n] = gfc_index_one_node;
2584 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2585 desc = info->descriptor;
2586 start = info->ref->u.ar.start[dim];
2587 end = info->ref->u.ar.end[dim];
2588 stride = info->ref->u.ar.stride[dim];
2590 /* Calculate the start of the range. For vector subscripts this will
2591 be the range of the vector. */
2594 /* Specified section start. */
2595 gfc_init_se (&se, NULL);
2596 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2597 gfc_add_block_to_block (&loop->pre, &se.pre);
2598 info->start[n] = se.expr;
2602 /* No lower bound specified so use the bound of the array. */
2603 info->start[n] = gfc_conv_array_lbound (desc, dim);
2605 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2607 /* Similarly calculate the end. Although this is not used in the
2608 scalarizer, it is needed when checking bounds and where the end
2609 is an expression with side-effects. */
2612 /* Specified section start. */
2613 gfc_init_se (&se, NULL);
2614 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2615 gfc_add_block_to_block (&loop->pre, &se.pre);
2616 info->end[n] = se.expr;
2620 /* No upper bound specified so use the bound of the array. */
2621 info->end[n] = gfc_conv_array_ubound (desc, dim);
2623 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2625 /* Calculate the stride. */
2627 info->stride[n] = gfc_index_one_node;
2630 gfc_init_se (&se, NULL);
2631 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2632 gfc_add_block_to_block (&loop->pre, &se.pre);
2633 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2638 /* Calculates the range start and stride for a SS chain. Also gets the
2639 descriptor and data pointer. The range of vector subscripts is the size
2640 of the vector. Array bounds are also checked. */
2643 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2651 /* Determine the rank of the loop. */
2653 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2657 case GFC_SS_SECTION:
2658 case GFC_SS_CONSTRUCTOR:
2659 case GFC_SS_FUNCTION:
2660 case GFC_SS_COMPONENT:
2661 loop->dimen = ss->data.info.dimen;
2664 /* As usual, lbound and ubound are exceptions!. */
2665 case GFC_SS_INTRINSIC:
2666 switch (ss->expr->value.function.isym->generic_id)
2668 case GFC_ISYM_LBOUND:
2669 case GFC_ISYM_UBOUND:
2670 loop->dimen = ss->data.info.dimen;
2681 if (loop->dimen == 0)
2682 gfc_todo_error ("Unable to determine rank of expression");
2685 /* Loop over all the SS in the chain. */
2686 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2688 if (ss->expr && ss->expr->shape && !ss->shape)
2689 ss->shape = ss->expr->shape;
2693 case GFC_SS_SECTION:
2694 /* Get the descriptor for the array. */
2695 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2697 for (n = 0; n < ss->data.info.dimen; n++)
2698 gfc_conv_section_startstride (loop, ss, n);
2701 case GFC_SS_INTRINSIC:
2702 switch (ss->expr->value.function.isym->generic_id)
2704 /* Fall through to supply start and stride. */
2705 case GFC_ISYM_LBOUND:
2706 case GFC_ISYM_UBOUND:
2712 case GFC_SS_CONSTRUCTOR:
2713 case GFC_SS_FUNCTION:
2714 for (n = 0; n < ss->data.info.dimen; n++)
2716 ss->data.info.start[n] = gfc_index_zero_node;
2717 ss->data.info.end[n] = gfc_index_zero_node;
2718 ss->data.info.stride[n] = gfc_index_one_node;
2727 /* The rest is just runtime bound checking. */
2728 if (flag_bounds_check)
2731 tree lbound, ubound;
2733 tree size[GFC_MAX_DIMENSIONS];
2734 tree stride_pos, stride_neg, non_zerosized, tmp2;
2739 gfc_start_block (&block);
2741 for (n = 0; n < loop->dimen; n++)
2742 size[n] = NULL_TREE;
2744 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2746 if (ss->type != GFC_SS_SECTION)
2749 /* TODO: range checking for mapped dimensions. */
2750 info = &ss->data.info;
2752 /* This code only checks ranges. Elemental and vector
2753 dimensions are checked later. */
2754 for (n = 0; n < loop->dimen; n++)
2757 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2759 if (n == info->ref->u.ar.dimen - 1
2760 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2761 || info->ref->u.ar.as->cp_was_assumed))
2764 desc = ss->data.info.descriptor;
2766 /* This is the run-time equivalent of resolve.c's
2767 check_dimension(). The logical is more readable there
2768 than it is here, with all the trees. */
2769 lbound = gfc_conv_array_lbound (desc, dim);
2770 ubound = gfc_conv_array_ubound (desc, dim);
2773 /* Zero stride is not allowed. */
2774 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2775 gfc_index_zero_node);
2776 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2777 "of array '%s'", info->dim[n]+1,
2778 ss->expr->symtree->name);
2779 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2782 /* non_zerosized is true when the selected range is not
2784 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2785 info->stride[n], gfc_index_zero_node);
2786 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2788 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2791 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2792 info->stride[n], gfc_index_zero_node);
2793 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2795 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2797 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2798 stride_pos, stride_neg);
2800 /* Check the start of the range against the lower and upper
2801 bounds of the array, if the range is not empty. */
2802 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2804 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2805 non_zerosized, tmp);
2806 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2807 " exceeded", gfc_msg_fault, info->dim[n]+1,
2808 ss->expr->symtree->name);
2809 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2812 tmp = fold_build2 (GT_EXPR, boolean_type_node, info->start[n],
2814 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2815 non_zerosized, tmp);
2816 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2817 " exceeded", gfc_msg_fault, info->dim[n]+1,
2818 ss->expr->symtree->name);
2819 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2822 /* Compute the last element of the range, which is not
2823 necessarily "end" (think 0:5:3, which doesn't contain 5)
2824 and check it against both lower and upper bounds. */
2825 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2827 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2829 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2832 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2833 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2834 non_zerosized, tmp);
2835 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2836 " exceeded", gfc_msg_fault, info->dim[n]+1,
2837 ss->expr->symtree->name);
2838 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2841 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2842 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2843 non_zerosized, tmp);
2844 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2845 " exceeded", gfc_msg_fault, info->dim[n]+1,
2846 ss->expr->symtree->name);
2847 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2850 /* Check the section sizes match. */
2851 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2853 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2855 /* We remember the size of the first section, and check all the
2856 others against this. */
2860 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2861 asprintf (&msg, "%s, size mismatch for dimension %d "
2862 "of array '%s'", gfc_msg_bounds, info->dim[n]+1,
2863 ss->expr->symtree->name);
2864 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2868 size[n] = gfc_evaluate_now (tmp, &block);
2872 tmp = gfc_finish_block (&block);
2873 gfc_add_expr_to_block (&loop->pre, tmp);
2878 /* Return true if the two SS could be aliased, i.e. both point to the same data
2880 /* TODO: resolve aliases based on frontend expressions. */
2883 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2890 lsym = lss->expr->symtree->n.sym;
2891 rsym = rss->expr->symtree->n.sym;
2892 if (gfc_symbols_could_alias (lsym, rsym))
2895 if (rsym->ts.type != BT_DERIVED
2896 && lsym->ts.type != BT_DERIVED)
2899 /* For derived types we must check all the component types. We can ignore
2900 array references as these will have the same base type as the previous
2902 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2904 if (lref->type != REF_COMPONENT)
2907 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2910 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2913 if (rref->type != REF_COMPONENT)
2916 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2921 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2923 if (rref->type != REF_COMPONENT)
2926 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2934 /* Resolve array data dependencies. Creates a temporary if required. */
2935 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2939 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2949 loop->temp_ss = NULL;
2950 aref = dest->data.info.ref;
2953 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2955 if (ss->type != GFC_SS_SECTION)
2958 if (gfc_could_be_alias (dest, ss)
2959 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2965 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2967 lref = dest->expr->ref;
2968 rref = ss->expr->ref;
2970 nDepend = gfc_dep_resolver (lref, rref);
2972 /* TODO : loop shifting. */
2975 /* Mark the dimensions for LOOP SHIFTING */
2976 for (n = 0; n < loop->dimen; n++)
2978 int dim = dest->data.info.dim[n];
2980 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2982 else if (! gfc_is_same_range (&lref->u.ar,
2983 &rref->u.ar, dim, 0))
2987 /* Put all the dimensions with dependencies in the
2990 for (n = 0; n < loop->dimen; n++)
2992 gcc_assert (loop->order[n] == n);
2994 loop->order[dim++] = n;
2997 for (n = 0; n < loop->dimen; n++)
3000 loop->order[dim++] = n;
3003 gcc_assert (dim == loop->dimen);
3012 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3013 if (GFC_ARRAY_TYPE_P (base_type)
3014 || GFC_DESCRIPTOR_TYPE_P (base_type))
3015 base_type = gfc_get_element_type (base_type);
3016 loop->temp_ss = gfc_get_ss ();
3017 loop->temp_ss->type = GFC_SS_TEMP;
3018 loop->temp_ss->data.temp.type = base_type;
3019 loop->temp_ss->string_length = dest->string_length;
3020 loop->temp_ss->data.temp.dimen = loop->dimen;
3021 loop->temp_ss->next = gfc_ss_terminator;
3022 gfc_add_ss_to_loop (loop, loop->temp_ss);
3025 loop->temp_ss = NULL;
3029 /* Initialize the scalarization loop. Creates the loop variables. Determines
3030 the range of the loop variables. Creates a temporary if required.
3031 Calculates how to transform from loop variables to array indices for each
3032 expression. Also generates code for scalar expressions which have been
3033 moved outside the loop. */
3036 gfc_conv_loop_setup (gfc_loopinfo * loop)
3041 gfc_ss_info *specinfo;
3045 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3046 bool dynamic[GFC_MAX_DIMENSIONS];
3052 for (n = 0; n < loop->dimen; n++)
3056 /* We use one SS term, and use that to determine the bounds of the
3057 loop for this dimension. We try to pick the simplest term. */
3058 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3062 /* The frontend has worked out the size for us. */
3067 if (ss->type == GFC_SS_CONSTRUCTOR)
3069 /* An unknown size constructor will always be rank one.
3070 Higher rank constructors will either have known shape,
3071 or still be wrapped in a call to reshape. */
3072 gcc_assert (loop->dimen == 1);
3074 /* Always prefer to use the constructor bounds if the size
3075 can be determined at compile time. Prefer not to otherwise,
3076 since the general case involves realloc, and it's better to
3077 avoid that overhead if possible. */
3078 c = ss->expr->value.constructor;
3079 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3080 if (!dynamic[n] || !loopspec[n])
3085 /* TODO: Pick the best bound if we have a choice between a
3086 function and something else. */
3087 if (ss->type == GFC_SS_FUNCTION)
3093 if (ss->type != GFC_SS_SECTION)
3097 specinfo = &loopspec[n]->data.info;
3100 info = &ss->data.info;
3104 /* Criteria for choosing a loop specifier (most important first):
3105 doesn't need realloc
3111 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3113 else if (integer_onep (info->stride[n])
3114 && !integer_onep (specinfo->stride[n]))
3116 else if (INTEGER_CST_P (info->stride[n])
3117 && !INTEGER_CST_P (specinfo->stride[n]))
3119 else if (INTEGER_CST_P (info->start[n])
3120 && !INTEGER_CST_P (specinfo->start[n]))
3122 /* We don't work out the upper bound.
3123 else if (INTEGER_CST_P (info->finish[n])
3124 && ! INTEGER_CST_P (specinfo->finish[n]))
3125 loopspec[n] = ss; */
3129 gfc_todo_error ("Unable to find scalarization loop specifier");
3131 info = &loopspec[n]->data.info;
3133 /* Set the extents of this range. */
3134 cshape = loopspec[n]->shape;
3135 if (cshape && INTEGER_CST_P (info->start[n])
3136 && INTEGER_CST_P (info->stride[n]))
3138 loop->from[n] = info->start[n];
3139 mpz_set (i, cshape[n]);
3140 mpz_sub_ui (i, i, 1);
3141 /* To = from + (size - 1) * stride. */
3142 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3143 if (!integer_onep (info->stride[n]))
3144 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3145 tmp, info->stride[n]);
3146 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3147 loop->from[n], tmp);
3151 loop->from[n] = info->start[n];
3152 switch (loopspec[n]->type)
3154 case GFC_SS_CONSTRUCTOR:
3155 /* The upper bound is calculated when we expand the
3157 gcc_assert (loop->to[n] == NULL_TREE);
3160 case GFC_SS_SECTION:
3161 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3165 case GFC_SS_FUNCTION:
3166 /* The loop bound will be set when we generate the call. */
3167 gcc_assert (loop->to[n] == NULL_TREE);
3175 /* Transform everything so we have a simple incrementing variable. */
3176 if (integer_onep (info->stride[n]))
3177 info->delta[n] = gfc_index_zero_node;
3180 /* Set the delta for this section. */
3181 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3182 /* Number of iterations is (end - start + step) / step.
3183 with start = 0, this simplifies to
3185 for (i = 0; i<=last; i++){...}; */
3186 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3187 loop->to[n], loop->from[n]);
3188 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3189 tmp, info->stride[n]);
3190 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3191 /* Make the loop variable start at 0. */
3192 loop->from[n] = gfc_index_zero_node;
3196 /* Add all the scalar code that can be taken out of the loops.
3197 This may include calculating the loop bounds, so do it before
3198 allocating the temporary. */
3199 gfc_add_loop_ss_code (loop, loop->ss, false);
3201 /* If we want a temporary then create it. */
3202 if (loop->temp_ss != NULL)
3204 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3205 tmp = loop->temp_ss->data.temp.type;
3206 len = loop->temp_ss->string_length;
3207 n = loop->temp_ss->data.temp.dimen;
3208 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3209 loop->temp_ss->type = GFC_SS_SECTION;
3210 loop->temp_ss->data.info.dimen = n;
3211 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3212 &loop->temp_ss->data.info, tmp, false, true,
3216 for (n = 0; n < loop->temp_dim; n++)
3217 loopspec[loop->order[n]] = NULL;
3221 /* For array parameters we don't have loop variables, so don't calculate the
3223 if (loop->array_parameter)
3226 /* Calculate the translation from loop variables to array indices. */
3227 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3229 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3232 info = &ss->data.info;
3234 for (n = 0; n < info->dimen; n++)
3238 /* If we are specifying the range the delta is already set. */
3239 if (loopspec[n] != ss)
3241 /* Calculate the offset relative to the loop variable.
3242 First multiply by the stride. */
3243 tmp = loop->from[n];
3244 if (!integer_onep (info->stride[n]))
3245 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3246 tmp, info->stride[n]);
3248 /* Then subtract this from our starting value. */
3249 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3250 info->start[n], tmp);
3252 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3259 /* Fills in an array descriptor, and returns the size of the array. The size
3260 will be a simple_val, ie a variable or a constant. Also calculates the
3261 offset of the base. Returns the size of the array.
3265 for (n = 0; n < rank; n++)
3267 a.lbound[n] = specified_lower_bound;
3268 offset = offset + a.lbond[n] * stride;
3270 a.ubound[n] = specified_upper_bound;
3271 a.stride[n] = stride;
3272 size = ubound + size; //size = ubound + 1 - lbound
3273 stride = stride * size;
3280 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3281 gfc_expr ** lower, gfc_expr ** upper,
3282 stmtblock_t * pblock)
3294 stmtblock_t thenblock;
3295 stmtblock_t elseblock;
3300 type = TREE_TYPE (descriptor);
3302 stride = gfc_index_one_node;
3303 offset = gfc_index_zero_node;
3305 /* Set the dtype. */
3306 tmp = gfc_conv_descriptor_dtype (descriptor);
3307 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3309 or_expr = NULL_TREE;
3311 for (n = 0; n < rank; n++)
3313 /* We have 3 possibilities for determining the size of the array:
3314 lower == NULL => lbound = 1, ubound = upper[n]
3315 upper[n] = NULL => lbound = 1, ubound = lower[n]
3316 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3319 /* Set lower bound. */
3320 gfc_init_se (&se, NULL);
3322 se.expr = gfc_index_one_node;
3325 gcc_assert (lower[n]);
3328 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3329 gfc_add_block_to_block (pblock, &se.pre);
3333 se.expr = gfc_index_one_node;
3337 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3338 gfc_add_modify_expr (pblock, tmp, se.expr);
3340 /* Work out the offset for this component. */
3341 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3342 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3344 /* Start the calculation for the size of this dimension. */
3345 size = build2 (MINUS_EXPR, gfc_array_index_type,
3346 gfc_index_one_node, se.expr);
3348 /* Set upper bound. */
3349 gfc_init_se (&se, NULL);
3350 gcc_assert (ubound);
3351 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3352 gfc_add_block_to_block (pblock, &se.pre);
3354 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3355 gfc_add_modify_expr (pblock, tmp, se.expr);
3357 /* Store the stride. */
3358 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3359 gfc_add_modify_expr (pblock, tmp, stride);
3361 /* Calculate the size of this dimension. */
3362 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3364 /* Check whether the size for this dimension is negative. */
3365 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3366 gfc_index_zero_node);
3370 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3372 /* Multiply the stride by the number of elements in this dimension. */
3373 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3374 stride = gfc_evaluate_now (stride, pblock);
3377 /* The stride is the number of elements in the array, so multiply by the
3378 size of an element to get the total size. */
3379 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3380 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
3382 if (poffset != NULL)
3384 offset = gfc_evaluate_now (offset, pblock);
3388 if (integer_zerop (or_expr))
3390 if (integer_onep (or_expr))
3391 return gfc_index_zero_node;
3393 var = gfc_create_var (TREE_TYPE (size), "size");
3394 gfc_start_block (&thenblock);
3395 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3396 thencase = gfc_finish_block (&thenblock);
3398 gfc_start_block (&elseblock);
3399 gfc_add_modify_expr (&elseblock, var, size);
3400 elsecase = gfc_finish_block (&elseblock);
3402 tmp = gfc_evaluate_now (or_expr, pblock);
3403 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3404 gfc_add_expr_to_block (pblock, tmp);
3410 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3411 the work for an ALLOCATE statement. */
3415 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3424 gfc_ref *ref, *prev_ref = NULL;
3425 bool allocatable_array;
3429 /* Find the last reference in the chain. */
3430 while (ref && ref->next != NULL)
3432 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3437 if (ref == NULL || ref->type != REF_ARRAY)
3441 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3443 allocatable_array = prev_ref->u.c.component->allocatable;
3445 /* Figure out the size of the array. */
3446 switch (ref->u.ar.type)
3450 upper = ref->u.ar.start;
3454 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3456 lower = ref->u.ar.as->lower;
3457 upper = ref->u.ar.as->upper;
3461 lower = ref->u.ar.start;
3462 upper = ref->u.ar.end;
3470 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3471 lower, upper, &se->pre);
3473 /* Allocate memory to store the data. */
3474 pointer = gfc_conv_descriptor_data_get (se->expr);
3475 STRIP_NOPS (pointer);
3477 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3479 if (allocatable_array)
3480 allocate = gfor_fndecl_allocate_array;
3482 allocate = gfor_fndecl_allocate;
3484 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3486 if (allocatable_array)
3487 allocate = gfor_fndecl_allocate64_array;
3489 allocate = gfor_fndecl_allocate64;
3495 /* The allocate_array variants take the old pointer as first argument. */
3496 if (allocatable_array)
3497 tmp = gfc_chainon_list (tmp, pointer);
3498 tmp = gfc_chainon_list (tmp, size);
3499 tmp = gfc_chainon_list (tmp, pstat);
3500 tmp = build_function_call_expr (allocate, tmp);
3501 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3502 gfc_add_expr_to_block (&se->pre, tmp);
3504 tmp = gfc_conv_descriptor_offset (se->expr);
3505 gfc_add_modify_expr (&se->pre, tmp, offset);
3507 if (expr->ts.type == BT_DERIVED
3508 && expr->ts.derived->attr.alloc_comp)
3510 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3511 ref->u.ar.as->rank);
3512 gfc_add_expr_to_block (&se->pre, tmp);
3519 /* Deallocate an array variable. Also used when an allocated variable goes
3524 gfc_array_deallocate (tree descriptor, tree pstat)
3530 gfc_start_block (&block);
3531 /* Get a pointer to the data. */
3532 var = gfc_conv_descriptor_data_get (descriptor);
3535 /* Parameter is the address of the data component. */
3536 tmp = gfc_chainon_list (NULL_TREE, var);
3537 tmp = gfc_chainon_list (tmp, pstat);
3538 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3539 gfc_add_expr_to_block (&block, tmp);
3541 /* Zero the data pointer. */
3542 tmp = build2 (MODIFY_EXPR, void_type_node,
3543 var, build_int_cst (TREE_TYPE (var), 0));
3544 gfc_add_expr_to_block (&block, tmp);
3546 return gfc_finish_block (&block);
3550 /* Create an array constructor from an initialization expression.
3551 We assume the frontend already did any expansions and conversions. */
3554 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3561 unsigned HOST_WIDE_INT lo;
3563 VEC(constructor_elt,gc) *v = NULL;
3565 switch (expr->expr_type)
3568 case EXPR_STRUCTURE:
3569 /* A single scalar or derived type value. Create an array with all
3570 elements equal to that value. */
3571 gfc_init_se (&se, NULL);
3573 if (expr->expr_type == EXPR_CONSTANT)
3574 gfc_conv_constant (&se, expr);
3576 gfc_conv_structure (&se, expr, 1);
3578 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3579 gcc_assert (tmp && INTEGER_CST_P (tmp));
3580 hi = TREE_INT_CST_HIGH (tmp);
3581 lo = TREE_INT_CST_LOW (tmp);
3585 /* This will probably eat buckets of memory for large arrays. */
3586 while (hi != 0 || lo != 0)
3588 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3596 /* Create a vector of all the elements. */
3597 for (c = expr->value.constructor; c; c = c->next)
3601 /* Problems occur when we get something like
3602 integer :: a(lots) = (/(i, i=1,lots)/) */
3603 /* TODO: Unexpanded array initializers. */
3605 ("Possible frontend bug: array constructor not expanded");
3607 if (mpz_cmp_si (c->n.offset, 0) != 0)
3608 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3612 if (mpz_cmp_si (c->repeat, 0) != 0)
3616 mpz_set (maxval, c->repeat);
3617 mpz_add (maxval, c->n.offset, maxval);
3618 mpz_sub_ui (maxval, maxval, 1);
3619 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3620 if (mpz_cmp_si (c->n.offset, 0) != 0)
3622 mpz_add_ui (maxval, c->n.offset, 1);
3623 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3626 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3628 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3634 gfc_init_se (&se, NULL);
3635 switch (c->expr->expr_type)
3638 gfc_conv_constant (&se, c->expr);
3639 if (range == NULL_TREE)
3640 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3643 if (index != NULL_TREE)
3644 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3645 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3649 case EXPR_STRUCTURE:
3650 gfc_conv_structure (&se, c->expr, 1);
3651 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3661 return gfc_build_null_descriptor (type);
3667 /* Create a constructor from the list of elements. */
3668 tmp = build_constructor (type, v);
3669 TREE_CONSTANT (tmp) = 1;
3670 TREE_INVARIANT (tmp) = 1;
3675 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3676 returns the size (in elements) of the array. */
3679 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3680 stmtblock_t * pblock)
3695 size = gfc_index_one_node;
3696 offset = gfc_index_zero_node;
3697 for (dim = 0; dim < as->rank; dim++)
3699 /* Evaluate non-constant array bound expressions. */
3700 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3701 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3703 gfc_init_se (&se, NULL);
3704 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3705 gfc_add_block_to_block (pblock, &se.pre);
3706 gfc_add_modify_expr (pblock, lbound, se.expr);
3708 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3709 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3711 gfc_init_se (&se, NULL);
3712 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3713 gfc_add_block_to_block (pblock, &se.pre);
3714 gfc_add_modify_expr (pblock, ubound, se.expr);
3716 /* The offset of this dimension. offset = offset - lbound * stride. */
3717 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3718 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3720 /* The size of this dimension, and the stride of the next. */
3721 if (dim + 1 < as->rank)
3722 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3724 stride = GFC_TYPE_ARRAY_SIZE (type);
3726 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3728 /* Calculate stride = size * (ubound + 1 - lbound). */
3729 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3730 gfc_index_one_node, lbound);
3731 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3732 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3734 gfc_add_modify_expr (pblock, stride, tmp);
3736 stride = gfc_evaluate_now (tmp, pblock);
3738 /* Make sure that negative size arrays are translated
3739 to being zero size. */
3740 tmp = build2 (GE_EXPR, boolean_type_node,
3741 stride, gfc_index_zero_node);
3742 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3743 stride, gfc_index_zero_node);
3744 gfc_add_modify_expr (pblock, stride, tmp);
3750 gfc_trans_vla_type_sizes (sym, pblock);
3757 /* Generate code to initialize/allocate an array variable. */
3760 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3770 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3772 /* Do nothing for USEd variables. */
3773 if (sym->attr.use_assoc)
3776 type = TREE_TYPE (decl);
3777 gcc_assert (GFC_ARRAY_TYPE_P (type));
3778 onstack = TREE_CODE (type) != POINTER_TYPE;
3780 gfc_start_block (&block);
3782 /* Evaluate character string length. */
3783 if (sym->ts.type == BT_CHARACTER
3784 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3786 gfc_trans_init_string_length (sym->ts.cl, &block);
3788 gfc_trans_vla_type_sizes (sym, &block);
3790 /* Emit a DECL_EXPR for this variable, which will cause the
3791 gimplifier to allocate storage, and all that good stuff. */
3792 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3793 gfc_add_expr_to_block (&block, tmp);
3798 gfc_add_expr_to_block (&block, fnbody);
3799 return gfc_finish_block (&block);
3802 type = TREE_TYPE (type);
3804 gcc_assert (!sym->attr.use_assoc);
3805 gcc_assert (!TREE_STATIC (decl));
3806 gcc_assert (!sym->module);
3808 if (sym->ts.type == BT_CHARACTER
3809 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3810 gfc_trans_init_string_length (sym->ts.cl, &block);
3812 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3814 /* Don't actually allocate space for Cray Pointees. */
3815 if (sym->attr.cray_pointee)
3817 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3818 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3819 gfc_add_expr_to_block (&block, fnbody);
3820 return gfc_finish_block (&block);
3823 /* The size is the number of elements in the array, so multiply by the
3824 size of an element to get the total size. */
3825 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3826 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3828 /* Allocate memory to hold the data. */
3829 tmp = gfc_chainon_list (NULL_TREE, size);
3831 if (gfc_index_integer_kind == 4)
3832 fndecl = gfor_fndecl_internal_malloc;
3833 else if (gfc_index_integer_kind == 8)
3834 fndecl = gfor_fndecl_internal_malloc64;
3837 tmp = build_function_call_expr (fndecl, tmp);
3838 tmp = fold (convert (TREE_TYPE (decl), tmp));
3839 gfc_add_modify_expr (&block, decl, tmp);
3841 /* Set offset of the array. */
3842 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3843 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3846 /* Automatic arrays should not have initializers. */
3847 gcc_assert (!sym->value);
3849 gfc_add_expr_to_block (&block, fnbody);
3851 /* Free the temporary. */
3852 tmp = convert (pvoid_type_node, decl);
3853 tmp = gfc_chainon_list (NULL_TREE, tmp);
3854 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3855 gfc_add_expr_to_block (&block, tmp);
3857 return gfc_finish_block (&block);
3861 /* Generate entry and exit code for g77 calling convention arrays. */
3864 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3874 gfc_get_backend_locus (&loc);
3875 gfc_set_backend_locus (&sym->declared_at);
3877 /* Descriptor type. */
3878 parm = sym->backend_decl;
3879 type = TREE_TYPE (parm);
3880 gcc_assert (GFC_ARRAY_TYPE_P (type));
3882 gfc_start_block (&block);
3884 if (sym->ts.type == BT_CHARACTER
3885 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3886 gfc_trans_init_string_length (sym->ts.cl, &block);
3888 /* Evaluate the bounds of the array. */
3889 gfc_trans_array_bounds (type, sym, &offset, &block);
3891 /* Set the offset. */
3892 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3893 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3895 /* Set the pointer itself if we aren't using the parameter directly. */
3896 if (TREE_CODE (parm) != PARM_DECL)
3898 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3899 gfc_add_modify_expr (&block, parm, tmp);
3901 stmt = gfc_finish_block (&block);
3903 gfc_set_backend_locus (&loc);
3905 gfc_start_block (&block);
3907 /* Add the initialization code to the start of the function. */
3909 if (sym->attr.optional || sym->attr.not_always_present)
3911 tmp = gfc_conv_expr_present (sym);
3912 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3915 gfc_add_expr_to_block (&block, stmt);
3916 gfc_add_expr_to_block (&block, body);
3918 return gfc_finish_block (&block);
3922 /* Modify the descriptor of an array parameter so that it has the
3923 correct lower bound. Also move the upper bound accordingly.
3924 If the array is not packed, it will be copied into a temporary.
3925 For each dimension we set the new lower and upper bounds. Then we copy the
3926 stride and calculate the offset for this dimension. We also work out
3927 what the stride of a packed array would be, and see it the two match.
3928 If the array need repacking, we set the stride to the values we just
3929 calculated, recalculate the offset and copy the array data.
3930 Code is also added to copy the data back at the end of the function.
3934 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3941 stmtblock_t cleanup;
3949 tree stride, stride2;
3959 /* Do nothing for pointer and allocatable arrays. */
3960 if (sym->attr.pointer || sym->attr.allocatable)
3963 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3964 return gfc_trans_g77_array (sym, body);
3966 gfc_get_backend_locus (&loc);
3967 gfc_set_backend_locus (&sym->declared_at);
3969 /* Descriptor type. */
3970 type = TREE_TYPE (tmpdesc);
3971 gcc_assert (GFC_ARRAY_TYPE_P (type));
3972 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3973 dumdesc = build_fold_indirect_ref (dumdesc);
3974 gfc_start_block (&block);
3976 if (sym->ts.type == BT_CHARACTER
3977 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3978 gfc_trans_init_string_length (sym->ts.cl, &block);
3980 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3982 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3983 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3985 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3987 /* For non-constant shape arrays we only check if the first dimension
3988 is contiguous. Repacking higher dimensions wouldn't gain us
3989 anything as we still don't know the array stride. */
3990 partial = gfc_create_var (boolean_type_node, "partial");
3991 TREE_USED (partial) = 1;
3992 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3993 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
3994 gfc_add_modify_expr (&block, partial, tmp);
3998 partial = NULL_TREE;
4001 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4002 here, however I think it does the right thing. */
4005 /* Set the first stride. */
4006 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4007 stride = gfc_evaluate_now (stride, &block);
4009 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4010 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4011 gfc_index_one_node, stride);
4012 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4013 gfc_add_modify_expr (&block, stride, tmp);
4015 /* Allow the user to disable array repacking. */
4016 stmt_unpacked = NULL_TREE;
4020 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4021 /* A library call to repack the array if necessary. */
4022 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4023 tmp = gfc_chainon_list (NULL_TREE, tmp);
4024 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4026 stride = gfc_index_one_node;
4029 /* This is for the case where the array data is used directly without
4030 calling the repack function. */
4031 if (no_repack || partial != NULL_TREE)
4032 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4034 stmt_packed = NULL_TREE;
4036 /* Assign the data pointer. */
4037 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4039 /* Don't repack unknown shape arrays when the first stride is 1. */
4040 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4041 stmt_packed, stmt_unpacked);
4044 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4045 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4047 offset = gfc_index_zero_node;
4048 size = gfc_index_one_node;
4050 /* Evaluate the bounds of the array. */
4051 for (n = 0; n < sym->as->rank; n++)
4053 if (checkparm || !sym->as->upper[n])
4055 /* Get the bounds of the actual parameter. */
4056 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4057 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4061 dubound = NULL_TREE;
4062 dlbound = NULL_TREE;
4065 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4066 if (!INTEGER_CST_P (lbound))
4068 gfc_init_se (&se, NULL);
4069 gfc_conv_expr_type (&se, sym->as->lower[n],
4070 gfc_array_index_type);
4071 gfc_add_block_to_block (&block, &se.pre);
4072 gfc_add_modify_expr (&block, lbound, se.expr);
4075 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4076 /* Set the desired upper bound. */
4077 if (sym->as->upper[n])
4079 /* We know what we want the upper bound to be. */
4080 if (!INTEGER_CST_P (ubound))
4082 gfc_init_se (&se, NULL);
4083 gfc_conv_expr_type (&se, sym->as->upper[n],
4084 gfc_array_index_type);
4085 gfc_add_block_to_block (&block, &se.pre);
4086 gfc_add_modify_expr (&block, ubound, se.expr);
4089 /* Check the sizes match. */
4092 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4095 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4097 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4099 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4100 asprintf (&msg, "%s for dimension %d of array '%s'",
4101 gfc_msg_bounds, n+1, sym->name);
4102 gfc_trans_runtime_check (tmp, msg, &block, &loc);
4108 /* For assumed shape arrays move the upper bound by the same amount
4109 as the lower bound. */
4110 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4111 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4112 gfc_add_modify_expr (&block, ubound, tmp);
4114 /* The offset of this dimension. offset = offset - lbound * stride. */
4115 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4116 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4118 /* The size of this dimension, and the stride of the next. */
4119 if (n + 1 < sym->as->rank)
4121 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4123 if (no_repack || partial != NULL_TREE)
4126 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4129 /* Figure out the stride if not a known constant. */
4130 if (!INTEGER_CST_P (stride))
4133 stmt_packed = NULL_TREE;
4136 /* Calculate stride = size * (ubound + 1 - lbound). */
4137 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4138 gfc_index_one_node, lbound);
4139 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4141 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4146 /* Assign the stride. */
4147 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4148 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4149 stmt_unpacked, stmt_packed);
4151 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4152 gfc_add_modify_expr (&block, stride, tmp);
4157 stride = GFC_TYPE_ARRAY_SIZE (type);
4159 if (stride && !INTEGER_CST_P (stride))
4161 /* Calculate size = stride * (ubound + 1 - lbound). */
4162 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4163 gfc_index_one_node, lbound);
4164 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4166 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4167 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4168 gfc_add_modify_expr (&block, stride, tmp);
4173 /* Set the offset. */
4174 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4175 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4177 gfc_trans_vla_type_sizes (sym, &block);
4179 stmt = gfc_finish_block (&block);
4181 gfc_start_block (&block);
4183 /* Only do the entry/initialization code if the arg is present. */
4184 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4185 optional_arg = (sym->attr.optional
4186 || (sym->ns->proc_name->attr.entry_master
4187 && sym->attr.dummy));
4190 tmp = gfc_conv_expr_present (sym);
4191 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4193 gfc_add_expr_to_block (&block, stmt);
4195 /* Add the main function body. */
4196 gfc_add_expr_to_block (&block, body);
4201 gfc_start_block (&cleanup);
4203 if (sym->attr.intent != INTENT_IN)
4205 /* Copy the data back. */
4206 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
4207 tmp = gfc_chainon_list (tmp, tmpdesc);
4208 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4209 gfc_add_expr_to_block (&cleanup, tmp);
4212 /* Free the temporary. */
4213 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
4214 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4215 gfc_add_expr_to_block (&cleanup, tmp);
4217 stmt = gfc_finish_block (&cleanup);
4219 /* Only do the cleanup if the array was repacked. */
4220 tmp = build_fold_indirect_ref (dumdesc);
4221 tmp = gfc_conv_descriptor_data_get (tmp);
4222 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4223 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4227 tmp = gfc_conv_expr_present (sym);
4228 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4230 gfc_add_expr_to_block (&block, stmt);
4232 /* We don't need to free any memory allocated by internal_pack as it will
4233 be freed at the end of the function by pop_context. */
4234 return gfc_finish_block (&block);
4238 /* Convert an array for passing as an actual argument. Expressions and
4239 vector subscripts are evaluated and stored in a temporary, which is then
4240 passed. For whole arrays the descriptor is passed. For array sections
4241 a modified copy of the descriptor is passed, but using the original data.
4243 This function is also used for array pointer assignments, and there
4246 - want_pointer && !se->direct_byref
4247 EXPR is an actual argument. On exit, se->expr contains a
4248 pointer to the array descriptor.
4250 - !want_pointer && !se->direct_byref
4251 EXPR is an actual argument to an intrinsic function or the
4252 left-hand side of a pointer assignment. On exit, se->expr
4253 contains the descriptor for EXPR.
4255 - !want_pointer && se->direct_byref
4256 EXPR is the right-hand side of a pointer assignment and
4257 se->expr is the descriptor for the previously-evaluated
4258 left-hand side. The function creates an assignment from
4259 EXPR to se->expr. */
4262 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4276 gcc_assert (ss != gfc_ss_terminator);
4278 /* Special case things we know we can pass easily. */
4279 switch (expr->expr_type)
4282 /* If we have a linear array section, we can pass it directly.
4283 Otherwise we need to copy it into a temporary. */
4285 /* Find the SS for the array section. */
4287 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4288 secss = secss->next;
4290 gcc_assert (secss != gfc_ss_terminator);
4291 info = &secss->data.info;
4293 /* Get the descriptor for the array. */
4294 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4295 desc = info->descriptor;
4297 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4300 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4302 /* Create a new descriptor if the array doesn't have one. */
4305 else if (info->ref->u.ar.type == AR_FULL)
4307 else if (se->direct_byref)
4310 full = gfc_full_array_ref_p (info->ref);
4314 if (se->direct_byref)
4316 /* Copy the descriptor for pointer assignments. */
4317 gfc_add_modify_expr (&se->pre, se->expr, desc);
4319 else if (se->want_pointer)
4321 /* We pass full arrays directly. This means that pointers and
4322 allocatable arrays should also work. */
4323 se->expr = build_fold_addr_expr (desc);
4330 if (expr->ts.type == BT_CHARACTER)
4331 se->string_length = gfc_get_expr_charlen (expr);
4338 /* A transformational function return value will be a temporary
4339 array descriptor. We still need to go through the scalarizer
4340 to create the descriptor. Elemental functions ar handled as
4341 arbitrary expressions, i.e. copy to a temporary. */
4343 /* Look for the SS for this function. */
4344 while (secss != gfc_ss_terminator
4345 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4346 secss = secss->next;
4348 if (se->direct_byref)
4350 gcc_assert (secss != gfc_ss_terminator);
4352 /* For pointer assignments pass the descriptor directly. */
4354 se->expr = build_fold_addr_expr (se->expr);
4355 gfc_conv_expr (se, expr);
4359 if (secss == gfc_ss_terminator)
4361 /* Elemental function. */
4367 /* Transformational function. */
4368 info = &secss->data.info;
4374 /* Constant array constructors don't need a temporary. */
4375 if (ss->type == GFC_SS_CONSTRUCTOR
4376 && expr->ts.type != BT_CHARACTER
4377 && gfc_constant_array_constructor_p (expr->value.constructor))
4380 info = &ss->data.info;
4392 /* Something complicated. Copy it into a temporary. */
4400 gfc_init_loopinfo (&loop);
4402 /* Associate the SS with the loop. */
4403 gfc_add_ss_to_loop (&loop, ss);
4405 /* Tell the scalarizer not to bother creating loop variables, etc. */
4407 loop.array_parameter = 1;
4409 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4410 gcc_assert (!se->direct_byref);
4412 /* Setup the scalarizing loops and bounds. */
4413 gfc_conv_ss_startstride (&loop);
4417 /* Tell the scalarizer to make a temporary. */
4418 loop.temp_ss = gfc_get_ss ();
4419 loop.temp_ss->type = GFC_SS_TEMP;
4420 loop.temp_ss->next = gfc_ss_terminator;
4421 if (expr->ts.type == BT_CHARACTER)
4423 if (expr->ts.cl == NULL)
4425 /* This had better be a substring reference! */
4426 gfc_ref *char_ref = expr->ref;
4427 for (; char_ref; char_ref = char_ref->next)
4428 if (char_ref->type == REF_SUBSTRING)
4431 expr->ts.cl = gfc_get_charlen ();
4432 expr->ts.cl->next = char_ref->u.ss.length->next;
4433 char_ref->u.ss.length->next = expr->ts.cl;
4435 mpz_init_set_ui (char_len, 1);
4436 mpz_add (char_len, char_len,
4437 char_ref->u.ss.end->value.integer);
4438 mpz_sub (char_len, char_len,
4439 char_ref->u.ss.start->value.integer);
4440 expr->ts.cl->backend_decl
4441 = gfc_conv_mpz_to_tree (char_len,
4442 gfc_default_character_kind);
4443 /* Cast is necessary for *-charlen refs. */
4444 expr->ts.cl->backend_decl
4445 = convert (gfc_charlen_type_node,
4446 expr->ts.cl->backend_decl);
4447 mpz_clear (char_len);
4450 gcc_assert (char_ref != NULL);
4451 loop.temp_ss->data.temp.type
4452 = gfc_typenode_for_spec (&expr->ts);
4453 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4455 else if (expr->ts.cl->length
4456 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4458 expr->ts.cl->backend_decl
4459 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4460 expr->ts.cl->length->ts.kind);
4461 loop.temp_ss->data.temp.type
4462 = gfc_typenode_for_spec (&expr->ts);
4463 loop.temp_ss->string_length
4464 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4468 loop.temp_ss->data.temp.type
4469 = gfc_typenode_for_spec (&expr->ts);
4470 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4472 se->string_length = loop.temp_ss->string_length;
4476 loop.temp_ss->data.temp.type
4477 = gfc_typenode_for_spec (&expr->ts);
4478 loop.temp_ss->string_length = NULL;
4480 loop.temp_ss->data.temp.dimen = loop.dimen;
4481 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4484 gfc_conv_loop_setup (&loop);
4488 /* Copy into a temporary and pass that. We don't need to copy the data
4489 back because expressions and vector subscripts must be INTENT_IN. */
4490 /* TODO: Optimize passing function return values. */
4494 /* Start the copying loops. */
4495 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4496 gfc_mark_ss_chain_used (ss, 1);
4497 gfc_start_scalarized_body (&loop, &block);
4499 /* Copy each data element. */
4500 gfc_init_se (&lse, NULL);
4501 gfc_copy_loopinfo_to_se (&lse, &loop);
4502 gfc_init_se (&rse, NULL);
4503 gfc_copy_loopinfo_to_se (&rse, &loop);
4505 lse.ss = loop.temp_ss;
4508 gfc_conv_scalarized_array_ref (&lse, NULL);
4509 if (expr->ts.type == BT_CHARACTER)
4511 gfc_conv_expr (&rse, expr);
4512 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4513 rse.expr = build_fold_indirect_ref (rse.expr);
4516 gfc_conv_expr_val (&rse, expr);
4518 gfc_add_block_to_block (&block, &rse.pre);
4519 gfc_add_block_to_block (&block, &lse.pre);
4521 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4523 /* Finish the copying loops. */
4524 gfc_trans_scalarizing_loops (&loop, &block);
4526 desc = loop.temp_ss->data.info.descriptor;
4528 gcc_assert (is_gimple_lvalue (desc));
4530 else if (expr->expr_type == EXPR_FUNCTION)
4532 desc = info->descriptor;
4533 se->string_length = ss->string_length;
4537 /* We pass sections without copying to a temporary. Make a new
4538 descriptor and point it at the section we want. The loop variable
4539 limits will be the limits of the section.
4540 A function may decide to repack the array to speed up access, but
4541 we're not bothered about that here. */
4550 /* Set the string_length for a character array. */
4551 if (expr->ts.type == BT_CHARACTER)
4552 se->string_length = gfc_get_expr_charlen (expr);
4554 desc = info->descriptor;
4555 gcc_assert (secss && secss != gfc_ss_terminator);
4556 if (se->direct_byref)
4558 /* For pointer assignments we fill in the destination. */
4560 parmtype = TREE_TYPE (parm);
4564 /* Otherwise make a new one. */
4565 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4566 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4567 loop.from, loop.to, 0);
4568 parm = gfc_create_var (parmtype, "parm");
4571 offset = gfc_index_zero_node;
4574 /* The following can be somewhat confusing. We have two
4575 descriptors, a new one and the original array.
4576 {parm, parmtype, dim} refer to the new one.
4577 {desc, type, n, secss, loop} refer to the original, which maybe
4578 a descriptorless array.
4579 The bounds of the scalarization are the bounds of the section.
4580 We don't have to worry about numeric overflows when calculating
4581 the offsets because all elements are within the array data. */
4583 /* Set the dtype. */
4584 tmp = gfc_conv_descriptor_dtype (parm);
4585 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4587 if (se->direct_byref)
4588 base = gfc_index_zero_node;
4592 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4593 for (n = 0; n < ndim; n++)
4595 stride = gfc_conv_array_stride (desc, n);
4597 /* Work out the offset. */
4599 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4601 gcc_assert (info->subscript[n]
4602 && info->subscript[n]->type == GFC_SS_SCALAR);
4603 start = info->subscript[n]->data.scalar.expr;
4607 /* Check we haven't somehow got out of sync. */
4608 gcc_assert (info->dim[dim] == n);
4610 /* Evaluate and remember the start of the section. */
4611 start = info->start[dim];
4612 stride = gfc_evaluate_now (stride, &loop.pre);
4615 tmp = gfc_conv_array_lbound (desc, n);
4616 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4618 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4619 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4622 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4624 /* For elemental dimensions, we only need the offset. */
4628 /* Vector subscripts need copying and are handled elsewhere. */
4630 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4632 /* Set the new lower bound. */
4633 from = loop.from[dim];
4636 /* If we have an array section or are assigning to a pointer,
4637 make sure that the lower bound is 1. References to the full
4638 array should otherwise keep the original bounds. */
4640 || info->ref->u.ar.type != AR_FULL
4641 || se->direct_byref)
4642 && !integer_onep (from))
4644 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4645 gfc_index_one_node, from);
4646 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4647 from = gfc_index_one_node;
4649 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4650 gfc_add_modify_expr (&loop.pre, tmp, from);
4652 /* Set the new upper bound. */
4653 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4654 gfc_add_modify_expr (&loop.pre, tmp, to);
4656 /* Multiply the stride by the section stride to get the
4658 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4659 stride, info->stride[dim]);
4661 if (se->direct_byref)
4662 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4665 /* Store the new stride. */
4666 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4667 gfc_add_modify_expr (&loop.pre, tmp, stride);
4672 if (se->data_not_needed)
4673 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4676 /* Point the data pointer at the first element in the section. */
4677 tmp = gfc_conv_array_data (desc);
4678 tmp = build_fold_indirect_ref (tmp);
4679 tmp = gfc_build_array_ref (tmp, offset);
4680 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4681 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4684 if (se->direct_byref && !se->data_not_needed)
4686 /* Set the offset. */
4687 tmp = gfc_conv_descriptor_offset (parm);
4688 gfc_add_modify_expr (&loop.pre, tmp, base);
4692 /* Only the callee knows what the correct offset it, so just set
4694 tmp = gfc_conv_descriptor_offset (parm);
4695 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4700 if (!se->direct_byref)
4702 /* Get a pointer to the new descriptor. */
4703 if (se->want_pointer)
4704 se->expr = build_fold_addr_expr (desc);
4709 gfc_add_block_to_block (&se->pre, &loop.pre);
4710 gfc_add_block_to_block (&se->post, &loop.post);
4712 /* Cleanup the scalarizer. */
4713 gfc_cleanup_loop (&loop);
4717 /* Convert an array for passing as an actual parameter. */
4718 /* TODO: Optimize passing g77 arrays. */
4721 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4730 /* Passing address of the array if it is not pointer or assumed-shape. */
4731 if (expr->expr_type == EXPR_VARIABLE
4732 && expr->ref->u.ar.type == AR_FULL && g77)
4734 sym = expr->symtree->n.sym;
4735 tmp = gfc_get_symbol_decl (sym);
4737 if (sym->ts.type == BT_CHARACTER)
4738 se->string_length = sym->ts.cl->backend_decl;
4739 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4740 && !sym->attr.allocatable)
4742 /* Some variables are declared directly, others are declared as
4743 pointers and allocated on the heap. */
4744 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4747 se->expr = build_fold_addr_expr (tmp);
4750 if (sym->attr.allocatable)
4752 if (sym->attr.dummy)
4754 gfc_conv_expr_descriptor (se, expr, ss);
4755 se->expr = gfc_conv_array_data (se->expr);
4758 se->expr = gfc_conv_array_data (tmp);
4763 se->want_pointer = 1;
4764 gfc_conv_expr_descriptor (se, expr, ss);
4766 /* Deallocate the allocatable components of structures that are
4768 if (expr->ts.type == BT_DERIVED
4769 && expr->ts.derived->attr.alloc_comp
4770 && expr->expr_type != EXPR_VARIABLE)
4772 tmp = build_fold_indirect_ref (se->expr);
4773 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4774 gfc_add_expr_to_block (&se->post, tmp);
4780 /* Repack the array. */
4781 tmp = gfc_chainon_list (NULL_TREE, desc);
4782 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4783 ptr = gfc_evaluate_now (ptr, &se->pre);
4786 gfc_start_block (&block);
4788 /* Copy the data back. */
4789 tmp = gfc_chainon_list (NULL_TREE, desc);
4790 tmp = gfc_chainon_list (tmp, ptr);
4791 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4792 gfc_add_expr_to_block (&block, tmp);
4794 /* Free the temporary. */
4795 tmp = convert (pvoid_type_node, ptr);
4796 tmp = gfc_chainon_list (NULL_TREE, tmp);
4797 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4798 gfc_add_expr_to_block (&block, tmp);
4800 stmt = gfc_finish_block (&block);
4802 gfc_init_block (&block);
4803 /* Only if it was repacked. This code needs to be executed before the
4804 loop cleanup code. */
4805 tmp = build_fold_indirect_ref (desc);
4806 tmp = gfc_conv_array_data (tmp);
4807 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4808 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4810 gfc_add_expr_to_block (&block, tmp);
4811 gfc_add_block_to_block (&block, &se->post);
4813 gfc_init_block (&se->post);
4814 gfc_add_block_to_block (&se->post, &block);
4819 /* Generate code to deallocate an array, if it is allocated. */
4822 gfc_trans_dealloc_allocated (tree descriptor)
4829 gfc_start_block (&block);
4831 var = gfc_conv_descriptor_data_get (descriptor);
4833 tmp = gfc_create_var (gfc_array_index_type, NULL);
4834 ptr = build_fold_addr_expr (tmp);
4836 /* Call array_deallocate with an int* present in the second argument.
4837 Although it is ignored here, it's presence ensures that arrays that
4838 are already deallocated are ignored. */
4839 tmp = gfc_chainon_list (NULL_TREE, var);
4840 tmp = gfc_chainon_list (tmp, ptr);
4841 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4842 gfc_add_expr_to_block (&block, tmp);
4844 /* Zero the data pointer. */
4845 tmp = build2 (MODIFY_EXPR, void_type_node,
4846 var, build_int_cst (TREE_TYPE (var), 0));
4847 gfc_add_expr_to_block (&block, tmp);
4849 return gfc_finish_block (&block);
4853 /* This helper function calculates the size in words of a full array. */
4856 get_full_array_size (stmtblock_t *block, tree decl, int rank)
4861 idx = gfc_rank_cst[rank - 1];
4862 nelems = gfc_conv_descriptor_ubound (decl, idx);
4863 tmp = gfc_conv_descriptor_lbound (decl, idx);
4864 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4865 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4866 tmp, gfc_index_one_node);
4867 tmp = gfc_evaluate_now (tmp, block);
4869 nelems = gfc_conv_descriptor_stride (decl, idx);
4870 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4871 return gfc_evaluate_now (tmp, block);
4875 /* Allocate dest to the same size as src, and copy src -> dest. */
4878 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
4888 /* If the source is null, set the destination to null. */
4889 gfc_init_block (&block);
4890 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4891 null_data = gfc_finish_block (&block);
4893 gfc_init_block (&block);
4895 nelems = get_full_array_size (&block, src, rank);
4896 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4897 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
4899 /* Allocate memory to the destination. */
4900 tmp = gfc_chainon_list (NULL_TREE, size);
4901 if (gfc_index_integer_kind == 4)
4902 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4903 else if (gfc_index_integer_kind == 8)
4904 tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4907 tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)),
4909 gfc_conv_descriptor_data_set (&block, dest, tmp);
4911 /* We know the temporary and the value will be the same length,
4912 so can use memcpy. */
4913 tmp = gfc_conv_descriptor_data_get (dest);
4914 args = gfc_chainon_list (NULL_TREE, tmp);
4915 tmp = gfc_conv_descriptor_data_get (src);
4916 args = gfc_chainon_list (args, tmp);
4917 args = gfc_chainon_list (args, size);
4918 tmp = built_in_decls[BUILT_IN_MEMCPY];
4919 tmp = build_function_call_expr (tmp, args);
4920 gfc_add_expr_to_block (&block, tmp);
4921 tmp = gfc_finish_block (&block);
4923 /* Null the destination if the source is null; otherwise do
4924 the allocate and copy. */
4925 null_cond = gfc_conv_descriptor_data_get (src);
4926 null_cond = convert (pvoid_type_node, null_cond);
4927 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4929 return build3_v (COND_EXPR, null_cond, tmp, null_data);
4933 /* Recursively traverse an object of derived type, generating code to
4934 deallocate, nullify or copy allocatable components. This is the work horse
4935 function for the functions named in this enum. */
4937 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4940 structure_alloc_comps (gfc_symbol * der_type, tree decl,
4941 tree dest, int rank, int purpose)
4945 stmtblock_t fnblock;
4946 stmtblock_t loopbody;
4956 tree null_cond = NULL_TREE;
4958 gfc_init_block (&fnblock);
4960 if (POINTER_TYPE_P (TREE_TYPE (decl)))
4961 decl = build_fold_indirect_ref (decl);
4963 /* If this an array of derived types with allocatable components
4964 build a loop and recursively call this function. */
4965 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4966 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4968 tmp = gfc_conv_array_data (decl);
4969 var = build_fold_indirect_ref (tmp);
4971 /* Get the number of elements - 1 and set the counter. */
4972 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4974 /* Use the descriptor for an allocatable array. Since this
4975 is a full array reference, we only need the descriptor
4976 information from dimension = rank. */
4977 tmp = get_full_array_size (&fnblock, decl, rank);
4978 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4979 tmp, gfc_index_one_node);
4981 null_cond = gfc_conv_descriptor_data_get (decl);
4982 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4983 build_int_cst (TREE_TYPE (tmp), 0));
4987 /* Otherwise use the TYPE_DOMAIN information. */
4988 tmp = array_type_nelts (TREE_TYPE (decl));
4989 tmp = fold_convert (gfc_array_index_type, tmp);
4992 /* Remember that this is, in fact, the no. of elements - 1. */
4993 nelems = gfc_evaluate_now (tmp, &fnblock);
4994 index = gfc_create_var (gfc_array_index_type, "S");
4996 /* Build the body of the loop. */
4997 gfc_init_block (&loopbody);
4999 vref = gfc_build_array_ref (var, index);
5001 if (purpose == COPY_ALLOC_COMP)
5003 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5004 gfc_add_expr_to_block (&fnblock, tmp);
5006 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5007 dref = gfc_build_array_ref (tmp, index);
5008 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5011 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5013 gfc_add_expr_to_block (&loopbody, tmp);
5015 /* Build the loop and return. */
5016 gfc_init_loopinfo (&loop);
5018 loop.from[0] = gfc_index_zero_node;
5019 loop.loopvar[0] = index;
5020 loop.to[0] = nelems;
5021 gfc_trans_scalarizing_loops (&loop, &loopbody);
5022 gfc_add_block_to_block (&fnblock, &loop.pre);
5024 tmp = gfc_finish_block (&fnblock);
5025 if (null_cond != NULL_TREE)
5026 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5031 /* Otherwise, act on the components or recursively call self to
5032 act on a chain of components. */
5033 for (c = der_type->components; c; c = c->next)
5035 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5036 && c->ts.derived->attr.alloc_comp;
5037 cdecl = c->backend_decl;
5038 ctype = TREE_TYPE (cdecl);
5042 case DEALLOCATE_ALLOC_COMP:
5043 /* Do not deallocate the components of ultimate pointer
5045 if (cmp_has_alloc_comps && !c->pointer)
5047 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5048 rank = c->as ? c->as->rank : 0;
5049 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5051 gfc_add_expr_to_block (&fnblock, tmp);
5056 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5057 tmp = gfc_trans_dealloc_allocated (comp);
5058 gfc_add_expr_to_block (&fnblock, tmp);
5062 case NULLIFY_ALLOC_COMP:
5065 else if (c->allocatable)
5067 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5068 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5070 else if (cmp_has_alloc_comps)
5072 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5073 rank = c->as ? c->as->rank : 0;
5074 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5076 gfc_add_expr_to_block (&fnblock, tmp);
5080 case COPY_ALLOC_COMP:
5084 /* We need source and destination components. */
5085 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5086 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5087 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5089 if (c->allocatable && !cmp_has_alloc_comps)
5091 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5092 gfc_add_expr_to_block (&fnblock, tmp);
5095 if (cmp_has_alloc_comps)
5097 rank = c->as ? c->as->rank : 0;
5098 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5099 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5100 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5102 gfc_add_expr_to_block (&fnblock, tmp);
5112 return gfc_finish_block (&fnblock);
5115 /* Recursively traverse an object of derived type, generating code to
5116 nullify allocatable components. */
5119 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5121 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5122 NULLIFY_ALLOC_COMP);
5126 /* Recursively traverse an object of derived type, generating code to
5127 deallocate allocatable components. */
5130 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5132 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5133 DEALLOCATE_ALLOC_COMP);
5137 /* Recursively traverse an object of derived type, generating code to
5138 copy its allocatable components. */
5141 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5143 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5147 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5148 Do likewise, recursively if necessary, with the allocatable components of
5152 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5157 stmtblock_t fnblock;
5160 bool sym_has_alloc_comp;
5162 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5163 && sym->ts.derived->attr.alloc_comp;
5165 /* Make sure the frontend gets these right. */
5166 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5167 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5168 "allocatable attribute or derived type without allocatable "
5171 gfc_init_block (&fnblock);
5173 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5174 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5176 if (sym->ts.type == BT_CHARACTER
5177 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5179 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5180 gfc_trans_vla_type_sizes (sym, &fnblock);
5183 /* Dummy and use associated variables don't need anything special. */
5184 if (sym->attr.dummy || sym->attr.use_assoc)
5186 gfc_add_expr_to_block (&fnblock, body);
5188 return gfc_finish_block (&fnblock);
5191 gfc_get_backend_locus (&loc);
5192 gfc_set_backend_locus (&sym->declared_at);
5193 descriptor = sym->backend_decl;
5195 /* Although static, derived types with default initializers and
5196 allocatable components must not be nulled wholesale; instead they
5197 are treated component by component. */
5198 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5200 /* SAVEd variables are not freed on exit. */
5201 gfc_trans_static_array_pointer (sym);
5205 /* Get the descriptor type. */
5206 type = TREE_TYPE (sym->backend_decl);
5208 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5210 rank = sym->as ? sym->as->rank : 0;
5211 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5212 gfc_add_expr_to_block (&fnblock, tmp);
5214 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5216 /* If the backend_decl is not a descriptor, we must have a pointer
5218 descriptor = build_fold_indirect_ref (sym->backend_decl);
5219 type = TREE_TYPE (descriptor);
5222 /* NULLIFY the data pointer. */
5223 if (GFC_DESCRIPTOR_TYPE_P (type))
5224 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5226 gfc_add_expr_to_block (&fnblock, body);
5228 gfc_set_backend_locus (&loc);
5230 /* Allocatable arrays need to be freed when they go out of scope.
5231 The allocatable components of pointers must not be touched. */
5232 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5233 && !sym->attr.pointer)
5236 rank = sym->as ? sym->as->rank : 0;
5237 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5238 gfc_add_expr_to_block (&fnblock, tmp);
5241 if (sym->attr.allocatable)
5243 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5244 gfc_add_expr_to_block (&fnblock, tmp);
5247 return gfc_finish_block (&fnblock);
5250 /************ Expression Walking Functions ******************/
5252 /* Walk a variable reference.
5254 Possible extension - multiple component subscripts.
5255 x(:,:) = foo%a(:)%b(:)
5257 forall (i=..., j=...)
5258 x(i,j) = foo%a(j)%b(i)
5260 This adds a fair amount of complexity because you need to deal with more
5261 than one ref. Maybe handle in a similar manner to vector subscripts.
5262 Maybe not worth the effort. */
5266 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5274 for (ref = expr->ref; ref; ref = ref->next)
5275 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5278 for (; ref; ref = ref->next)
5280 if (ref->type == REF_SUBSTRING)
5282 newss = gfc_get_ss ();
5283 newss->type = GFC_SS_SCALAR;
5284 newss->expr = ref->u.ss.start;
5288 newss = gfc_get_ss ();
5289 newss->type = GFC_SS_SCALAR;
5290 newss->expr = ref->u.ss.end;
5295 /* We're only interested in array sections from now on. */
5296 if (ref->type != REF_ARRAY)
5303 for (n = 0; n < ar->dimen; n++)
5305 newss = gfc_get_ss ();
5306 newss->type = GFC_SS_SCALAR;
5307 newss->expr = ar->start[n];
5314 newss = gfc_get_ss ();
5315 newss->type = GFC_SS_SECTION;
5318 newss->data.info.dimen = ar->as->rank;
5319 newss->data.info.ref = ref;
5321 /* Make sure array is the same as array(:,:), this way
5322 we don't need to special case all the time. */
5323 ar->dimen = ar->as->rank;
5324 for (n = 0; n < ar->dimen; n++)
5326 newss->data.info.dim[n] = n;
5327 ar->dimen_type[n] = DIMEN_RANGE;
5329 gcc_assert (ar->start[n] == NULL);
5330 gcc_assert (ar->end[n] == NULL);
5331 gcc_assert (ar->stride[n] == NULL);
5337 newss = gfc_get_ss ();
5338 newss->type = GFC_SS_SECTION;
5341 newss->data.info.dimen = 0;
5342 newss->data.info.ref = ref;
5346 /* We add SS chains for all the subscripts in the section. */
5347 for (n = 0; n < ar->dimen; n++)
5351 switch (ar->dimen_type[n])
5354 /* Add SS for elemental (scalar) subscripts. */
5355 gcc_assert (ar->start[n]);
5356 indexss = gfc_get_ss ();
5357 indexss->type = GFC_SS_SCALAR;
5358 indexss->expr = ar->start[n];
5359 indexss->next = gfc_ss_terminator;
5360 indexss->loop_chain = gfc_ss_terminator;
5361 newss->data.info.subscript[n] = indexss;
5365 /* We don't add anything for sections, just remember this
5366 dimension for later. */
5367 newss->data.info.dim[newss->data.info.dimen] = n;
5368 newss->data.info.dimen++;
5372 /* Create a GFC_SS_VECTOR index in which we can store
5373 the vector's descriptor. */
5374 indexss = gfc_get_ss ();
5375 indexss->type = GFC_SS_VECTOR;
5376 indexss->expr = ar->start[n];
5377 indexss->next = gfc_ss_terminator;
5378 indexss->loop_chain = gfc_ss_terminator;
5379 newss->data.info.subscript[n] = indexss;
5380 newss->data.info.dim[newss->data.info.dimen] = n;
5381 newss->data.info.dimen++;
5385 /* We should know what sort of section it is by now. */
5389 /* We should have at least one non-elemental dimension. */
5390 gcc_assert (newss->data.info.dimen > 0);
5395 /* We should know what sort of section it is by now. */
5404 /* Walk an expression operator. If only one operand of a binary expression is
5405 scalar, we must also add the scalar term to the SS chain. */
5408 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5414 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5415 if (expr->value.op.op2 == NULL)
5418 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5420 /* All operands are scalar. Pass back and let the caller deal with it. */
5424 /* All operands require scalarization. */
5425 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5428 /* One of the operands needs scalarization, the other is scalar.
5429 Create a gfc_ss for the scalar expression. */
5430 newss = gfc_get_ss ();
5431 newss->type = GFC_SS_SCALAR;
5434 /* First operand is scalar. We build the chain in reverse order, so
5435 add the scarar SS after the second operand. */
5437 while (head && head->next != ss)
5439 /* Check we haven't somehow broken the chain. */
5443 newss->expr = expr->value.op.op1;
5445 else /* head2 == head */
5447 gcc_assert (head2 == head);
5448 /* Second operand is scalar. */
5449 newss->next = head2;
5451 newss->expr = expr->value.op.op2;
5458 /* Reverse a SS chain. */
5461 gfc_reverse_ss (gfc_ss * ss)
5466 gcc_assert (ss != NULL);
5468 head = gfc_ss_terminator;
5469 while (ss != gfc_ss_terminator)
5472 /* Check we didn't somehow break the chain. */
5473 gcc_assert (next != NULL);
5483 /* Walk the arguments of an elemental function. */
5486 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5494 head = gfc_ss_terminator;
5497 for (; arg; arg = arg->next)
5502 newss = gfc_walk_subexpr (head, arg->expr);
5505 /* Scalar argument. */
5506 newss = gfc_get_ss ();
5508 newss->expr = arg->expr;
5518 while (tail->next != gfc_ss_terminator)
5525 /* If all the arguments are scalar we don't need the argument SS. */
5526 gfc_free_ss_chain (head);
5531 /* Add it onto the existing chain. */
5537 /* Walk a function call. Scalar functions are passed back, and taken out of
5538 scalarization loops. For elemental functions we walk their arguments.
5539 The result of functions returning arrays is stored in a temporary outside
5540 the loop, so that the function is only called once. Hence we do not need
5541 to walk their arguments. */
5544 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5547 gfc_intrinsic_sym *isym;
5550 isym = expr->value.function.isym;
5552 /* Handle intrinsic functions separately. */
5554 return gfc_walk_intrinsic_function (ss, expr, isym);
5556 sym = expr->value.function.esym;
5558 sym = expr->symtree->n.sym;
5560 /* A function that returns arrays. */
5561 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5563 newss = gfc_get_ss ();
5564 newss->type = GFC_SS_FUNCTION;
5567 newss->data.info.dimen = expr->rank;
5571 /* Walk the parameters of an elemental function. For now we always pass
5573 if (sym->attr.elemental)
5574 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5577 /* Scalar functions are OK as these are evaluated outside the scalarization
5578 loop. Pass back and let the caller deal with it. */
5583 /* An array temporary is constructed for array constructors. */
5586 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5591 newss = gfc_get_ss ();
5592 newss->type = GFC_SS_CONSTRUCTOR;
5595 newss->data.info.dimen = expr->rank;
5596 for (n = 0; n < expr->rank; n++)
5597 newss->data.info.dim[n] = n;
5603 /* Walk an expression. Add walked expressions to the head of the SS chain.
5604 A wholly scalar expression will not be added. */
5607 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5611 switch (expr->expr_type)
5614 head = gfc_walk_variable_expr (ss, expr);
5618 head = gfc_walk_op_expr (ss, expr);
5622 head = gfc_walk_function_expr (ss, expr);
5627 case EXPR_STRUCTURE:
5628 /* Pass back and let the caller deal with it. */
5632 head = gfc_walk_array_constructor (ss, expr);
5635 case EXPR_SUBSTRING:
5636 /* Pass back and let the caller deal with it. */
5640 internal_error ("bad expression type during walk (%d)",
5647 /* Entry point for expression walking.
5648 A return value equal to the passed chain means this is
5649 a scalar expression. It is up to the caller to take whatever action is
5650 necessary to translate these. */
5653 gfc_walk_expr (gfc_expr * expr)
5657 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5658 return gfc_reverse_ss (res);