1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 3, 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 COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subscripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
95 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
97 /* The contents of this structure aren't actually used, just the address. */
98 static gfc_ss gfc_ss_terminator_var;
99 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
103 gfc_array_dataptr_type (tree desc)
105 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
109 /* Build expressions to access the members of an array descriptor.
110 It's surprisingly easy to mess up here, so never access
111 an array descriptor by "brute force", always use these
112 functions. This also avoids problems if we change the format
113 of an array descriptor.
115 To understand these magic numbers, look at the comments
116 before gfc_build_array_type() in trans-types.c.
118 The code within these defines should be the only code which knows the format
119 of an array descriptor.
121 Any code just needing to read obtain the bounds of an array should use
122 gfc_conv_array_* rather than the following functions as these will return
123 know constant values, and work with arrays which do not have descriptors.
125 Don't forget to #undef these! */
128 #define OFFSET_FIELD 1
129 #define DTYPE_FIELD 2
130 #define DIMENSION_FIELD 3
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc)
144 type = TREE_TYPE (desc);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
147 field = TYPE_FIELDS (type);
148 gcc_assert (DATA_FIELD == 0);
150 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
152 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
166 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
170 type = TREE_TYPE (desc);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
173 field = TYPE_FIELDS (type);
174 gcc_assert (DATA_FIELD == 0);
176 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc)
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
196 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
198 return gfc_build_addr_expr (NULL_TREE, t);
202 gfc_conv_descriptor_offset (tree desc)
207 type = TREE_TYPE (desc);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
210 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
211 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
213 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
214 desc, field, NULL_TREE);
218 gfc_conv_descriptor_offset_get (tree desc)
220 return gfc_conv_descriptor_offset (desc);
224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
227 tree t = gfc_conv_descriptor_offset (desc);
228 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
233 gfc_conv_descriptor_dtype (tree desc)
238 type = TREE_TYPE (desc);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
241 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
242 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
244 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
245 desc, field, NULL_TREE);
249 gfc_conv_descriptor_dimension (tree desc, tree dim)
255 type = TREE_TYPE (desc);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
258 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
259 gcc_assert (field != NULL_TREE
260 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
261 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
263 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
264 desc, field, NULL_TREE);
265 tmp = gfc_build_array_ref (tmp, dim, NULL);
270 gfc_conv_descriptor_stride (tree desc, tree dim)
275 tmp = gfc_conv_descriptor_dimension (desc, dim);
276 field = TYPE_FIELDS (TREE_TYPE (tmp));
277 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
278 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
280 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
281 tmp, field, NULL_TREE);
286 gfc_conv_descriptor_stride_get (tree desc, tree dim)
288 tree type = TREE_TYPE (desc);
289 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
290 if (integer_zerop (dim)
291 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
292 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
293 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
294 return gfc_index_one_node;
296 return gfc_conv_descriptor_stride (desc, dim);
300 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
301 tree dim, tree value)
303 tree t = gfc_conv_descriptor_stride (desc, dim);
304 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
308 gfc_conv_descriptor_lbound (tree desc, tree dim)
313 tmp = gfc_conv_descriptor_dimension (desc, dim);
314 field = TYPE_FIELDS (TREE_TYPE (tmp));
315 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
316 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
318 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
319 tmp, field, NULL_TREE);
324 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
326 return gfc_conv_descriptor_lbound (desc, dim);
330 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
331 tree dim, tree value)
333 tree t = gfc_conv_descriptor_lbound (desc, dim);
334 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
338 gfc_conv_descriptor_ubound (tree desc, tree dim)
343 tmp = gfc_conv_descriptor_dimension (desc, dim);
344 field = TYPE_FIELDS (TREE_TYPE (tmp));
345 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
346 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
348 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
349 tmp, field, NULL_TREE);
354 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
356 return gfc_conv_descriptor_ubound (desc, dim);
360 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
361 tree dim, tree value)
363 tree t = gfc_conv_descriptor_ubound (desc, dim);
364 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
367 /* Build a null array descriptor constructor. */
370 gfc_build_null_descriptor (tree type)
375 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
376 gcc_assert (DATA_FIELD == 0);
377 field = TYPE_FIELDS (type);
379 /* Set a NULL data pointer. */
380 tmp = build_constructor_single (type, field, null_pointer_node);
381 TREE_CONSTANT (tmp) = 1;
382 /* All other fields are ignored. */
388 /* Modify a descriptor such that the lbound of a given dimension is the value
389 specified. This also updates ubound and offset accordingly. */
392 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
393 int dim, tree new_lbound)
395 tree offs, ubound, lbound, stride;
396 tree diff, offs_diff;
398 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
400 offs = gfc_conv_descriptor_offset_get (desc);
401 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
402 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
403 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
405 /* Get difference (new - old) by which to shift stuff. */
406 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
409 /* Shift ubound and offset accordingly. This has to be done before
410 updating the lbound, as they depend on the lbound expression! */
411 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
413 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
414 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
416 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
418 gfc_conv_descriptor_offset_set (block, desc, offs);
420 /* Finally set lbound to value we want. */
421 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
425 /* Cleanup those #defines. */
430 #undef DIMENSION_FIELD
431 #undef STRIDE_SUBFIELD
432 #undef LBOUND_SUBFIELD
433 #undef UBOUND_SUBFIELD
436 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
437 flags & 1 = Main loop body.
438 flags & 2 = temp copy loop. */
441 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
443 for (; ss != gfc_ss_terminator; ss = ss->next)
444 ss->useflags = flags;
447 static void gfc_free_ss (gfc_ss *);
450 /* Free a gfc_ss chain. */
453 gfc_free_ss_chain (gfc_ss * ss)
457 while (ss != gfc_ss_terminator)
459 gcc_assert (ss != NULL);
470 gfc_free_ss (gfc_ss * ss)
477 for (n = 0; n < ss->data.info.dimen; n++)
479 if (ss->data.info.subscript[ss->data.info.dim[n]])
480 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
492 /* Free all the SS associated with a loop. */
495 gfc_cleanup_loop (gfc_loopinfo * loop)
501 while (ss != gfc_ss_terminator)
503 gcc_assert (ss != NULL);
504 next = ss->loop_chain;
511 /* Associate a SS chain with a loop. */
514 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
518 if (head == gfc_ss_terminator)
522 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
524 if (ss->next == gfc_ss_terminator)
525 ss->loop_chain = loop->ss;
527 ss->loop_chain = ss->next;
529 gcc_assert (ss == gfc_ss_terminator);
534 /* Generate an initializer for a static pointer or allocatable array. */
537 gfc_trans_static_array_pointer (gfc_symbol * sym)
541 gcc_assert (TREE_STATIC (sym->backend_decl));
542 /* Just zero the data member. */
543 type = TREE_TYPE (sym->backend_decl);
544 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
548 /* If the bounds of SE's loop have not yet been set, see if they can be
549 determined from array spec AS, which is the array spec of a called
550 function. MAPPING maps the callee's dummy arguments to the values
551 that the caller is passing. Add any initialization and finalization
555 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
556 gfc_se * se, gfc_array_spec * as)
564 if (as && as->type == AS_EXPLICIT)
565 for (n = 0; n < se->loop->dimen; n++)
567 dim = se->ss->data.info.dim[n];
568 gcc_assert (dim < as->rank);
569 gcc_assert (se->loop->dimen == as->rank);
570 if (se->loop->to[n] == NULL_TREE)
572 /* Evaluate the lower bound. */
573 gfc_init_se (&tmpse, NULL);
574 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
575 gfc_add_block_to_block (&se->pre, &tmpse.pre);
576 gfc_add_block_to_block (&se->post, &tmpse.post);
577 lower = fold_convert (gfc_array_index_type, tmpse.expr);
579 /* ...and the upper bound. */
580 gfc_init_se (&tmpse, NULL);
581 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
582 gfc_add_block_to_block (&se->pre, &tmpse.pre);
583 gfc_add_block_to_block (&se->post, &tmpse.post);
584 upper = fold_convert (gfc_array_index_type, tmpse.expr);
586 /* Set the upper bound of the loop to UPPER - LOWER. */
587 tmp = fold_build2_loc (input_location, MINUS_EXPR,
588 gfc_array_index_type, upper, lower);
589 tmp = gfc_evaluate_now (tmp, &se->pre);
590 se->loop->to[n] = tmp;
596 /* Generate code to allocate an array temporary, or create a variable to
597 hold the data. If size is NULL, zero the descriptor so that the
598 callee will allocate the array. If DEALLOC is true, also generate code to
599 free the array afterwards.
601 If INITIAL is not NULL, it is packed using internal_pack and the result used
602 as data instead of allocating a fresh, unitialized area of memory.
604 Initialization code is added to PRE and finalization code to POST.
605 DYNAMIC is true if the caller may want to extend the array later
606 using realloc. This prevents us from putting the array on the stack. */
609 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
610 gfc_ss_info * info, tree size, tree nelem,
611 tree initial, bool dynamic, bool dealloc)
617 desc = info->descriptor;
618 info->offset = gfc_index_zero_node;
619 if (size == NULL_TREE || integer_zerop (size))
621 /* A callee allocated array. */
622 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
627 /* Allocate the temporary. */
628 onstack = !dynamic && initial == NULL_TREE
629 && gfc_can_put_var_on_stack (size);
633 /* Make a temporary variable to hold the data. */
634 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
635 nelem, gfc_index_one_node);
636 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
638 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
640 tmp = gfc_create_var (tmp, "A");
641 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
642 gfc_conv_descriptor_data_set (pre, desc, tmp);
646 /* Allocate memory to hold the data or call internal_pack. */
647 if (initial == NULL_TREE)
649 tmp = gfc_call_malloc (pre, NULL, size);
650 tmp = gfc_evaluate_now (tmp, pre);
657 stmtblock_t do_copying;
659 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
660 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
661 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
662 tmp = gfc_get_element_type (tmp);
663 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
664 packed = gfc_create_var (build_pointer_type (tmp), "data");
666 tmp = build_call_expr_loc (input_location,
667 gfor_fndecl_in_pack, 1, initial);
668 tmp = fold_convert (TREE_TYPE (packed), tmp);
669 gfc_add_modify (pre, packed, tmp);
671 tmp = build_fold_indirect_ref_loc (input_location,
673 source_data = gfc_conv_descriptor_data_get (tmp);
675 /* internal_pack may return source->data without any allocation
676 or copying if it is already packed. If that's the case, we
677 need to allocate and copy manually. */
679 gfc_start_block (&do_copying);
680 tmp = gfc_call_malloc (&do_copying, NULL, size);
681 tmp = fold_convert (TREE_TYPE (packed), tmp);
682 gfc_add_modify (&do_copying, packed, tmp);
683 tmp = gfc_build_memcpy_call (packed, source_data, size);
684 gfc_add_expr_to_block (&do_copying, tmp);
686 was_packed = fold_build2_loc (input_location, EQ_EXPR,
687 boolean_type_node, packed,
689 tmp = gfc_finish_block (&do_copying);
690 tmp = build3_v (COND_EXPR, was_packed, tmp,
691 build_empty_stmt (input_location));
692 gfc_add_expr_to_block (pre, tmp);
694 tmp = fold_convert (pvoid_type_node, packed);
697 gfc_conv_descriptor_data_set (pre, desc, tmp);
700 info->data = gfc_conv_descriptor_data_get (desc);
702 /* The offset is zero because we create temporaries with a zero
704 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
706 if (dealloc && !onstack)
708 /* Free the temporary. */
709 tmp = gfc_conv_descriptor_data_get (desc);
710 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
711 gfc_add_expr_to_block (post, tmp);
716 /* Get the array reference dimension corresponding to the given loop dimension.
717 It is different from the true array dimension given by the dim array in
718 the case of a partial array reference
719 It is different from the loop dimension in the case of a transposed array.
723 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
725 int n, array_dim, array_ref_dim;
728 array_dim = info->dim[loop_dim];
730 for (n = 0; n < info->dimen; n++)
731 if (n != loop_dim && info->dim[n] < array_dim)
734 return array_ref_dim;
738 /* Generate code to create and initialize the descriptor for a temporary
739 array. This is used for both temporaries needed by the scalarizer, and
740 functions returning arrays. Adjusts the loop variables to be
741 zero-based, and calculates the loop bounds for callee allocated arrays.
742 Allocate the array unless it's callee allocated (we have a callee
743 allocated array if 'callee_alloc' is true, or if loop->to[n] is
744 NULL_TREE for any n). Also fills in the descriptor, data and offset
745 fields of info if known. Returns the size of the array, or NULL for a
746 callee allocated array.
748 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
749 gfc_trans_allocate_array_storage.
753 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
754 gfc_loopinfo * loop, gfc_ss_info * info,
755 tree eltype, tree initial, bool dynamic,
756 bool dealloc, bool callee_alloc, locus * where)
758 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
768 memset (from, 0, sizeof (from));
769 memset (to, 0, sizeof (to));
771 gcc_assert (info->dimen > 0);
772 gcc_assert (loop->dimen == info->dimen);
774 if (gfc_option.warn_array_temp && where)
775 gfc_warning ("Creating array temporary at %L", where);
777 /* Set the lower bound to zero. */
778 for (n = 0; n < loop->dimen; n++)
782 /* Callee allocated arrays may not have a known bound yet. */
784 loop->to[n] = gfc_evaluate_now (
785 fold_build2_loc (input_location, MINUS_EXPR,
786 gfc_array_index_type,
787 loop->to[n], loop->from[n]),
789 loop->from[n] = gfc_index_zero_node;
791 /* We are constructing the temporary's descriptor based on the loop
792 dimensions. As the dimensions may be accessed in arbitrary order
793 (think of transpose) the size taken from the n'th loop may not map
794 to the n'th dimension of the array. We need to reconstruct loop infos
795 in the right order before using it to set the descriptor
797 tmp_dim = get_array_ref_dim (info, n);
798 from[tmp_dim] = loop->from[n];
799 to[tmp_dim] = loop->to[n];
801 info->delta[dim] = gfc_index_zero_node;
802 info->start[dim] = gfc_index_zero_node;
803 info->end[dim] = gfc_index_zero_node;
804 info->stride[dim] = gfc_index_one_node;
807 /* Initialize the descriptor. */
809 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
810 GFC_ARRAY_UNKNOWN, true);
811 desc = gfc_create_var (type, "atmp");
812 GFC_DECL_PACKED_ARRAY (desc) = 1;
814 info->descriptor = desc;
815 size = gfc_index_one_node;
817 /* Fill in the array dtype. */
818 tmp = gfc_conv_descriptor_dtype (desc);
819 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
822 Fill in the bounds and stride. This is a packed array, so:
825 for (n = 0; n < rank; n++)
828 delta = ubound[n] + 1 - lbound[n];
831 size = size * sizeof(element);
836 /* If there is at least one null loop->to[n], it is a callee allocated
838 for (n = 0; n < loop->dimen; n++)
839 if (loop->to[n] == NULL_TREE)
845 for (n = 0; n < loop->dimen; n++)
849 if (size == NULL_TREE)
851 /* For a callee allocated array express the loop bounds in terms
852 of the descriptor fields. */
853 tmp = fold_build2_loc (input_location,
854 MINUS_EXPR, gfc_array_index_type,
855 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
856 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
861 /* Store the stride and bound components in the descriptor. */
862 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
864 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
865 gfc_index_zero_node);
867 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
870 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
871 to[n], gfc_index_one_node);
873 /* Check whether the size for this dimension is negative. */
874 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
875 gfc_index_zero_node);
876 cond = gfc_evaluate_now (cond, pre);
881 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
882 boolean_type_node, or_expr, cond);
884 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
886 size = gfc_evaluate_now (size, pre);
889 /* Get the size of the array. */
891 if (size && !callee_alloc)
893 /* If or_expr is true, then the extent in at least one
894 dimension is zero and the size is set to zero. */
895 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
896 or_expr, gfc_index_zero_node, size);
899 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
901 fold_convert (gfc_array_index_type,
902 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
910 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
913 if (info->dimen > loop->temp_dim)
914 loop->temp_dim = info->dimen;
920 /* Generate code to transpose array EXPR by creating a new descriptor
921 in which the dimension specifications have been reversed. */
924 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
926 tree dest, src, dest_index, src_index;
928 gfc_ss_info *dest_info;
929 gfc_ss *dest_ss, *src_ss;
935 src_ss = gfc_walk_expr (expr);
938 dest_info = &dest_ss->data.info;
939 gcc_assert (dest_info->dimen == 2);
941 /* Get a descriptor for EXPR. */
942 gfc_init_se (&src_se, NULL);
943 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
944 gfc_add_block_to_block (&se->pre, &src_se.pre);
945 gfc_add_block_to_block (&se->post, &src_se.post);
948 /* Allocate a new descriptor for the return value. */
949 dest = gfc_create_var (TREE_TYPE (src), "transp");
950 dest_info->descriptor = dest;
953 /* Copy across the dtype field. */
954 gfc_add_modify (&se->pre,
955 gfc_conv_descriptor_dtype (dest),
956 gfc_conv_descriptor_dtype (src));
958 /* Copy the dimension information, renumbering dimension 1 to 0 and
960 for (n = 0; n < 2; n++)
962 dest_info->delta[n] = gfc_index_zero_node;
963 dest_info->start[n] = gfc_index_zero_node;
964 dest_info->end[n] = gfc_index_zero_node;
965 dest_info->stride[n] = gfc_index_one_node;
966 dest_info->dim[n] = n;
968 dest_index = gfc_rank_cst[n];
969 src_index = gfc_rank_cst[1 - n];
971 gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
972 gfc_conv_descriptor_stride_get (src, src_index));
974 gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
975 gfc_conv_descriptor_lbound_get (src, src_index));
977 gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
978 gfc_conv_descriptor_ubound_get (src, src_index));
982 gcc_assert (integer_zerop (loop->from[n]));
984 fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
985 gfc_conv_descriptor_ubound_get (dest, dest_index),
986 gfc_conv_descriptor_lbound_get (dest, dest_index));
990 /* Copy the data pointer. */
991 dest_info->data = gfc_conv_descriptor_data_get (src);
992 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
994 /* Copy the offset. This is not changed by transposition; the top-left
995 element is still at the same offset as before, except where the loop
997 if (!integer_zerop (loop->from[0]))
998 dest_info->offset = gfc_conv_descriptor_offset_get (src);
1000 dest_info->offset = gfc_index_zero_node;
1002 gfc_conv_descriptor_offset_set (&se->pre, dest,
1005 if (dest_info->dimen > loop->temp_dim)
1006 loop->temp_dim = dest_info->dimen;
1010 /* Return the number of iterations in a loop that starts at START,
1011 ends at END, and has step STEP. */
1014 gfc_get_iteration_count (tree start, tree end, tree step)
1019 type = TREE_TYPE (step);
1020 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1021 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1022 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1023 build_int_cst (type, 1));
1024 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1025 build_int_cst (type, 0));
1026 return fold_convert (gfc_array_index_type, tmp);
1030 /* Extend the data in array DESC by EXTRA elements. */
1033 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1040 if (integer_zerop (extra))
1043 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1045 /* Add EXTRA to the upper bound. */
1046 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1048 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1050 /* Get the value of the current data pointer. */
1051 arg0 = gfc_conv_descriptor_data_get (desc);
1053 /* Calculate the new array size. */
1054 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1055 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1056 ubound, gfc_index_one_node);
1057 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1058 fold_convert (size_type_node, tmp),
1059 fold_convert (size_type_node, size));
1061 /* Call the realloc() function. */
1062 tmp = gfc_call_realloc (pblock, arg0, arg1);
1063 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1067 /* Return true if the bounds of iterator I can only be determined
1071 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1073 return (i->start->expr_type != EXPR_CONSTANT
1074 || i->end->expr_type != EXPR_CONSTANT
1075 || i->step->expr_type != EXPR_CONSTANT);
1079 /* Split the size of constructor element EXPR into the sum of two terms,
1080 one of which can be determined at compile time and one of which must
1081 be calculated at run time. Set *SIZE to the former and return true
1082 if the latter might be nonzero. */
1085 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1087 if (expr->expr_type == EXPR_ARRAY)
1088 return gfc_get_array_constructor_size (size, expr->value.constructor);
1089 else if (expr->rank > 0)
1091 /* Calculate everything at run time. */
1092 mpz_set_ui (*size, 0);
1097 /* A single element. */
1098 mpz_set_ui (*size, 1);
1104 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1105 of array constructor C. */
1108 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1116 mpz_set_ui (*size, 0);
1121 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1124 if (i && gfc_iterator_has_dynamic_bounds (i))
1128 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1131 /* Multiply the static part of the element size by the
1132 number of iterations. */
1133 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1134 mpz_fdiv_q (val, val, i->step->value.integer);
1135 mpz_add_ui (val, val, 1);
1136 if (mpz_sgn (val) > 0)
1137 mpz_mul (len, len, val);
1139 mpz_set_ui (len, 0);
1141 mpz_add (*size, *size, len);
1150 /* Make sure offset is a variable. */
1153 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1156 /* We should have already created the offset variable. We cannot
1157 create it here because we may be in an inner scope. */
1158 gcc_assert (*offsetvar != NULL_TREE);
1159 gfc_add_modify (pblock, *offsetvar, *poffset);
1160 *poffset = *offsetvar;
1161 TREE_USED (*offsetvar) = 1;
1165 /* Variables needed for bounds-checking. */
1166 static bool first_len;
1167 static tree first_len_val;
1168 static bool typespec_chararray_ctor;
1171 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1172 tree offset, gfc_se * se, gfc_expr * expr)
1176 gfc_conv_expr (se, expr);
1178 /* Store the value. */
1179 tmp = build_fold_indirect_ref_loc (input_location,
1180 gfc_conv_descriptor_data_get (desc));
1181 tmp = gfc_build_array_ref (tmp, offset, NULL);
1183 if (expr->ts.type == BT_CHARACTER)
1185 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1188 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1189 esize = fold_convert (gfc_charlen_type_node, esize);
1190 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1191 gfc_charlen_type_node, esize,
1192 build_int_cst (gfc_charlen_type_node,
1193 gfc_character_kinds[i].bit_size / 8));
1195 gfc_conv_string_parameter (se);
1196 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1198 /* The temporary is an array of pointers. */
1199 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1200 gfc_add_modify (&se->pre, tmp, se->expr);
1204 /* The temporary is an array of string values. */
1205 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1206 /* We know the temporary and the value will be the same length,
1207 so can use memcpy. */
1208 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1209 se->string_length, se->expr, expr->ts.kind);
1211 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1215 gfc_add_modify (&se->pre, first_len_val,
1221 /* Verify that all constructor elements are of the same
1223 tree cond = fold_build2_loc (input_location, NE_EXPR,
1224 boolean_type_node, first_len_val,
1226 gfc_trans_runtime_check
1227 (true, false, cond, &se->pre, &expr->where,
1228 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1229 fold_convert (long_integer_type_node, first_len_val),
1230 fold_convert (long_integer_type_node, se->string_length));
1236 /* TODO: Should the frontend already have done this conversion? */
1237 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1238 gfc_add_modify (&se->pre, tmp, se->expr);
1241 gfc_add_block_to_block (pblock, &se->pre);
1242 gfc_add_block_to_block (pblock, &se->post);
1246 /* Add the contents of an array to the constructor. DYNAMIC is as for
1247 gfc_trans_array_constructor_value. */
1250 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1251 tree type ATTRIBUTE_UNUSED,
1252 tree desc, gfc_expr * expr,
1253 tree * poffset, tree * offsetvar,
1264 /* We need this to be a variable so we can increment it. */
1265 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1267 gfc_init_se (&se, NULL);
1269 /* Walk the array expression. */
1270 ss = gfc_walk_expr (expr);
1271 gcc_assert (ss != gfc_ss_terminator);
1273 /* Initialize the scalarizer. */
1274 gfc_init_loopinfo (&loop);
1275 gfc_add_ss_to_loop (&loop, ss);
1277 /* Initialize the loop. */
1278 gfc_conv_ss_startstride (&loop);
1279 gfc_conv_loop_setup (&loop, &expr->where);
1281 /* Make sure the constructed array has room for the new data. */
1284 /* Set SIZE to the total number of elements in the subarray. */
1285 size = gfc_index_one_node;
1286 for (n = 0; n < loop.dimen; n++)
1288 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1289 gfc_index_one_node);
1290 size = fold_build2_loc (input_location, MULT_EXPR,
1291 gfc_array_index_type, size, tmp);
1294 /* Grow the constructed array by SIZE elements. */
1295 gfc_grow_array (&loop.pre, desc, size);
1298 /* Make the loop body. */
1299 gfc_mark_ss_chain_used (ss, 1);
1300 gfc_start_scalarized_body (&loop, &body);
1301 gfc_copy_loopinfo_to_se (&se, &loop);
1304 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1305 gcc_assert (se.ss == gfc_ss_terminator);
1307 /* Increment the offset. */
1308 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1309 *poffset, gfc_index_one_node);
1310 gfc_add_modify (&body, *poffset, tmp);
1312 /* Finish the loop. */
1313 gfc_trans_scalarizing_loops (&loop, &body);
1314 gfc_add_block_to_block (&loop.pre, &loop.post);
1315 tmp = gfc_finish_block (&loop.pre);
1316 gfc_add_expr_to_block (pblock, tmp);
1318 gfc_cleanup_loop (&loop);
1322 /* Assign the values to the elements of an array constructor. DYNAMIC
1323 is true if descriptor DESC only contains enough data for the static
1324 size calculated by gfc_get_array_constructor_size. When true, memory
1325 for the dynamic parts must be allocated using realloc. */
1328 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1329 tree desc, gfc_constructor_base base,
1330 tree * poffset, tree * offsetvar,
1339 tree shadow_loopvar = NULL_TREE;
1340 gfc_saved_var saved_loopvar;
1343 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1345 /* If this is an iterator or an array, the offset must be a variable. */
1346 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1347 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1349 /* Shadowing the iterator avoids changing its value and saves us from
1350 keeping track of it. Further, it makes sure that there's always a
1351 backend-decl for the symbol, even if there wasn't one before,
1352 e.g. in the case of an iterator that appears in a specification
1353 expression in an interface mapping. */
1356 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1357 tree type = gfc_typenode_for_spec (&sym->ts);
1359 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1360 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1363 gfc_start_block (&body);
1365 if (c->expr->expr_type == EXPR_ARRAY)
1367 /* Array constructors can be nested. */
1368 gfc_trans_array_constructor_value (&body, type, desc,
1369 c->expr->value.constructor,
1370 poffset, offsetvar, dynamic);
1372 else if (c->expr->rank > 0)
1374 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1375 poffset, offsetvar, dynamic);
1379 /* This code really upsets the gimplifier so don't bother for now. */
1386 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1388 p = gfc_constructor_next (p);
1393 /* Scalar values. */
1394 gfc_init_se (&se, NULL);
1395 gfc_trans_array_ctor_element (&body, desc, *poffset,
1398 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1399 gfc_array_index_type,
1400 *poffset, gfc_index_one_node);
1404 /* Collect multiple scalar constants into a constructor. */
1405 VEC(constructor_elt,gc) *v = NULL;
1409 HOST_WIDE_INT idx = 0;
1412 /* Count the number of consecutive scalar constants. */
1413 while (p && !(p->iterator
1414 || p->expr->expr_type != EXPR_CONSTANT))
1416 gfc_init_se (&se, NULL);
1417 gfc_conv_constant (&se, p->expr);
1419 if (c->expr->ts.type != BT_CHARACTER)
1420 se.expr = fold_convert (type, se.expr);
1421 /* For constant character array constructors we build
1422 an array of pointers. */
1423 else if (POINTER_TYPE_P (type))
1424 se.expr = gfc_build_addr_expr
1425 (gfc_get_pchar_type (p->expr->ts.kind),
1428 CONSTRUCTOR_APPEND_ELT (v,
1429 build_int_cst (gfc_array_index_type,
1433 p = gfc_constructor_next (p);
1436 bound = build_int_cst (NULL_TREE, n - 1);
1437 /* Create an array type to hold them. */
1438 tmptype = build_range_type (gfc_array_index_type,
1439 gfc_index_zero_node, bound);
1440 tmptype = build_array_type (type, tmptype);
1442 init = build_constructor (tmptype, v);
1443 TREE_CONSTANT (init) = 1;
1444 TREE_STATIC (init) = 1;
1445 /* Create a static variable to hold the data. */
1446 tmp = gfc_create_var (tmptype, "data");
1447 TREE_STATIC (tmp) = 1;
1448 TREE_CONSTANT (tmp) = 1;
1449 TREE_READONLY (tmp) = 1;
1450 DECL_INITIAL (tmp) = init;
1453 /* Use BUILTIN_MEMCPY to assign the values. */
1454 tmp = gfc_conv_descriptor_data_get (desc);
1455 tmp = build_fold_indirect_ref_loc (input_location,
1457 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1458 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1459 init = gfc_build_addr_expr (NULL_TREE, init);
1461 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1462 bound = build_int_cst (NULL_TREE, n * size);
1463 tmp = build_call_expr_loc (input_location,
1464 built_in_decls[BUILT_IN_MEMCPY], 3,
1466 gfc_add_expr_to_block (&body, tmp);
1468 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1469 gfc_array_index_type, *poffset,
1470 build_int_cst (gfc_array_index_type, n));
1472 if (!INTEGER_CST_P (*poffset))
1474 gfc_add_modify (&body, *offsetvar, *poffset);
1475 *poffset = *offsetvar;
1479 /* The frontend should already have done any expansions
1483 /* Pass the code as is. */
1484 tmp = gfc_finish_block (&body);
1485 gfc_add_expr_to_block (pblock, tmp);
1489 /* Build the implied do-loop. */
1490 stmtblock_t implied_do_block;
1498 loopbody = gfc_finish_block (&body);
1500 /* Create a new block that holds the implied-do loop. A temporary
1501 loop-variable is used. */
1502 gfc_start_block(&implied_do_block);
1504 /* Initialize the loop. */
1505 gfc_init_se (&se, NULL);
1506 gfc_conv_expr_val (&se, c->iterator->start);
1507 gfc_add_block_to_block (&implied_do_block, &se.pre);
1508 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1510 gfc_init_se (&se, NULL);
1511 gfc_conv_expr_val (&se, c->iterator->end);
1512 gfc_add_block_to_block (&implied_do_block, &se.pre);
1513 end = gfc_evaluate_now (se.expr, &implied_do_block);
1515 gfc_init_se (&se, NULL);
1516 gfc_conv_expr_val (&se, c->iterator->step);
1517 gfc_add_block_to_block (&implied_do_block, &se.pre);
1518 step = gfc_evaluate_now (se.expr, &implied_do_block);
1520 /* If this array expands dynamically, and the number of iterations
1521 is not constant, we won't have allocated space for the static
1522 part of C->EXPR's size. Do that now. */
1523 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1525 /* Get the number of iterations. */
1526 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1528 /* Get the static part of C->EXPR's size. */
1529 gfc_get_array_constructor_element_size (&size, c->expr);
1530 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1532 /* Grow the array by TMP * TMP2 elements. */
1533 tmp = fold_build2_loc (input_location, MULT_EXPR,
1534 gfc_array_index_type, tmp, tmp2);
1535 gfc_grow_array (&implied_do_block, desc, tmp);
1538 /* Generate the loop body. */
1539 exit_label = gfc_build_label_decl (NULL_TREE);
1540 gfc_start_block (&body);
1542 /* Generate the exit condition. Depending on the sign of
1543 the step variable we have to generate the correct
1545 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1546 step, build_int_cst (TREE_TYPE (step), 0));
1547 cond = fold_build3_loc (input_location, COND_EXPR,
1548 boolean_type_node, tmp,
1549 fold_build2_loc (input_location, GT_EXPR,
1550 boolean_type_node, shadow_loopvar, end),
1551 fold_build2_loc (input_location, LT_EXPR,
1552 boolean_type_node, shadow_loopvar, end));
1553 tmp = build1_v (GOTO_EXPR, exit_label);
1554 TREE_USED (exit_label) = 1;
1555 tmp = build3_v (COND_EXPR, cond, tmp,
1556 build_empty_stmt (input_location));
1557 gfc_add_expr_to_block (&body, tmp);
1559 /* The main loop body. */
1560 gfc_add_expr_to_block (&body, loopbody);
1562 /* Increase loop variable by step. */
1563 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1564 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1566 gfc_add_modify (&body, shadow_loopvar, tmp);
1568 /* Finish the loop. */
1569 tmp = gfc_finish_block (&body);
1570 tmp = build1_v (LOOP_EXPR, tmp);
1571 gfc_add_expr_to_block (&implied_do_block, tmp);
1573 /* Add the exit label. */
1574 tmp = build1_v (LABEL_EXPR, exit_label);
1575 gfc_add_expr_to_block (&implied_do_block, tmp);
1577 /* Finishe the implied-do loop. */
1578 tmp = gfc_finish_block(&implied_do_block);
1579 gfc_add_expr_to_block(pblock, tmp);
1581 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1588 /* Figure out the string length of a variable reference expression.
1589 Used by get_array_ctor_strlen. */
1592 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1598 /* Don't bother if we already know the length is a constant. */
1599 if (*len && INTEGER_CST_P (*len))
1602 ts = &expr->symtree->n.sym->ts;
1603 for (ref = expr->ref; ref; ref = ref->next)
1608 /* Array references don't change the string length. */
1612 /* Use the length of the component. */
1613 ts = &ref->u.c.component->ts;
1617 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1618 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1620 mpz_init_set_ui (char_len, 1);
1621 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1622 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1623 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1624 *len = convert (gfc_charlen_type_node, *len);
1625 mpz_clear (char_len);
1629 /* TODO: Substrings are tricky because we can't evaluate the
1630 expression more than once. For now we just give up, and hope
1631 we can figure it out elsewhere. */
1636 *len = ts->u.cl->backend_decl;
1640 /* A catch-all to obtain the string length for anything that is not a
1641 constant, array or variable. */
1643 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1648 /* Don't bother if we already know the length is a constant. */
1649 if (*len && INTEGER_CST_P (*len))
1652 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1653 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1656 gfc_conv_const_charlen (e->ts.u.cl);
1657 *len = e->ts.u.cl->backend_decl;
1661 /* Otherwise, be brutal even if inefficient. */
1662 ss = gfc_walk_expr (e);
1663 gfc_init_se (&se, NULL);
1665 /* No function call, in case of side effects. */
1666 se.no_function_call = 1;
1667 if (ss == gfc_ss_terminator)
1668 gfc_conv_expr (&se, e);
1670 gfc_conv_expr_descriptor (&se, e, ss);
1672 /* Fix the value. */
1673 *len = gfc_evaluate_now (se.string_length, &se.pre);
1675 gfc_add_block_to_block (block, &se.pre);
1676 gfc_add_block_to_block (block, &se.post);
1678 e->ts.u.cl->backend_decl = *len;
1683 /* Figure out the string length of a character array constructor.
1684 If len is NULL, don't calculate the length; this happens for recursive calls
1685 when a sub-array-constructor is an element but not at the first position,
1686 so when we're not interested in the length.
1687 Returns TRUE if all elements are character constants. */
1690 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1697 if (gfc_constructor_first (base) == NULL)
1700 *len = build_int_cstu (gfc_charlen_type_node, 0);
1704 /* Loop over all constructor elements to find out is_const, but in len we
1705 want to store the length of the first, not the last, element. We can
1706 of course exit the loop as soon as is_const is found to be false. */
1707 for (c = gfc_constructor_first (base);
1708 c && is_const; c = gfc_constructor_next (c))
1710 switch (c->expr->expr_type)
1713 if (len && !(*len && INTEGER_CST_P (*len)))
1714 *len = build_int_cstu (gfc_charlen_type_node,
1715 c->expr->value.character.length);
1719 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1726 get_array_ctor_var_strlen (c->expr, len);
1732 get_array_ctor_all_strlen (block, c->expr, len);
1736 /* After the first iteration, we don't want the length modified. */
1743 /* Check whether the array constructor C consists entirely of constant
1744 elements, and if so returns the number of those elements, otherwise
1745 return zero. Note, an empty or NULL array constructor returns zero. */
1747 unsigned HOST_WIDE_INT
1748 gfc_constant_array_constructor_p (gfc_constructor_base base)
1750 unsigned HOST_WIDE_INT nelem = 0;
1752 gfc_constructor *c = gfc_constructor_first (base);
1756 || c->expr->rank > 0
1757 || c->expr->expr_type != EXPR_CONSTANT)
1759 c = gfc_constructor_next (c);
1766 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1767 and the tree type of it's elements, TYPE, return a static constant
1768 variable that is compile-time initialized. */
1771 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1773 tree tmptype, init, tmp;
1774 HOST_WIDE_INT nelem;
1779 VEC(constructor_elt,gc) *v = NULL;
1781 /* First traverse the constructor list, converting the constants
1782 to tree to build an initializer. */
1784 c = gfc_constructor_first (expr->value.constructor);
1787 gfc_init_se (&se, NULL);
1788 gfc_conv_constant (&se, c->expr);
1789 if (c->expr->ts.type != BT_CHARACTER)
1790 se.expr = fold_convert (type, se.expr);
1791 else if (POINTER_TYPE_P (type))
1792 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1794 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1796 c = gfc_constructor_next (c);
1800 /* Next determine the tree type for the array. We use the gfortran
1801 front-end's gfc_get_nodesc_array_type in order to create a suitable
1802 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1804 memset (&as, 0, sizeof (gfc_array_spec));
1806 as.rank = expr->rank;
1807 as.type = AS_EXPLICIT;
1810 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1811 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1815 for (i = 0; i < expr->rank; i++)
1817 int tmp = (int) mpz_get_si (expr->shape[i]);
1818 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1819 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1823 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1825 init = build_constructor (tmptype, v);
1827 TREE_CONSTANT (init) = 1;
1828 TREE_STATIC (init) = 1;
1830 tmp = gfc_create_var (tmptype, "A");
1831 TREE_STATIC (tmp) = 1;
1832 TREE_CONSTANT (tmp) = 1;
1833 TREE_READONLY (tmp) = 1;
1834 DECL_INITIAL (tmp) = init;
1840 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1841 This mostly initializes the scalarizer state info structure with the
1842 appropriate values to directly use the array created by the function
1843 gfc_build_constant_array_constructor. */
1846 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1847 gfc_ss * ss, tree type)
1853 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1855 info = &ss->data.info;
1857 info->descriptor = tmp;
1858 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1859 info->offset = gfc_index_zero_node;
1861 for (i = 0; i < info->dimen; i++)
1863 info->delta[i] = gfc_index_zero_node;
1864 info->start[i] = gfc_index_zero_node;
1865 info->end[i] = gfc_index_zero_node;
1866 info->stride[i] = gfc_index_one_node;
1870 if (info->dimen > loop->temp_dim)
1871 loop->temp_dim = info->dimen;
1874 /* Helper routine of gfc_trans_array_constructor to determine if the
1875 bounds of the loop specified by LOOP are constant and simple enough
1876 to use with gfc_trans_constant_array_constructor. Returns the
1877 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1880 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1882 tree size = gfc_index_one_node;
1886 for (i = 0; i < loop->dimen; i++)
1888 /* If the bounds aren't constant, return NULL_TREE. */
1889 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1891 if (!integer_zerop (loop->from[i]))
1893 /* Only allow nonzero "from" in one-dimensional arrays. */
1894 if (loop->dimen != 1)
1896 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1897 gfc_array_index_type,
1898 loop->to[i], loop->from[i]);
1902 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1903 tmp, gfc_index_one_node);
1904 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1912 /* Array constructors are handled by constructing a temporary, then using that
1913 within the scalarization loop. This is not optimal, but seems by far the
1917 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1919 gfc_constructor_base c;
1925 bool old_first_len, old_typespec_chararray_ctor;
1926 tree old_first_len_val;
1928 /* Save the old values for nested checking. */
1929 old_first_len = first_len;
1930 old_first_len_val = first_len_val;
1931 old_typespec_chararray_ctor = typespec_chararray_ctor;
1933 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1934 typespec was given for the array constructor. */
1935 typespec_chararray_ctor = (ss->expr->ts.u.cl
1936 && ss->expr->ts.u.cl->length_from_typespec);
1938 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1939 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1941 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1945 ss->data.info.dimen = loop->dimen;
1947 c = ss->expr->value.constructor;
1948 if (ss->expr->ts.type == BT_CHARACTER)
1952 /* get_array_ctor_strlen walks the elements of the constructor, if a
1953 typespec was given, we already know the string length and want the one
1955 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1956 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1960 const_string = false;
1961 gfc_init_se (&length_se, NULL);
1962 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1963 gfc_charlen_type_node);
1964 ss->string_length = length_se.expr;
1965 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1966 gfc_add_block_to_block (&loop->post, &length_se.post);
1969 const_string = get_array_ctor_strlen (&loop->pre, c,
1970 &ss->string_length);
1972 /* Complex character array constructors should have been taken care of
1973 and not end up here. */
1974 gcc_assert (ss->string_length);
1976 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1978 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1980 type = build_pointer_type (type);
1983 type = gfc_typenode_for_spec (&ss->expr->ts);
1985 /* See if the constructor determines the loop bounds. */
1988 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1990 /* We have a multidimensional parameter. */
1992 for (n = 0; n < ss->expr->rank; n++)
1994 loop->from[n] = gfc_index_zero_node;
1995 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1996 gfc_index_integer_kind);
1997 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1998 gfc_array_index_type,
1999 loop->to[n], gfc_index_one_node);
2003 if (loop->to[0] == NULL_TREE)
2007 /* We should have a 1-dimensional, zero-based loop. */
2008 gcc_assert (loop->dimen == 1);
2009 gcc_assert (integer_zerop (loop->from[0]));
2011 /* Split the constructor size into a static part and a dynamic part.
2012 Allocate the static size up-front and record whether the dynamic
2013 size might be nonzero. */
2015 dynamic = gfc_get_array_constructor_size (&size, c);
2016 mpz_sub_ui (size, size, 1);
2017 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2021 /* Special case constant array constructors. */
2024 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2027 tree size = constant_array_constructor_loop_size (loop);
2028 if (size && compare_tree_int (size, nelem) == 0)
2030 gfc_trans_constant_array_constructor (loop, ss, type);
2036 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
2037 type, NULL_TREE, dynamic, true, false, where);
2039 desc = ss->data.info.descriptor;
2040 offset = gfc_index_zero_node;
2041 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2042 TREE_NO_WARNING (offsetvar) = 1;
2043 TREE_USED (offsetvar) = 0;
2044 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2045 &offset, &offsetvar, dynamic);
2047 /* If the array grows dynamically, the upper bound of the loop variable
2048 is determined by the array's final upper bound. */
2050 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
2052 if (TREE_USED (offsetvar))
2053 pushdecl (offsetvar);
2055 gcc_assert (INTEGER_CST_P (offset));
2057 /* Disable bound checking for now because it's probably broken. */
2058 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2065 /* Restore old values of globals. */
2066 first_len = old_first_len;
2067 first_len_val = old_first_len_val;
2068 typespec_chararray_ctor = old_typespec_chararray_ctor;
2072 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2073 called after evaluating all of INFO's vector dimensions. Go through
2074 each such vector dimension and see if we can now fill in any missing
2078 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2087 for (n = 0; n < loop->dimen; n++)
2090 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2091 && loop->to[n] == NULL)
2093 /* Loop variable N indexes vector dimension DIM, and we don't
2094 yet know the upper bound of loop variable N. Set it to the
2095 difference between the vector's upper and lower bounds. */
2096 gcc_assert (loop->from[n] == gfc_index_zero_node);
2097 gcc_assert (info->subscript[dim]
2098 && info->subscript[dim]->type == GFC_SS_VECTOR);
2100 gfc_init_se (&se, NULL);
2101 desc = info->subscript[dim]->data.info.descriptor;
2102 zero = gfc_rank_cst[0];
2103 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2104 gfc_array_index_type,
2105 gfc_conv_descriptor_ubound_get (desc, zero),
2106 gfc_conv_descriptor_lbound_get (desc, zero));
2107 tmp = gfc_evaluate_now (tmp, &loop->pre);
2114 /* Add the pre and post chains for all the scalar expressions in a SS chain
2115 to loop. This is called after the loop parameters have been calculated,
2116 but before the actual scalarizing loops. */
2119 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2125 /* TODO: This can generate bad code if there are ordering dependencies,
2126 e.g., a callee allocated function and an unknown size constructor. */
2127 gcc_assert (ss != NULL);
2129 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2136 /* Scalar expression. Evaluate this now. This includes elemental
2137 dimension indices, but not array section bounds. */
2138 gfc_init_se (&se, NULL);
2139 gfc_conv_expr (&se, ss->expr);
2140 gfc_add_block_to_block (&loop->pre, &se.pre);
2142 if (ss->expr->ts.type != BT_CHARACTER)
2144 /* Move the evaluation of scalar expressions outside the
2145 scalarization loop, except for WHERE assignments. */
2147 se.expr = convert(gfc_array_index_type, se.expr);
2149 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2150 gfc_add_block_to_block (&loop->pre, &se.post);
2153 gfc_add_block_to_block (&loop->post, &se.post);
2155 ss->data.scalar.expr = se.expr;
2156 ss->string_length = se.string_length;
2159 case GFC_SS_REFERENCE:
2160 /* Scalar argument to elemental procedure. Evaluate this
2162 gfc_init_se (&se, NULL);
2163 gfc_conv_expr (&se, ss->expr);
2164 gfc_add_block_to_block (&loop->pre, &se.pre);
2165 gfc_add_block_to_block (&loop->post, &se.post);
2167 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2168 ss->string_length = se.string_length;
2171 case GFC_SS_SECTION:
2172 /* Add the expressions for scalar and vector subscripts. */
2173 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2174 if (ss->data.info.subscript[n])
2175 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2178 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2182 /* Get the vector's descriptor and store it in SS. */
2183 gfc_init_se (&se, NULL);
2184 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2185 gfc_add_block_to_block (&loop->pre, &se.pre);
2186 gfc_add_block_to_block (&loop->post, &se.post);
2187 ss->data.info.descriptor = se.expr;
2190 case GFC_SS_INTRINSIC:
2191 gfc_add_intrinsic_ss_code (loop, ss);
2194 case GFC_SS_FUNCTION:
2195 /* Array function return value. We call the function and save its
2196 result in a temporary for use inside the loop. */
2197 gfc_init_se (&se, NULL);
2200 gfc_conv_expr (&se, ss->expr);
2201 gfc_add_block_to_block (&loop->pre, &se.pre);
2202 gfc_add_block_to_block (&loop->post, &se.post);
2203 ss->string_length = se.string_length;
2206 case GFC_SS_CONSTRUCTOR:
2207 if (ss->expr->ts.type == BT_CHARACTER
2208 && ss->string_length == NULL
2209 && ss->expr->ts.u.cl
2210 && ss->expr->ts.u.cl->length)
2212 gfc_init_se (&se, NULL);
2213 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2214 gfc_charlen_type_node);
2215 ss->string_length = se.expr;
2216 gfc_add_block_to_block (&loop->pre, &se.pre);
2217 gfc_add_block_to_block (&loop->post, &se.post);
2219 gfc_trans_array_constructor (loop, ss, where);
2223 case GFC_SS_COMPONENT:
2224 /* Do nothing. These are handled elsewhere. */
2234 /* Translate expressions for the descriptor and data pointer of a SS. */
2238 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2243 /* Get the descriptor for the array to be scalarized. */
2244 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2245 gfc_init_se (&se, NULL);
2246 se.descriptor_only = 1;
2247 gfc_conv_expr_lhs (&se, ss->expr);
2248 gfc_add_block_to_block (block, &se.pre);
2249 ss->data.info.descriptor = se.expr;
2250 ss->string_length = se.string_length;
2254 /* Also the data pointer. */
2255 tmp = gfc_conv_array_data (se.expr);
2256 /* If this is a variable or address of a variable we use it directly.
2257 Otherwise we must evaluate it now to avoid breaking dependency
2258 analysis by pulling the expressions for elemental array indices
2261 || (TREE_CODE (tmp) == ADDR_EXPR
2262 && DECL_P (TREE_OPERAND (tmp, 0)))))
2263 tmp = gfc_evaluate_now (tmp, block);
2264 ss->data.info.data = tmp;
2266 tmp = gfc_conv_array_offset (se.expr);
2267 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2272 /* Initialize a gfc_loopinfo structure. */
2275 gfc_init_loopinfo (gfc_loopinfo * loop)
2279 memset (loop, 0, sizeof (gfc_loopinfo));
2280 gfc_init_block (&loop->pre);
2281 gfc_init_block (&loop->post);
2283 /* Initially scalarize in order and default to no loop reversal. */
2284 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2287 loop->reverse[n] = GFC_CANNOT_REVERSE;
2290 loop->ss = gfc_ss_terminator;
2294 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2298 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2304 /* Return an expression for the data pointer of an array. */
2307 gfc_conv_array_data (tree descriptor)
2311 type = TREE_TYPE (descriptor);
2312 if (GFC_ARRAY_TYPE_P (type))
2314 if (TREE_CODE (type) == POINTER_TYPE)
2318 /* Descriptorless arrays. */
2319 return gfc_build_addr_expr (NULL_TREE, descriptor);
2323 return gfc_conv_descriptor_data_get (descriptor);
2327 /* Return an expression for the base offset of an array. */
2330 gfc_conv_array_offset (tree descriptor)
2334 type = TREE_TYPE (descriptor);
2335 if (GFC_ARRAY_TYPE_P (type))
2336 return GFC_TYPE_ARRAY_OFFSET (type);
2338 return gfc_conv_descriptor_offset_get (descriptor);
2342 /* Get an expression for the array stride. */
2345 gfc_conv_array_stride (tree descriptor, int dim)
2350 type = TREE_TYPE (descriptor);
2352 /* For descriptorless arrays use the array size. */
2353 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2354 if (tmp != NULL_TREE)
2357 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2362 /* Like gfc_conv_array_stride, but for the lower bound. */
2365 gfc_conv_array_lbound (tree descriptor, int dim)
2370 type = TREE_TYPE (descriptor);
2372 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2373 if (tmp != NULL_TREE)
2376 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2381 /* Like gfc_conv_array_stride, but for the upper bound. */
2384 gfc_conv_array_ubound (tree descriptor, int dim)
2389 type = TREE_TYPE (descriptor);
2391 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2392 if (tmp != NULL_TREE)
2395 /* This should only ever happen when passing an assumed shape array
2396 as an actual parameter. The value will never be used. */
2397 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2398 return gfc_index_zero_node;
2400 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2405 /* Generate code to perform an array index bound check. */
2408 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2409 locus * where, bool check_upper)
2412 tree tmp_lo, tmp_up;
2414 const char * name = NULL;
2416 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2419 index = gfc_evaluate_now (index, &se->pre);
2421 /* We find a name for the error message. */
2423 name = se->ss->expr->symtree->name;
2425 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2426 && se->loop->ss->expr->symtree)
2427 name = se->loop->ss->expr->symtree->name;
2429 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2430 && se->loop->ss->loop_chain->expr
2431 && se->loop->ss->loop_chain->expr->symtree)
2432 name = se->loop->ss->loop_chain->expr->symtree->name;
2434 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2436 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2437 && se->loop->ss->expr->value.function.name)
2438 name = se->loop->ss->expr->value.function.name;
2440 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2441 || se->loop->ss->type == GFC_SS_SCALAR)
2442 name = "unnamed constant";
2445 if (TREE_CODE (descriptor) == VAR_DECL)
2446 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2448 /* If upper bound is present, include both bounds in the error message. */
2451 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2452 tmp_up = gfc_conv_array_ubound (descriptor, n);
2455 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2456 "outside of expected range (%%ld:%%ld)", n+1, name);
2458 asprintf (&msg, "Index '%%ld' of dimension %d "
2459 "outside of expected range (%%ld:%%ld)", n+1);
2461 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2463 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2464 fold_convert (long_integer_type_node, index),
2465 fold_convert (long_integer_type_node, tmp_lo),
2466 fold_convert (long_integer_type_node, tmp_up));
2467 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2469 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2470 fold_convert (long_integer_type_node, index),
2471 fold_convert (long_integer_type_node, tmp_lo),
2472 fold_convert (long_integer_type_node, tmp_up));
2477 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2480 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2481 "below lower bound of %%ld", n+1, name);
2483 asprintf (&msg, "Index '%%ld' of dimension %d "
2484 "below lower bound of %%ld", n+1);
2486 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2488 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2489 fold_convert (long_integer_type_node, index),
2490 fold_convert (long_integer_type_node, tmp_lo));
2498 /* Return the offset for an index. Performs bound checking for elemental
2499 dimensions. Single element references are processed separately.
2500 DIM is the array dimension, I is the loop dimension. */
2503 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2504 gfc_array_ref * ar, tree stride)
2510 /* Get the index into the array for this dimension. */
2513 gcc_assert (ar->type != AR_ELEMENT);
2514 switch (ar->dimen_type[dim])
2517 /* Elemental dimension. */
2518 gcc_assert (info->subscript[dim]
2519 && info->subscript[dim]->type == GFC_SS_SCALAR);
2520 /* We've already translated this value outside the loop. */
2521 index = info->subscript[dim]->data.scalar.expr;
2523 index = gfc_trans_array_bound_check (se, info->descriptor,
2524 index, dim, &ar->where,
2525 ar->as->type != AS_ASSUMED_SIZE
2526 || dim < ar->dimen - 1);
2530 gcc_assert (info && se->loop);
2531 gcc_assert (info->subscript[dim]
2532 && info->subscript[dim]->type == GFC_SS_VECTOR);
2533 desc = info->subscript[dim]->data.info.descriptor;
2535 /* Get a zero-based index into the vector. */
2536 index = fold_build2_loc (input_location, MINUS_EXPR,
2537 gfc_array_index_type,
2538 se->loop->loopvar[i], se->loop->from[i]);
2540 /* Multiply the index by the stride. */
2541 index = fold_build2_loc (input_location, MULT_EXPR,
2542 gfc_array_index_type,
2543 index, gfc_conv_array_stride (desc, 0));
2545 /* Read the vector to get an index into info->descriptor. */
2546 data = build_fold_indirect_ref_loc (input_location,
2547 gfc_conv_array_data (desc));
2548 index = gfc_build_array_ref (data, index, NULL);
2549 index = gfc_evaluate_now (index, &se->pre);
2550 index = fold_convert (gfc_array_index_type, index);
2552 /* Do any bounds checking on the final info->descriptor index. */
2553 index = gfc_trans_array_bound_check (se, info->descriptor,
2554 index, dim, &ar->where,
2555 ar->as->type != AS_ASSUMED_SIZE
2556 || dim < ar->dimen - 1);
2560 /* Scalarized dimension. */
2561 gcc_assert (info && se->loop);
2563 /* Multiply the loop variable by the stride and delta. */
2564 index = se->loop->loopvar[i];
2565 if (!integer_onep (info->stride[dim]))
2566 index = fold_build2_loc (input_location, MULT_EXPR,
2567 gfc_array_index_type, index,
2569 if (!integer_zerop (info->delta[dim]))
2570 index = fold_build2_loc (input_location, PLUS_EXPR,
2571 gfc_array_index_type, index,
2581 /* Temporary array or derived type component. */
2582 gcc_assert (se->loop);
2583 index = se->loop->loopvar[se->loop->order[i]];
2584 if (!integer_zerop (info->delta[dim]))
2585 index = fold_build2_loc (input_location, PLUS_EXPR,
2586 gfc_array_index_type, index, info->delta[dim]);
2589 /* Multiply by the stride. */
2590 if (!integer_onep (stride))
2591 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2598 /* Build a scalarized reference to an array. */
2601 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2604 tree decl = NULL_TREE;
2609 info = &se->ss->data.info;
2611 n = se->loop->order[0];
2615 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2617 /* Add the offset for this dimension to the stored offset for all other
2619 if (!integer_zerop (info->offset))
2620 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2621 index, info->offset);
2623 if (se->ss->expr && is_subref_array (se->ss->expr))
2624 decl = se->ss->expr->symtree->n.sym->backend_decl;
2626 tmp = build_fold_indirect_ref_loc (input_location,
2628 se->expr = gfc_build_array_ref (tmp, index, decl);
2632 /* Translate access of temporary array. */
2635 gfc_conv_tmp_array_ref (gfc_se * se)
2637 se->string_length = se->ss->string_length;
2638 gfc_conv_scalarized_array_ref (se, NULL);
2642 /* Build an array reference. se->expr already holds the array descriptor.
2643 This should be either a variable, indirect variable reference or component
2644 reference. For arrays which do not have a descriptor, se->expr will be
2646 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2649 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2662 /* Handle scalarized references separately. */
2663 if (ar->type != AR_ELEMENT)
2665 gfc_conv_scalarized_array_ref (se, ar);
2666 gfc_advance_se_ss_chain (se);
2670 index = gfc_index_zero_node;
2672 /* Calculate the offsets from all the dimensions. */
2673 for (n = 0; n < ar->dimen; n++)
2675 /* Calculate the index for this dimension. */
2676 gfc_init_se (&indexse, se);
2677 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2678 gfc_add_block_to_block (&se->pre, &indexse.pre);
2680 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2682 /* Check array bounds. */
2686 /* Evaluate the indexse.expr only once. */
2687 indexse.expr = save_expr (indexse.expr);
2690 tmp = gfc_conv_array_lbound (se->expr, n);
2691 if (sym->attr.temporary)
2693 gfc_init_se (&tmpse, se);
2694 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2695 gfc_array_index_type);
2696 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2700 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2702 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2703 "below lower bound of %%ld", n+1, sym->name);
2704 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2705 fold_convert (long_integer_type_node,
2707 fold_convert (long_integer_type_node, tmp));
2710 /* Upper bound, but not for the last dimension of assumed-size
2712 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2714 tmp = gfc_conv_array_ubound (se->expr, n);
2715 if (sym->attr.temporary)
2717 gfc_init_se (&tmpse, se);
2718 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2719 gfc_array_index_type);
2720 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2724 cond = fold_build2_loc (input_location, GT_EXPR,
2725 boolean_type_node, indexse.expr, tmp);
2726 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2727 "above upper bound of %%ld", n+1, sym->name);
2728 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2729 fold_convert (long_integer_type_node,
2731 fold_convert (long_integer_type_node, tmp));
2736 /* Multiply the index by the stride. */
2737 stride = gfc_conv_array_stride (se->expr, n);
2738 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2739 indexse.expr, stride);
2741 /* And add it to the total. */
2742 index = fold_build2_loc (input_location, PLUS_EXPR,
2743 gfc_array_index_type, index, tmp);
2746 tmp = gfc_conv_array_offset (se->expr);
2747 if (!integer_zerop (tmp))
2748 index = fold_build2_loc (input_location, PLUS_EXPR,
2749 gfc_array_index_type, index, tmp);
2751 /* Access the calculated element. */
2752 tmp = gfc_conv_array_data (se->expr);
2753 tmp = build_fold_indirect_ref (tmp);
2754 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2758 /* Generate the code to be executed immediately before entering a
2759 scalarization loop. */
2762 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2763 stmtblock_t * pblock)
2772 /* This code will be executed before entering the scalarization loop
2773 for this dimension. */
2774 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2776 if ((ss->useflags & flag) == 0)
2779 if (ss->type != GFC_SS_SECTION
2780 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2781 && ss->type != GFC_SS_COMPONENT)
2784 info = &ss->data.info;
2786 if (dim >= info->dimen)
2789 if (dim == info->dimen - 1)
2791 /* For the outermost loop calculate the offset due to any
2792 elemental dimensions. It will have been initialized with the
2793 base offset of the array. */
2796 for (i = 0; i < info->ref->u.ar.dimen; i++)
2798 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2801 gfc_init_se (&se, NULL);
2803 se.expr = info->descriptor;
2804 stride = gfc_conv_array_stride (info->descriptor, i);
2805 index = gfc_conv_array_index_offset (&se, info, i, -1,
2808 gfc_add_block_to_block (pblock, &se.pre);
2810 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2811 gfc_array_index_type,
2812 info->offset, index);
2813 info->offset = gfc_evaluate_now (info->offset, pblock);
2818 /* For the time being, the innermost loop is unconditionally on
2819 the first dimension of the scalarization loop. */
2820 gcc_assert (i == 0);
2821 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2823 /* Calculate the stride of the innermost loop. Hopefully this will
2824 allow the backend optimizers to do their stuff more effectively.
2826 info->stride0 = gfc_evaluate_now (stride, pblock);
2830 /* Add the offset for the previous loop dimension. */
2835 ar = &info->ref->u.ar;
2836 i = loop->order[dim + 1];
2844 gfc_init_se (&se, NULL);
2846 se.expr = info->descriptor;
2847 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2848 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2850 gfc_add_block_to_block (pblock, &se.pre);
2851 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2852 gfc_array_index_type, info->offset,
2854 info->offset = gfc_evaluate_now (info->offset, pblock);
2857 /* Remember this offset for the second loop. */
2858 if (dim == loop->temp_dim - 1)
2859 info->saved_offset = info->offset;
2864 /* Start a scalarized expression. Creates a scope and declares loop
2868 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2874 gcc_assert (!loop->array_parameter);
2876 for (dim = loop->dimen - 1; dim >= 0; dim--)
2878 n = loop->order[dim];
2880 gfc_start_block (&loop->code[n]);
2882 /* Create the loop variable. */
2883 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2885 if (dim < loop->temp_dim)
2889 /* Calculate values that will be constant within this loop. */
2890 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2892 gfc_start_block (pbody);
2896 /* Generates the actual loop code for a scalarization loop. */
2899 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2900 stmtblock_t * pbody)
2911 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2912 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2913 && n == loop->dimen - 1)
2915 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2916 init = make_tree_vec (1);
2917 cond = make_tree_vec (1);
2918 incr = make_tree_vec (1);
2920 /* Cycle statement is implemented with a goto. Exit statement must not
2921 be present for this loop. */
2922 exit_label = gfc_build_label_decl (NULL_TREE);
2923 TREE_USED (exit_label) = 1;
2925 /* Label for cycle statements (if needed). */
2926 tmp = build1_v (LABEL_EXPR, exit_label);
2927 gfc_add_expr_to_block (pbody, tmp);
2929 stmt = make_node (OMP_FOR);
2931 TREE_TYPE (stmt) = void_type_node;
2932 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2934 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2935 OMP_CLAUSE_SCHEDULE);
2936 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2937 = OMP_CLAUSE_SCHEDULE_STATIC;
2938 if (ompws_flags & OMPWS_NOWAIT)
2939 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2940 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2942 /* Initialize the loopvar. */
2943 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2945 OMP_FOR_INIT (stmt) = init;
2946 /* The exit condition. */
2947 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2949 loop->loopvar[n], loop->to[n]);
2950 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2951 OMP_FOR_COND (stmt) = cond;
2952 /* Increment the loopvar. */
2953 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2954 loop->loopvar[n], gfc_index_one_node);
2955 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2956 void_type_node, loop->loopvar[n], tmp);
2957 OMP_FOR_INCR (stmt) = incr;
2959 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2960 gfc_add_expr_to_block (&loop->code[n], stmt);
2964 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2965 && (loop->temp_ss == NULL);
2967 loopbody = gfc_finish_block (pbody);
2971 tmp = loop->from[n];
2972 loop->from[n] = loop->to[n];
2976 /* Initialize the loopvar. */
2977 if (loop->loopvar[n] != loop->from[n])
2978 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2980 exit_label = gfc_build_label_decl (NULL_TREE);
2982 /* Generate the loop body. */
2983 gfc_init_block (&block);
2985 /* The exit condition. */
2986 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2987 boolean_type_node, loop->loopvar[n], loop->to[n]);
2988 tmp = build1_v (GOTO_EXPR, exit_label);
2989 TREE_USED (exit_label) = 1;
2990 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2991 gfc_add_expr_to_block (&block, tmp);
2993 /* The main body. */
2994 gfc_add_expr_to_block (&block, loopbody);
2996 /* Increment the loopvar. */
2997 tmp = fold_build2_loc (input_location,
2998 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2999 gfc_array_index_type, loop->loopvar[n],
3000 gfc_index_one_node);
3002 gfc_add_modify (&block, loop->loopvar[n], tmp);
3004 /* Build the loop. */
3005 tmp = gfc_finish_block (&block);
3006 tmp = build1_v (LOOP_EXPR, tmp);
3007 gfc_add_expr_to_block (&loop->code[n], tmp);
3009 /* Add the exit label. */
3010 tmp = build1_v (LABEL_EXPR, exit_label);
3011 gfc_add_expr_to_block (&loop->code[n], tmp);
3017 /* Finishes and generates the loops for a scalarized expression. */
3020 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3025 stmtblock_t *pblock;
3029 /* Generate the loops. */
3030 for (dim = 0; dim < loop->dimen; dim++)
3032 n = loop->order[dim];
3033 gfc_trans_scalarized_loop_end (loop, n, pblock);
3034 loop->loopvar[n] = NULL_TREE;
3035 pblock = &loop->code[n];
3038 tmp = gfc_finish_block (pblock);
3039 gfc_add_expr_to_block (&loop->pre, tmp);
3041 /* Clear all the used flags. */
3042 for (ss = loop->ss; ss; ss = ss->loop_chain)
3047 /* Finish the main body of a scalarized expression, and start the secondary
3051 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3055 stmtblock_t *pblock;
3059 /* We finish as many loops as are used by the temporary. */
3060 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3062 n = loop->order[dim];
3063 gfc_trans_scalarized_loop_end (loop, n, pblock);
3064 loop->loopvar[n] = NULL_TREE;
3065 pblock = &loop->code[n];
3068 /* We don't want to finish the outermost loop entirely. */
3069 n = loop->order[loop->temp_dim - 1];
3070 gfc_trans_scalarized_loop_end (loop, n, pblock);
3072 /* Restore the initial offsets. */
3073 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3075 if ((ss->useflags & 2) == 0)
3078 if (ss->type != GFC_SS_SECTION
3079 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3080 && ss->type != GFC_SS_COMPONENT)
3083 ss->data.info.offset = ss->data.info.saved_offset;
3086 /* Restart all the inner loops we just finished. */
3087 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3089 n = loop->order[dim];
3091 gfc_start_block (&loop->code[n]);
3093 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3095 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3098 /* Start a block for the secondary copying code. */
3099 gfc_start_block (body);
3103 /* Calculate the lower bound of an array section. */
3106 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3115 gcc_assert (ss->type == GFC_SS_SECTION);
3117 info = &ss->data.info;
3119 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3121 /* We use a zero-based index to access the vector. */
3122 info->start[dim] = gfc_index_zero_node;
3123 info->stride[dim] = gfc_index_one_node;
3124 info->end[dim] = NULL;
3128 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3129 desc = info->descriptor;
3130 start = info->ref->u.ar.start[dim];
3131 end = info->ref->u.ar.end[dim];
3132 stride = info->ref->u.ar.stride[dim];
3134 /* Calculate the start of the range. For vector subscripts this will
3135 be the range of the vector. */
3138 /* Specified section start. */
3139 gfc_init_se (&se, NULL);
3140 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3141 gfc_add_block_to_block (&loop->pre, &se.pre);
3142 info->start[dim] = se.expr;
3146 /* No lower bound specified so use the bound of the array. */
3147 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3149 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3151 /* Similarly calculate the end. Although this is not used in the
3152 scalarizer, it is needed when checking bounds and where the end
3153 is an expression with side-effects. */
3156 /* Specified section start. */
3157 gfc_init_se (&se, NULL);
3158 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3159 gfc_add_block_to_block (&loop->pre, &se.pre);
3160 info->end[dim] = se.expr;
3164 /* No upper bound specified so use the bound of the array. */
3165 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3167 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3169 /* Calculate the stride. */
3171 info->stride[dim] = gfc_index_one_node;
3174 gfc_init_se (&se, NULL);
3175 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3176 gfc_add_block_to_block (&loop->pre, &se.pre);
3177 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3182 /* Calculates the range start and stride for a SS chain. Also gets the
3183 descriptor and data pointer. The range of vector subscripts is the size
3184 of the vector. Array bounds are also checked. */
3187 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3195 /* Determine the rank of the loop. */
3197 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3201 case GFC_SS_SECTION:
3202 case GFC_SS_CONSTRUCTOR:
3203 case GFC_SS_FUNCTION:
3204 case GFC_SS_COMPONENT:
3205 loop->dimen = ss->data.info.dimen;
3208 /* As usual, lbound and ubound are exceptions!. */
3209 case GFC_SS_INTRINSIC:
3210 switch (ss->expr->value.function.isym->id)
3212 case GFC_ISYM_LBOUND:
3213 case GFC_ISYM_UBOUND:
3214 loop->dimen = ss->data.info.dimen;
3225 /* We should have determined the rank of the expression by now. If
3226 not, that's bad news. */
3227 gcc_assert (loop->dimen != 0);
3229 /* Loop over all the SS in the chain. */
3230 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3232 if (ss->expr && ss->expr->shape && !ss->shape)
3233 ss->shape = ss->expr->shape;
3237 case GFC_SS_SECTION:
3238 /* Get the descriptor for the array. */
3239 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3241 for (n = 0; n < ss->data.info.dimen; n++)
3242 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
3245 case GFC_SS_INTRINSIC:
3246 switch (ss->expr->value.function.isym->id)
3248 /* Fall through to supply start and stride. */
3249 case GFC_ISYM_LBOUND:
3250 case GFC_ISYM_UBOUND:
3256 case GFC_SS_CONSTRUCTOR:
3257 case GFC_SS_FUNCTION:
3258 for (n = 0; n < ss->data.info.dimen; n++)
3260 ss->data.info.start[n] = gfc_index_zero_node;
3261 ss->data.info.end[n] = gfc_index_zero_node;
3262 ss->data.info.stride[n] = gfc_index_one_node;
3271 /* The rest is just runtime bound checking. */
3272 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3275 tree lbound, ubound;
3277 tree size[GFC_MAX_DIMENSIONS];
3278 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3283 gfc_start_block (&block);
3285 for (n = 0; n < loop->dimen; n++)
3286 size[n] = NULL_TREE;
3288 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3292 if (ss->type != GFC_SS_SECTION)
3295 gfc_start_block (&inner);
3297 /* TODO: range checking for mapped dimensions. */
3298 info = &ss->data.info;
3300 /* This code only checks ranges. Elemental and vector
3301 dimensions are checked later. */
3302 for (n = 0; n < loop->dimen; n++)
3307 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3310 if (dim == info->ref->u.ar.dimen - 1
3311 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3312 check_upper = false;
3316 /* Zero stride is not allowed. */
3317 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3318 info->stride[dim], gfc_index_zero_node);
3319 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3320 "of array '%s'", dim + 1, ss->expr->symtree->name);
3321 gfc_trans_runtime_check (true, false, tmp, &inner,
3322 &ss->expr->where, msg);
3325 desc = ss->data.info.descriptor;
3327 /* This is the run-time equivalent of resolve.c's
3328 check_dimension(). The logical is more readable there
3329 than it is here, with all the trees. */
3330 lbound = gfc_conv_array_lbound (desc, dim);
3331 end = info->end[dim];
3333 ubound = gfc_conv_array_ubound (desc, dim);
3337 /* non_zerosized is true when the selected range is not
3339 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3340 boolean_type_node, info->stride[dim],
3341 gfc_index_zero_node);
3342 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3343 info->start[dim], end);
3344 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3345 boolean_type_node, stride_pos, tmp);
3347 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3349 info->stride[dim], gfc_index_zero_node);
3350 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3351 info->start[dim], end);
3352 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3355 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3357 stride_pos, stride_neg);
3359 /* Check the start of the range against the lower and upper
3360 bounds of the array, if the range is not empty.
3361 If upper bound is present, include both bounds in the
3365 tmp = fold_build2_loc (input_location, LT_EXPR,
3367 info->start[dim], lbound);
3368 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3370 non_zerosized, tmp);
3371 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3373 info->start[dim], ubound);
3374 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3376 non_zerosized, tmp2);
3377 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3378 "outside of expected range (%%ld:%%ld)",
3379 dim + 1, ss->expr->symtree->name);
3380 gfc_trans_runtime_check (true, false, tmp, &inner,
3381 &ss->expr->where, msg,
3382 fold_convert (long_integer_type_node, info->start[dim]),
3383 fold_convert (long_integer_type_node, lbound),
3384 fold_convert (long_integer_type_node, ubound));
3385 gfc_trans_runtime_check (true, false, tmp2, &inner,
3386 &ss->expr->where, msg,
3387 fold_convert (long_integer_type_node, info->start[dim]),
3388 fold_convert (long_integer_type_node, lbound),
3389 fold_convert (long_integer_type_node, ubound));
3394 tmp = fold_build2_loc (input_location, LT_EXPR,
3396 info->start[dim], lbound);
3397 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3398 boolean_type_node, non_zerosized, tmp);
3399 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3400 "below lower bound of %%ld",
3401 dim + 1, ss->expr->symtree->name);
3402 gfc_trans_runtime_check (true, false, tmp, &inner,
3403 &ss->expr->where, msg,
3404 fold_convert (long_integer_type_node, info->start[dim]),
3405 fold_convert (long_integer_type_node, lbound));
3409 /* Compute the last element of the range, which is not
3410 necessarily "end" (think 0:5:3, which doesn't contain 5)
3411 and check it against both lower and upper bounds. */
3413 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3414 gfc_array_index_type, end,
3416 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3417 gfc_array_index_type, tmp,
3419 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3420 gfc_array_index_type, end, tmp);
3421 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3422 boolean_type_node, tmp, lbound);
3423 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3424 boolean_type_node, non_zerosized, tmp2);
3427 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3428 boolean_type_node, tmp, ubound);
3429 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3430 boolean_type_node, non_zerosized, tmp3);
3431 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3432 "outside of expected range (%%ld:%%ld)",
3433 dim + 1, ss->expr->symtree->name);
3434 gfc_trans_runtime_check (true, false, tmp2, &inner,
3435 &ss->expr->where, msg,
3436 fold_convert (long_integer_type_node, tmp),
3437 fold_convert (long_integer_type_node, ubound),
3438 fold_convert (long_integer_type_node, lbound));
3439 gfc_trans_runtime_check (true, false, tmp3, &inner,
3440 &ss->expr->where, msg,
3441 fold_convert (long_integer_type_node, tmp),
3442 fold_convert (long_integer_type_node, ubound),
3443 fold_convert (long_integer_type_node, lbound));
3448 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3449 "below lower bound of %%ld",
3450 dim + 1, ss->expr->symtree->name);
3451 gfc_trans_runtime_check (true, false, tmp2, &inner,
3452 &ss->expr->where, msg,
3453 fold_convert (long_integer_type_node, tmp),
3454 fold_convert (long_integer_type_node, lbound));
3458 /* Check the section sizes match. */
3459 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3460 gfc_array_index_type, end,
3462 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3463 gfc_array_index_type, tmp,
3465 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3466 gfc_array_index_type,
3467 gfc_index_one_node, tmp);
3468 tmp = fold_build2_loc (input_location, MAX_EXPR,
3469 gfc_array_index_type, tmp,
3470 build_int_cst (gfc_array_index_type, 0));
3471 /* We remember the size of the first section, and check all the
3472 others against this. */
3475 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3476 boolean_type_node, tmp, size[n]);
3477 asprintf (&msg, "Array bound mismatch for dimension %d "
3478 "of array '%s' (%%ld/%%ld)",
3479 dim + 1, ss->expr->symtree->name);
3481 gfc_trans_runtime_check (true, false, tmp3, &inner,
3482 &ss->expr->where, msg,
3483 fold_convert (long_integer_type_node, tmp),
3484 fold_convert (long_integer_type_node, size[n]));
3489 size[n] = gfc_evaluate_now (tmp, &inner);
3492 tmp = gfc_finish_block (&inner);
3494 /* For optional arguments, only check bounds if the argument is
3496 if (ss->expr->symtree->n.sym->attr.optional
3497 || ss->expr->symtree->n.sym->attr.not_always_present)
3498 tmp = build3_v (COND_EXPR,
3499 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3500 tmp, build_empty_stmt (input_location));
3502 gfc_add_expr_to_block (&block, tmp);
3506 tmp = gfc_finish_block (&block);
3507 gfc_add_expr_to_block (&loop->pre, tmp);
3512 /* Return true if the two SS could be aliased, i.e. both point to the same data
3514 /* TODO: resolve aliases based on frontend expressions. */
3517 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3524 lsym = lss->expr->symtree->n.sym;
3525 rsym = rss->expr->symtree->n.sym;
3526 if (gfc_symbols_could_alias (lsym, rsym))
3529 if (rsym->ts.type != BT_DERIVED
3530 && lsym->ts.type != BT_DERIVED)
3533 /* For derived types we must check all the component types. We can ignore
3534 array references as these will have the same base type as the previous
3536 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3538 if (lref->type != REF_COMPONENT)
3541 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3544 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3547 if (rref->type != REF_COMPONENT)
3550 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3555 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3557 if (rref->type != REF_COMPONENT)
3560 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3568 /* Resolve array data dependencies. Creates a temporary if required. */
3569 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3573 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3581 loop->temp_ss = NULL;
3583 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3585 if (ss->type != GFC_SS_SECTION)
3588 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3590 if (gfc_could_be_alias (dest, ss)
3591 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3599 lref = dest->expr->ref;
3600 rref = ss->expr->ref;
3602 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3607 /* TODO : loop shifting. */
3610 /* Mark the dimensions for LOOP SHIFTING */
3611 for (n = 0; n < loop->dimen; n++)
3613 int dim = dest->data.info.dim[n];
3615 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3617 else if (! gfc_is_same_range (&lref->u.ar,
3618 &rref->u.ar, dim, 0))
3622 /* Put all the dimensions with dependencies in the
3625 for (n = 0; n < loop->dimen; n++)
3627 gcc_assert (loop->order[n] == n);
3629 loop->order[dim++] = n;
3631 for (n = 0; n < loop->dimen; n++)
3634 loop->order[dim++] = n;
3637 gcc_assert (dim == loop->dimen);
3646 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3647 if (GFC_ARRAY_TYPE_P (base_type)
3648 || GFC_DESCRIPTOR_TYPE_P (base_type))
3649 base_type = gfc_get_element_type (base_type);
3650 loop->temp_ss = gfc_get_ss ();
3651 loop->temp_ss->type = GFC_SS_TEMP;
3652 loop->temp_ss->data.temp.type = base_type;
3653 loop->temp_ss->string_length = dest->string_length;
3654 loop->temp_ss->data.temp.dimen = loop->dimen;
3655 loop->temp_ss->next = gfc_ss_terminator;
3656 gfc_add_ss_to_loop (loop, loop->temp_ss);
3659 loop->temp_ss = NULL;
3663 /* Initialize the scalarization loop. Creates the loop variables. Determines
3664 the range of the loop variables. Creates a temporary if required.
3665 Calculates how to transform from loop variables to array indices for each
3666 expression. Also generates code for scalar expressions which have been
3667 moved outside the loop. */
3670 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3672 int n, dim, spec_dim;
3674 gfc_ss_info *specinfo;
3677 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3678 bool dynamic[GFC_MAX_DIMENSIONS];
3683 for (n = 0; n < loop->dimen; n++)
3687 /* We use one SS term, and use that to determine the bounds of the
3688 loop for this dimension. We try to pick the simplest term. */
3689 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3691 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3694 info = &ss->data.info;
3697 if (loopspec[n] != NULL)
3699 specinfo = &loopspec[n]->data.info;
3700 spec_dim = specinfo->dim[n];
3704 /* Silence unitialized warnings. */
3711 gcc_assert (ss->shape[dim]);
3712 /* The frontend has worked out the size for us. */
3714 || !loopspec[n]->shape
3715 || !integer_zerop (specinfo->start[spec_dim]))
3716 /* Prefer zero-based descriptors if possible. */
3721 if (ss->type == GFC_SS_CONSTRUCTOR)
3723 gfc_constructor_base base;
3724 /* An unknown size constructor will always be rank one.
3725 Higher rank constructors will either have known shape,
3726 or still be wrapped in a call to reshape. */
3727 gcc_assert (loop->dimen == 1);
3729 /* Always prefer to use the constructor bounds if the size
3730 can be determined at compile time. Prefer not to otherwise,
3731 since the general case involves realloc, and it's better to
3732 avoid that overhead if possible. */
3733 base = ss->expr->value.constructor;
3734 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3735 if (!dynamic[n] || !loopspec[n])
3740 /* TODO: Pick the best bound if we have a choice between a
3741 function and something else. */
3742 if (ss->type == GFC_SS_FUNCTION)
3748 if (ss->type != GFC_SS_SECTION)
3753 /* Criteria for choosing a loop specifier (most important first):
3754 doesn't need realloc
3760 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3762 else if (integer_onep (info->stride[dim])
3763 && !integer_onep (specinfo->stride[spec_dim]))
3765 else if (INTEGER_CST_P (info->stride[dim])
3766 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3768 else if (INTEGER_CST_P (info->start[dim])
3769 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3771 /* We don't work out the upper bound.
3772 else if (INTEGER_CST_P (info->finish[n])
3773 && ! INTEGER_CST_P (specinfo->finish[n]))
3774 loopspec[n] = ss; */
3777 /* We should have found the scalarization loop specifier. If not,
3779 gcc_assert (loopspec[n]);
3781 info = &loopspec[n]->data.info;
3784 /* Set the extents of this range. */
3785 cshape = loopspec[n]->shape;
3786 if (cshape && INTEGER_CST_P (info->start[dim])
3787 && INTEGER_CST_P (info->stride[dim]))
3789 loop->from[n] = info->start[dim];
3790 mpz_set (i, cshape[n]);
3791 mpz_sub_ui (i, i, 1);
3792 /* To = from + (size - 1) * stride. */
3793 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3794 if (!integer_onep (info->stride[dim]))
3795 tmp = fold_build2_loc (input_location, MULT_EXPR,
3796 gfc_array_index_type, tmp,
3798 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3799 gfc_array_index_type,
3800 loop->from[n], tmp);
3804 loop->from[n] = info->start[dim];
3805 switch (loopspec[n]->type)
3807 case GFC_SS_CONSTRUCTOR:
3808 /* The upper bound is calculated when we expand the
3810 gcc_assert (loop->to[n] == NULL_TREE);
3813 case GFC_SS_SECTION:
3814 /* Use the end expression if it exists and is not constant,
3815 so that it is only evaluated once. */
3816 loop->to[n] = info->end[dim];
3819 case GFC_SS_FUNCTION:
3820 /* The loop bound will be set when we generate the call. */
3821 gcc_assert (loop->to[n] == NULL_TREE);
3829 /* Transform everything so we have a simple incrementing variable. */
3830 if (integer_onep (info->stride[dim]))
3831 info->delta[dim] = gfc_index_zero_node;
3834 /* Set the delta for this section. */
3835 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3836 /* Number of iterations is (end - start + step) / step.
3837 with start = 0, this simplifies to
3839 for (i = 0; i<=last; i++){...}; */
3840 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3841 gfc_array_index_type, loop->to[n],
3843 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3844 gfc_array_index_type, tmp, info->stride[dim]);
3845 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3846 tmp, build_int_cst (gfc_array_index_type, -1));
3847 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3848 /* Make the loop variable start at 0. */
3849 loop->from[n] = gfc_index_zero_node;
3853 /* Add all the scalar code that can be taken out of the loops.
3854 This may include calculating the loop bounds, so do it before
3855 allocating the temporary. */
3856 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3858 /* If we want a temporary then create it. */
3859 if (loop->temp_ss != NULL)
3861 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3863 /* Make absolutely sure that this is a complete type. */
3864 if (loop->temp_ss->string_length)
3865 loop->temp_ss->data.temp.type
3866 = gfc_get_character_type_len_for_eltype
3867 (TREE_TYPE (loop->temp_ss->data.temp.type),
3868 loop->temp_ss->string_length);
3870 tmp = loop->temp_ss->data.temp.type;
3871 n = loop->temp_ss->data.temp.dimen;
3872 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3873 loop->temp_ss->type = GFC_SS_SECTION;
3874 loop->temp_ss->data.info.dimen = n;
3876 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3877 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3878 loop->temp_ss->data.info.dim[n] = n;
3880 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3881 &loop->temp_ss->data.info, tmp, NULL_TREE,
3882 false, true, false, where);
3885 for (n = 0; n < loop->temp_dim; n++)
3886 loopspec[loop->order[n]] = NULL;
3890 /* For array parameters we don't have loop variables, so don't calculate the
3892 if (loop->array_parameter)
3895 /* Calculate the translation from loop variables to array indices. */
3896 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3898 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3899 && ss->type != GFC_SS_CONSTRUCTOR)
3903 info = &ss->data.info;
3905 for (n = 0; n < info->dimen; n++)
3907 /* If we are specifying the range the delta is already set. */
3908 if (loopspec[n] != ss)
3910 dim = ss->data.info.dim[n];
3912 /* Calculate the offset relative to the loop variable.
3913 First multiply by the stride. */
3914 tmp = loop->from[n];
3915 if (!integer_onep (info->stride[dim]))
3916 tmp = fold_build2_loc (input_location, MULT_EXPR,
3917 gfc_array_index_type,
3918 tmp, info->stride[dim]);
3920 /* Then subtract this from our starting value. */
3921 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3922 gfc_array_index_type,
3923 info->start[dim], tmp);
3925 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
3932 /* Calculate the size of a given array dimension from the bounds. This
3933 is simply (ubound - lbound + 1) if this expression is positive
3934 or 0 if it is negative (pick either one if it is zero). Optionally
3935 (if or_expr is present) OR the (expression != 0) condition to it. */
3938 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
3943 /* Calculate (ubound - lbound + 1). */
3944 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3946 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
3947 gfc_index_one_node);
3949 /* Check whether the size for this dimension is negative. */
3950 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
3951 gfc_index_zero_node);
3952 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
3953 gfc_index_zero_node, res);
3955 /* Build OR expression. */
3957 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3958 boolean_type_node, *or_expr, cond);
3964 /* For an array descriptor, get the total number of elements. This is just
3965 the product of the extents along all dimensions. */
3968 gfc_conv_descriptor_size (tree desc, int rank)
3973 res = gfc_index_one_node;
3975 for (dim = 0; dim < rank; ++dim)
3981 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
3982 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
3984 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
3985 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3993 /* Fills in an array descriptor, and returns the size of the array. The size
3994 will be a simple_val, ie a variable or a constant. Also calculates the
3995 offset of the base. Returns the size of the array.
3999 for (n = 0; n < rank; n++)
4001 a.lbound[n] = specified_lower_bound;
4002 offset = offset + a.lbond[n] * stride;
4004 a.ubound[n] = specified_upper_bound;
4005 a.stride[n] = stride;
4006 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4007 stride = stride * size;
4014 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4015 gfc_expr ** lower, gfc_expr ** upper,
4016 stmtblock_t * pblock)
4027 stmtblock_t thenblock;
4028 stmtblock_t elseblock;
4033 type = TREE_TYPE (descriptor);
4035 stride = gfc_index_one_node;
4036 offset = gfc_index_zero_node;
4038 /* Set the dtype. */
4039 tmp = gfc_conv_descriptor_dtype (descriptor);
4040 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4042 or_expr = boolean_false_node;
4044 for (n = 0; n < rank; n++)
4049 /* We have 3 possibilities for determining the size of the array:
4050 lower == NULL => lbound = 1, ubound = upper[n]
4051 upper[n] = NULL => lbound = 1, ubound = lower[n]
4052 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4055 /* Set lower bound. */
4056 gfc_init_se (&se, NULL);
4058 se.expr = gfc_index_one_node;
4061 gcc_assert (lower[n]);
4064 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4065 gfc_add_block_to_block (pblock, &se.pre);
4069 se.expr = gfc_index_one_node;
4073 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4075 conv_lbound = se.expr;
4077 /* Work out the offset for this component. */
4078 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4080 offset = fold_build2_loc (input_location, MINUS_EXPR,
4081 gfc_array_index_type, offset, tmp);
4083 /* Set upper bound. */
4084 gfc_init_se (&se, NULL);
4085 gcc_assert (ubound);
4086 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4087 gfc_add_block_to_block (pblock, &se.pre);
4089 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4090 gfc_rank_cst[n], se.expr);
4091 conv_ubound = se.expr;
4093 /* Store the stride. */
4094 gfc_conv_descriptor_stride_set (pblock, descriptor,
4095 gfc_rank_cst[n], stride);
4097 /* Calculate size and check whether extent is negative. */
4098 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4100 /* Multiply the stride by the number of elements in this dimension. */
4101 stride = fold_build2_loc (input_location, MULT_EXPR,
4102 gfc_array_index_type, stride, size);
4103 stride = gfc_evaluate_now (stride, pblock);
4106 for (n = rank; n < rank + corank; n++)
4110 /* Set lower bound. */
4111 gfc_init_se (&se, NULL);
4112 if (lower == NULL || lower[n] == NULL)
4114 gcc_assert (n == rank + corank - 1);
4115 se.expr = gfc_index_one_node;
4119 if (ubound || n == rank + corank - 1)
4121 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4122 gfc_add_block_to_block (pblock, &se.pre);
4126 se.expr = gfc_index_one_node;
4130 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4133 if (n < rank + corank - 1)
4135 gfc_init_se (&se, NULL);
4136 gcc_assert (ubound);
4137 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4138 gfc_add_block_to_block (pblock, &se.pre);
4139 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4140 gfc_rank_cst[n], se.expr);
4144 /* The stride is the number of elements in the array, so multiply by the
4145 size of an element to get the total size. */
4146 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4147 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4148 stride, fold_convert (gfc_array_index_type, tmp));
4150 if (poffset != NULL)
4152 offset = gfc_evaluate_now (offset, pblock);
4156 if (integer_zerop (or_expr))
4158 if (integer_onep (or_expr))
4159 return gfc_index_zero_node;
4161 var = gfc_create_var (TREE_TYPE (size), "size");
4162 gfc_start_block (&thenblock);
4163 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
4164 thencase = gfc_finish_block (&thenblock);
4166 gfc_start_block (&elseblock);
4167 gfc_add_modify (&elseblock, var, size);
4168 elsecase = gfc_finish_block (&elseblock);
4170 tmp = gfc_evaluate_now (or_expr, pblock);
4171 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4172 gfc_add_expr_to_block (pblock, tmp);
4178 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4179 the work for an ALLOCATE statement. */
4183 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4191 gfc_ref *ref, *prev_ref = NULL;
4192 bool allocatable_array, coarray;
4196 /* Find the last reference in the chain. */
4197 while (ref && ref->next != NULL)
4199 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4200 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4205 if (ref == NULL || ref->type != REF_ARRAY)
4210 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4211 coarray = expr->symtree->n.sym->attr.codimension;
4215 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4216 coarray = prev_ref->u.c.component->attr.codimension;
4219 /* Return if this is a scalar coarray. */
4220 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4221 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4223 gcc_assert (coarray);
4227 /* Figure out the size of the array. */
4228 switch (ref->u.ar.type)
4234 upper = ref->u.ar.start;
4240 lower = ref->u.ar.start;
4241 upper = ref->u.ar.end;
4245 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4247 lower = ref->u.ar.as->lower;
4248 upper = ref->u.ar.as->upper;
4256 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4257 ref->u.ar.as->corank, &offset, lower, upper,
4260 /* Allocate memory to store the data. */
4261 pointer = gfc_conv_descriptor_data_get (se->expr);
4262 STRIP_NOPS (pointer);
4264 /* The allocate_array variants take the old pointer as first argument. */
4265 if (allocatable_array)
4266 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4268 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4269 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4271 gfc_add_expr_to_block (&se->pre, tmp);
4273 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4275 if (expr->ts.type == BT_DERIVED
4276 && expr->ts.u.derived->attr.alloc_comp)
4278 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4279 ref->u.ar.as->rank);
4280 gfc_add_expr_to_block (&se->pre, tmp);
4287 /* Deallocate an array variable. Also used when an allocated variable goes
4292 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4298 gfc_start_block (&block);
4299 /* Get a pointer to the data. */
4300 var = gfc_conv_descriptor_data_get (descriptor);
4303 /* Parameter is the address of the data component. */
4304 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4305 gfc_add_expr_to_block (&block, tmp);
4307 /* Zero the data pointer. */
4308 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4309 var, build_int_cst (TREE_TYPE (var), 0));
4310 gfc_add_expr_to_block (&block, tmp);
4312 return gfc_finish_block (&block);
4316 /* Create an array constructor from an initialization expression.
4317 We assume the frontend already did any expansions and conversions. */
4320 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4326 unsigned HOST_WIDE_INT lo;
4328 VEC(constructor_elt,gc) *v = NULL;
4330 switch (expr->expr_type)
4333 case EXPR_STRUCTURE:
4334 /* A single scalar or derived type value. Create an array with all
4335 elements equal to that value. */
4336 gfc_init_se (&se, NULL);
4338 if (expr->expr_type == EXPR_CONSTANT)
4339 gfc_conv_constant (&se, expr);
4341 gfc_conv_structure (&se, expr, 1);
4343 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4344 gcc_assert (tmp && INTEGER_CST_P (tmp));
4345 hi = TREE_INT_CST_HIGH (tmp);
4346 lo = TREE_INT_CST_LOW (tmp);
4350 /* This will probably eat buckets of memory for large arrays. */
4351 while (hi != 0 || lo != 0)
4353 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4361 /* Create a vector of all the elements. */
4362 for (c = gfc_constructor_first (expr->value.constructor);
4363 c; c = gfc_constructor_next (c))
4367 /* Problems occur when we get something like
4368 integer :: a(lots) = (/(i, i=1, lots)/) */
4369 gfc_fatal_error ("The number of elements in the array constructor "
4370 "at %L requires an increase of the allowed %d "
4371 "upper limit. See -fmax-array-constructor "
4372 "option", &expr->where,
4373 gfc_option.flag_max_array_constructor);
4376 if (mpz_cmp_si (c->offset, 0) != 0)
4377 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4381 gfc_init_se (&se, NULL);
4382 switch (c->expr->expr_type)
4385 gfc_conv_constant (&se, c->expr);
4386 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4389 case EXPR_STRUCTURE:
4390 gfc_conv_structure (&se, c->expr, 1);
4391 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4396 /* Catch those occasional beasts that do not simplify
4397 for one reason or another, assuming that if they are
4398 standard defying the frontend will catch them. */
4399 gfc_conv_expr (&se, c->expr);
4400 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4407 return gfc_build_null_descriptor (type);
4413 /* Create a constructor from the list of elements. */
4414 tmp = build_constructor (type, v);
4415 TREE_CONSTANT (tmp) = 1;
4420 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4421 returns the size (in elements) of the array. */
4424 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4425 stmtblock_t * pblock)
4440 size = gfc_index_one_node;
4441 offset = gfc_index_zero_node;
4442 for (dim = 0; dim < as->rank; dim++)
4444 /* Evaluate non-constant array bound expressions. */
4445 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4446 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4448 gfc_init_se (&se, NULL);
4449 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4450 gfc_add_block_to_block (pblock, &se.pre);
4451 gfc_add_modify (pblock, lbound, se.expr);
4453 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4454 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4456 gfc_init_se (&se, NULL);
4457 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4458 gfc_add_block_to_block (pblock, &se.pre);
4459 gfc_add_modify (pblock, ubound, se.expr);
4461 /* The offset of this dimension. offset = offset - lbound * stride. */
4462 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4464 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4467 /* The size of this dimension, and the stride of the next. */
4468 if (dim + 1 < as->rank)
4469 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4471 stride = GFC_TYPE_ARRAY_SIZE (type);
4473 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4475 /* Calculate stride = size * (ubound + 1 - lbound). */
4476 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4477 gfc_array_index_type,
4478 gfc_index_one_node, lbound);
4479 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4480 gfc_array_index_type, ubound, tmp);
4481 tmp = fold_build2_loc (input_location, MULT_EXPR,
4482 gfc_array_index_type, size, tmp);
4484 gfc_add_modify (pblock, stride, tmp);
4486 stride = gfc_evaluate_now (tmp, pblock);
4488 /* Make sure that negative size arrays are translated
4489 to being zero size. */
4490 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4491 stride, gfc_index_zero_node);
4492 tmp = fold_build3_loc (input_location, COND_EXPR,
4493 gfc_array_index_type, tmp,
4494 stride, gfc_index_zero_node);
4495 gfc_add_modify (pblock, stride, tmp);
4501 gfc_trans_vla_type_sizes (sym, pblock);
4508 /* Generate code to initialize/allocate an array variable. */
4511 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4512 gfc_wrapped_block * block)
4521 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4523 /* Do nothing for USEd variables. */
4524 if (sym->attr.use_assoc)
4527 type = TREE_TYPE (decl);
4528 gcc_assert (GFC_ARRAY_TYPE_P (type));
4529 onstack = TREE_CODE (type) != POINTER_TYPE;
4531 gfc_start_block (&init);
4533 /* Evaluate character string length. */
4534 if (sym->ts.type == BT_CHARACTER
4535 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4537 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4539 gfc_trans_vla_type_sizes (sym, &init);
4541 /* Emit a DECL_EXPR for this variable, which will cause the
4542 gimplifier to allocate storage, and all that good stuff. */
4543 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4544 gfc_add_expr_to_block (&init, tmp);
4549 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4553 type = TREE_TYPE (type);
4555 gcc_assert (!sym->attr.use_assoc);
4556 gcc_assert (!TREE_STATIC (decl));
4557 gcc_assert (!sym->module);
4559 if (sym->ts.type == BT_CHARACTER
4560 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4561 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4563 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4565 /* Don't actually allocate space for Cray Pointees. */
4566 if (sym->attr.cray_pointee)
4568 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4569 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4571 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4575 /* The size is the number of elements in the array, so multiply by the
4576 size of an element to get the total size. */
4577 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4578 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4579 size, fold_convert (gfc_array_index_type, tmp));
4581 /* Allocate memory to hold the data. */
4582 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4583 gfc_add_modify (&init, decl, tmp);
4585 /* Set offset of the array. */
4586 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4587 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4589 /* Automatic arrays should not have initializers. */
4590 gcc_assert (!sym->value);
4592 /* Free the temporary. */
4593 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4595 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4599 /* Generate entry and exit code for g77 calling convention arrays. */
4602 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4612 gfc_get_backend_locus (&loc);
4613 gfc_set_backend_locus (&sym->declared_at);
4615 /* Descriptor type. */
4616 parm = sym->backend_decl;
4617 type = TREE_TYPE (parm);
4618 gcc_assert (GFC_ARRAY_TYPE_P (type));
4620 gfc_start_block (&init);
4622 if (sym->ts.type == BT_CHARACTER
4623 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4624 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4626 /* Evaluate the bounds of the array. */
4627 gfc_trans_array_bounds (type, sym, &offset, &init);
4629 /* Set the offset. */
4630 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4631 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4633 /* Set the pointer itself if we aren't using the parameter directly. */
4634 if (TREE_CODE (parm) != PARM_DECL)
4636 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4637 gfc_add_modify (&init, parm, tmp);
4639 stmt = gfc_finish_block (&init);
4641 gfc_set_backend_locus (&loc);
4643 /* Add the initialization code to the start of the function. */
4645 if (sym->attr.optional || sym->attr.not_always_present)
4647 tmp = gfc_conv_expr_present (sym);
4648 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4651 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4655 /* Modify the descriptor of an array parameter so that it has the
4656 correct lower bound. Also move the upper bound accordingly.
4657 If the array is not packed, it will be copied into a temporary.
4658 For each dimension we set the new lower and upper bounds. Then we copy the
4659 stride and calculate the offset for this dimension. We also work out
4660 what the stride of a packed array would be, and see it the two match.
4661 If the array need repacking, we set the stride to the values we just
4662 calculated, recalculate the offset and copy the array data.
4663 Code is also added to copy the data back at the end of the function.
4667 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4668 gfc_wrapped_block * block)
4675 tree stmtInit, stmtCleanup;
4682 tree stride, stride2;
4692 /* Do nothing for pointer and allocatable arrays. */
4693 if (sym->attr.pointer || sym->attr.allocatable)
4696 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4698 gfc_trans_g77_array (sym, block);
4702 gfc_get_backend_locus (&loc);
4703 gfc_set_backend_locus (&sym->declared_at);
4705 /* Descriptor type. */
4706 type = TREE_TYPE (tmpdesc);
4707 gcc_assert (GFC_ARRAY_TYPE_P (type));
4708 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4709 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4710 gfc_start_block (&init);
4712 if (sym->ts.type == BT_CHARACTER
4713 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4714 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4716 checkparm = (sym->as->type == AS_EXPLICIT
4717 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4719 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4720 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4722 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4724 /* For non-constant shape arrays we only check if the first dimension
4725 is contiguous. Repacking higher dimensions wouldn't gain us
4726 anything as we still don't know the array stride. */
4727 partial = gfc_create_var (boolean_type_node, "partial");
4728 TREE_USED (partial) = 1;
4729 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4730 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4731 gfc_index_one_node);
4732 gfc_add_modify (&init, partial, tmp);
4735 partial = NULL_TREE;
4737 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4738 here, however I think it does the right thing. */
4741 /* Set the first stride. */
4742 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4743 stride = gfc_evaluate_now (stride, &init);
4745 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4746 stride, gfc_index_zero_node);
4747 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4748 tmp, gfc_index_one_node, stride);
4749 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4750 gfc_add_modify (&init, stride, tmp);
4752 /* Allow the user to disable array repacking. */
4753 stmt_unpacked = NULL_TREE;
4757 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4758 /* A library call to repack the array if necessary. */
4759 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4760 stmt_unpacked = build_call_expr_loc (input_location,
4761 gfor_fndecl_in_pack, 1, tmp);
4763 stride = gfc_index_one_node;
4765 if (gfc_option.warn_array_temp)
4766 gfc_warning ("Creating array temporary at %L", &loc);
4769 /* This is for the case where the array data is used directly without
4770 calling the repack function. */
4771 if (no_repack || partial != NULL_TREE)
4772 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4774 stmt_packed = NULL_TREE;
4776 /* Assign the data pointer. */
4777 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4779 /* Don't repack unknown shape arrays when the first stride is 1. */
4780 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
4781 partial, stmt_packed, stmt_unpacked);
4784 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4785 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
4787 offset = gfc_index_zero_node;
4788 size = gfc_index_one_node;
4790 /* Evaluate the bounds of the array. */
4791 for (n = 0; n < sym->as->rank; n++)
4793 if (checkparm || !sym->as->upper[n])
4795 /* Get the bounds of the actual parameter. */
4796 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4797 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4801 dubound = NULL_TREE;
4802 dlbound = NULL_TREE;
4805 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4806 if (!INTEGER_CST_P (lbound))
4808 gfc_init_se (&se, NULL);
4809 gfc_conv_expr_type (&se, sym->as->lower[n],
4810 gfc_array_index_type);
4811 gfc_add_block_to_block (&init, &se.pre);
4812 gfc_add_modify (&init, lbound, se.expr);
4815 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4816 /* Set the desired upper bound. */
4817 if (sym->as->upper[n])
4819 /* We know what we want the upper bound to be. */
4820 if (!INTEGER_CST_P (ubound))
4822 gfc_init_se (&se, NULL);
4823 gfc_conv_expr_type (&se, sym->as->upper[n],
4824 gfc_array_index_type);
4825 gfc_add_block_to_block (&init, &se.pre);
4826 gfc_add_modify (&init, ubound, se.expr);
4829 /* Check the sizes match. */
4832 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4836 temp = fold_build2_loc (input_location, MINUS_EXPR,
4837 gfc_array_index_type, ubound, lbound);
4838 temp = fold_build2_loc (input_location, PLUS_EXPR,
4839 gfc_array_index_type,
4840 gfc_index_one_node, temp);
4841 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
4842 gfc_array_index_type, dubound,
4844 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
4845 gfc_array_index_type,
4846 gfc_index_one_node, stride2);
4847 tmp = fold_build2_loc (input_location, NE_EXPR,
4848 gfc_array_index_type, temp, stride2);
4849 asprintf (&msg, "Dimension %d of array '%s' has extent "
4850 "%%ld instead of %%ld", n+1, sym->name);
4852 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
4853 fold_convert (long_integer_type_node, temp),
4854 fold_convert (long_integer_type_node, stride2));
4861 /* For assumed shape arrays move the upper bound by the same amount
4862 as the lower bound. */
4863 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4864 gfc_array_index_type, dubound, dlbound);
4865 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4866 gfc_array_index_type, tmp, lbound);
4867 gfc_add_modify (&init, ubound, tmp);
4869 /* The offset of this dimension. offset = offset - lbound * stride. */
4870 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4872 offset = fold_build2_loc (input_location, MINUS_EXPR,
4873 gfc_array_index_type, offset, tmp);
4875 /* The size of this dimension, and the stride of the next. */
4876 if (n + 1 < sym->as->rank)
4878 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4880 if (no_repack || partial != NULL_TREE)
4882 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4884 /* Figure out the stride if not a known constant. */
4885 if (!INTEGER_CST_P (stride))
4888 stmt_packed = NULL_TREE;
4891 /* Calculate stride = size * (ubound + 1 - lbound). */
4892 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4893 gfc_array_index_type,
4894 gfc_index_one_node, lbound);
4895 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4896 gfc_array_index_type, ubound, tmp);
4897 size = fold_build2_loc (input_location, MULT_EXPR,
4898 gfc_array_index_type, size, tmp);
4902 /* Assign the stride. */
4903 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4904 tmp = fold_build3_loc (input_location, COND_EXPR,
4905 gfc_array_index_type, partial,
4906 stmt_unpacked, stmt_packed);
4908 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4909 gfc_add_modify (&init, stride, tmp);
4914 stride = GFC_TYPE_ARRAY_SIZE (type);
4916 if (stride && !INTEGER_CST_P (stride))
4918 /* Calculate size = stride * (ubound + 1 - lbound). */
4919 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4920 gfc_array_index_type,
4921 gfc_index_one_node, lbound);
4922 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4923 gfc_array_index_type,
4925 tmp = fold_build2_loc (input_location, MULT_EXPR,
4926 gfc_array_index_type,
4927 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4928 gfc_add_modify (&init, stride, tmp);
4933 /* Set the offset. */
4934 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4935 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4937 gfc_trans_vla_type_sizes (sym, &init);
4939 stmtInit = gfc_finish_block (&init);
4941 /* Only do the entry/initialization code if the arg is present. */
4942 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4943 optional_arg = (sym->attr.optional
4944 || (sym->ns->proc_name->attr.entry_master
4945 && sym->attr.dummy));
4948 tmp = gfc_conv_expr_present (sym);
4949 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
4950 build_empty_stmt (input_location));
4955 stmtCleanup = NULL_TREE;
4958 stmtblock_t cleanup;
4959 gfc_start_block (&cleanup);
4961 if (sym->attr.intent != INTENT_IN)
4963 /* Copy the data back. */
4964 tmp = build_call_expr_loc (input_location,
4965 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4966 gfc_add_expr_to_block (&cleanup, tmp);
4969 /* Free the temporary. */
4970 tmp = gfc_call_free (tmpdesc);
4971 gfc_add_expr_to_block (&cleanup, tmp);
4973 stmtCleanup = gfc_finish_block (&cleanup);
4975 /* Only do the cleanup if the array was repacked. */
4976 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
4977 tmp = gfc_conv_descriptor_data_get (tmp);
4978 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4980 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4981 build_empty_stmt (input_location));
4985 tmp = gfc_conv_expr_present (sym);
4986 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4987 build_empty_stmt (input_location));
4991 /* We don't need to free any memory allocated by internal_pack as it will
4992 be freed at the end of the function by pop_context. */
4993 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
4997 /* Calculate the overall offset, including subreferences. */
4999 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5000 bool subref, gfc_expr *expr)
5010 /* If offset is NULL and this is not a subreferenced array, there is
5012 if (offset == NULL_TREE)
5015 offset = gfc_index_zero_node;
5020 tmp = gfc_conv_array_data (desc);
5021 tmp = build_fold_indirect_ref_loc (input_location,
5023 tmp = gfc_build_array_ref (tmp, offset, NULL);
5025 /* Offset the data pointer for pointer assignments from arrays with
5026 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5029 /* Go past the array reference. */
5030 for (ref = expr->ref; ref; ref = ref->next)
5031 if (ref->type == REF_ARRAY &&
5032 ref->u.ar.type != AR_ELEMENT)
5038 /* Calculate the offset for each subsequent subreference. */
5039 for (; ref; ref = ref->next)
5044 field = ref->u.c.component->backend_decl;
5045 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5046 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5048 tmp, field, NULL_TREE);
5052 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5053 gfc_init_se (&start, NULL);
5054 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5055 gfc_add_block_to_block (block, &start.pre);
5056 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5060 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5061 && ref->u.ar.type == AR_ELEMENT);
5063 /* TODO - Add bounds checking. */
5064 stride = gfc_index_one_node;
5065 index = gfc_index_zero_node;
5066 for (n = 0; n < ref->u.ar.dimen; n++)
5071 /* Update the index. */
5072 gfc_init_se (&start, NULL);
5073 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5074 itmp = gfc_evaluate_now (start.expr, block);
5075 gfc_init_se (&start, NULL);
5076 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5077 jtmp = gfc_evaluate_now (start.expr, block);
5078 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5079 gfc_array_index_type, itmp, jtmp);
5080 itmp = fold_build2_loc (input_location, MULT_EXPR,
5081 gfc_array_index_type, itmp, stride);
5082 index = fold_build2_loc (input_location, PLUS_EXPR,
5083 gfc_array_index_type, itmp, index);
5084 index = gfc_evaluate_now (index, block);
5086 /* Update the stride. */
5087 gfc_init_se (&start, NULL);
5088 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5089 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5090 gfc_array_index_type, start.expr,
5092 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5093 gfc_array_index_type,
5094 gfc_index_one_node, itmp);
5095 stride = fold_build2_loc (input_location, MULT_EXPR,
5096 gfc_array_index_type, stride, itmp);
5097 stride = gfc_evaluate_now (stride, block);
5100 /* Apply the index to obtain the array element. */
5101 tmp = gfc_build_array_ref (tmp, index, NULL);
5111 /* Set the target data pointer. */
5112 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5113 gfc_conv_descriptor_data_set (block, parm, offset);
5117 /* gfc_conv_expr_descriptor needs the string length an expression
5118 so that the size of the temporary can be obtained. This is done
5119 by adding up the string lengths of all the elements in the
5120 expression. Function with non-constant expressions have their
5121 string lengths mapped onto the actual arguments using the
5122 interface mapping machinery in trans-expr.c. */
5124 get_array_charlen (gfc_expr *expr, gfc_se *se)
5126 gfc_interface_mapping mapping;
5127 gfc_formal_arglist *formal;
5128 gfc_actual_arglist *arg;
5131 if (expr->ts.u.cl->length
5132 && gfc_is_constant_expr (expr->ts.u.cl->length))
5134 if (!expr->ts.u.cl->backend_decl)
5135 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5139 switch (expr->expr_type)
5142 get_array_charlen (expr->value.op.op1, se);
5144 /* For parentheses the expression ts.u.cl is identical. */
5145 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5148 expr->ts.u.cl->backend_decl =
5149 gfc_create_var (gfc_charlen_type_node, "sln");
5151 if (expr->value.op.op2)
5153 get_array_charlen (expr->value.op.op2, se);
5155 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5157 /* Add the string lengths and assign them to the expression
5158 string length backend declaration. */
5159 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5160 fold_build2_loc (input_location, PLUS_EXPR,
5161 gfc_charlen_type_node,
5162 expr->value.op.op1->ts.u.cl->backend_decl,
5163 expr->value.op.op2->ts.u.cl->backend_decl));
5166 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5167 expr->value.op.op1->ts.u.cl->backend_decl);
5171 if (expr->value.function.esym == NULL
5172 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5174 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5178 /* Map expressions involving the dummy arguments onto the actual
5179 argument expressions. */
5180 gfc_init_interface_mapping (&mapping);
5181 formal = expr->symtree->n.sym->formal;
5182 arg = expr->value.function.actual;
5184 /* Set se = NULL in the calls to the interface mapping, to suppress any
5186 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5191 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5194 gfc_init_se (&tse, NULL);
5196 /* Build the expression for the character length and convert it. */
5197 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5199 gfc_add_block_to_block (&se->pre, &tse.pre);
5200 gfc_add_block_to_block (&se->post, &tse.post);
5201 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5202 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5203 gfc_charlen_type_node, tse.expr,
5204 build_int_cst (gfc_charlen_type_node, 0));
5205 expr->ts.u.cl->backend_decl = tse.expr;
5206 gfc_free_interface_mapping (&mapping);
5210 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5217 /* Convert an array for passing as an actual argument. Expressions and
5218 vector subscripts are evaluated and stored in a temporary, which is then
5219 passed. For whole arrays the descriptor is passed. For array sections
5220 a modified copy of the descriptor is passed, but using the original data.
5222 This function is also used for array pointer assignments, and there
5225 - se->want_pointer && !se->direct_byref
5226 EXPR is an actual argument. On exit, se->expr contains a
5227 pointer to the array descriptor.
5229 - !se->want_pointer && !se->direct_byref
5230 EXPR is an actual argument to an intrinsic function or the
5231 left-hand side of a pointer assignment. On exit, se->expr
5232 contains the descriptor for EXPR.
5234 - !se->want_pointer && se->direct_byref
5235 EXPR is the right-hand side of a pointer assignment and
5236 se->expr is the descriptor for the previously-evaluated
5237 left-hand side. The function creates an assignment from
5238 EXPR to se->expr. */
5241 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5254 bool subref_array_target = false;
5256 gcc_assert (ss != gfc_ss_terminator);
5258 /* Special case things we know we can pass easily. */
5259 switch (expr->expr_type)
5262 /* If we have a linear array section, we can pass it directly.
5263 Otherwise we need to copy it into a temporary. */
5265 /* Find the SS for the array section. */
5267 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5268 secss = secss->next;
5270 gcc_assert (secss != gfc_ss_terminator);
5271 info = &secss->data.info;
5273 /* Get the descriptor for the array. */
5274 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5275 desc = info->descriptor;
5277 subref_array_target = se->direct_byref && is_subref_array (expr);
5278 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5279 && !subref_array_target;
5283 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5285 /* Create a new descriptor if the array doesn't have one. */
5288 else if (info->ref->u.ar.type == AR_FULL)
5290 else if (se->direct_byref)
5293 full = gfc_full_array_ref_p (info->ref, NULL);
5297 if (se->direct_byref && !se->byref_noassign)
5299 /* Copy the descriptor for pointer assignments. */
5300 gfc_add_modify (&se->pre, se->expr, desc);
5302 /* Add any offsets from subreferences. */
5303 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5304 subref_array_target, expr);
5306 else if (se->want_pointer)
5308 /* We pass full arrays directly. This means that pointers and
5309 allocatable arrays should also work. */
5310 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5317 if (expr->ts.type == BT_CHARACTER)
5318 se->string_length = gfc_get_expr_charlen (expr);
5325 /* A transformational function return value will be a temporary
5326 array descriptor. We still need to go through the scalarizer
5327 to create the descriptor. Elemental functions ar handled as
5328 arbitrary expressions, i.e. copy to a temporary. */
5330 /* Look for the SS for this function. */
5331 while (secss != gfc_ss_terminator
5332 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5333 secss = secss->next;
5335 if (se->direct_byref)
5337 gcc_assert (secss != gfc_ss_terminator);
5339 /* For pointer assignments pass the descriptor directly. */
5341 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5342 gfc_conv_expr (se, expr);
5346 if (secss == gfc_ss_terminator)
5348 /* Elemental function. */
5350 if (expr->ts.type == BT_CHARACTER
5351 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5352 get_array_charlen (expr, se);
5358 /* Transformational function. */
5359 info = &secss->data.info;
5365 /* Constant array constructors don't need a temporary. */
5366 if (ss->type == GFC_SS_CONSTRUCTOR
5367 && expr->ts.type != BT_CHARACTER
5368 && gfc_constant_array_constructor_p (expr->value.constructor))
5371 info = &ss->data.info;
5383 /* Something complicated. Copy it into a temporary. */
5390 gfc_init_loopinfo (&loop);
5392 /* Associate the SS with the loop. */
5393 gfc_add_ss_to_loop (&loop, ss);
5395 /* Tell the scalarizer not to bother creating loop variables, etc. */
5397 loop.array_parameter = 1;
5399 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5400 gcc_assert (!se->direct_byref);
5402 /* Setup the scalarizing loops and bounds. */
5403 gfc_conv_ss_startstride (&loop);
5407 /* Tell the scalarizer to make a temporary. */
5408 loop.temp_ss = gfc_get_ss ();
5409 loop.temp_ss->type = GFC_SS_TEMP;
5410 loop.temp_ss->next = gfc_ss_terminator;
5412 if (expr->ts.type == BT_CHARACTER
5413 && !expr->ts.u.cl->backend_decl)
5414 get_array_charlen (expr, se);
5416 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5418 if (expr->ts.type == BT_CHARACTER)
5419 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5421 loop.temp_ss->string_length = NULL;
5423 se->string_length = loop.temp_ss->string_length;
5424 loop.temp_ss->data.temp.dimen = loop.dimen;
5425 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5428 gfc_conv_loop_setup (&loop, & expr->where);
5432 /* Copy into a temporary and pass that. We don't need to copy the data
5433 back because expressions and vector subscripts must be INTENT_IN. */
5434 /* TODO: Optimize passing function return values. */
5438 /* Start the copying loops. */
5439 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5440 gfc_mark_ss_chain_used (ss, 1);
5441 gfc_start_scalarized_body (&loop, &block);
5443 /* Copy each data element. */
5444 gfc_init_se (&lse, NULL);
5445 gfc_copy_loopinfo_to_se (&lse, &loop);
5446 gfc_init_se (&rse, NULL);
5447 gfc_copy_loopinfo_to_se (&rse, &loop);
5449 lse.ss = loop.temp_ss;
5452 gfc_conv_scalarized_array_ref (&lse, NULL);
5453 if (expr->ts.type == BT_CHARACTER)
5455 gfc_conv_expr (&rse, expr);
5456 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5457 rse.expr = build_fold_indirect_ref_loc (input_location,
5461 gfc_conv_expr_val (&rse, expr);
5463 gfc_add_block_to_block (&block, &rse.pre);
5464 gfc_add_block_to_block (&block, &lse.pre);
5466 lse.string_length = rse.string_length;
5467 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5468 expr->expr_type == EXPR_VARIABLE, true);
5469 gfc_add_expr_to_block (&block, tmp);
5471 /* Finish the copying loops. */
5472 gfc_trans_scalarizing_loops (&loop, &block);
5474 desc = loop.temp_ss->data.info.descriptor;
5476 else if (expr->expr_type == EXPR_FUNCTION)
5478 desc = info->descriptor;
5479 se->string_length = ss->string_length;
5483 /* We pass sections without copying to a temporary. Make a new
5484 descriptor and point it at the section we want. The loop variable
5485 limits will be the limits of the section.
5486 A function may decide to repack the array to speed up access, but
5487 we're not bothered about that here. */
5496 /* Set the string_length for a character array. */
5497 if (expr->ts.type == BT_CHARACTER)
5498 se->string_length = gfc_get_expr_charlen (expr);
5500 desc = info->descriptor;
5501 gcc_assert (secss && secss != gfc_ss_terminator);
5502 if (se->direct_byref && !se->byref_noassign)
5504 /* For pointer assignments we fill in the destination. */
5506 parmtype = TREE_TYPE (parm);
5510 /* Otherwise make a new one. */
5511 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5512 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5513 loop.from, loop.to, 0,
5514 GFC_ARRAY_UNKNOWN, false);
5515 parm = gfc_create_var (parmtype, "parm");
5518 offset = gfc_index_zero_node;
5521 /* The following can be somewhat confusing. We have two
5522 descriptors, a new one and the original array.
5523 {parm, parmtype, dim} refer to the new one.
5524 {desc, type, n, secss, loop} refer to the original, which maybe
5525 a descriptorless array.
5526 The bounds of the scalarization are the bounds of the section.
5527 We don't have to worry about numeric overflows when calculating
5528 the offsets because all elements are within the array data. */
5530 /* Set the dtype. */
5531 tmp = gfc_conv_descriptor_dtype (parm);
5532 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5534 /* Set offset for assignments to pointer only to zero if it is not
5536 if (se->direct_byref
5537 && info->ref && info->ref->u.ar.type != AR_FULL)
5538 base = gfc_index_zero_node;
5539 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5540 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5544 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5545 for (n = 0; n < ndim; n++)
5547 stride = gfc_conv_array_stride (desc, n);
5549 /* Work out the offset. */
5551 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5553 gcc_assert (info->subscript[n]
5554 && info->subscript[n]->type == GFC_SS_SCALAR);
5555 start = info->subscript[n]->data.scalar.expr;
5559 /* Check we haven't somehow got out of sync. */
5560 gcc_assert (info->dim[dim] == n);
5562 /* Evaluate and remember the start of the section. */
5563 start = info->start[n];
5564 stride = gfc_evaluate_now (stride, &loop.pre);
5567 tmp = gfc_conv_array_lbound (desc, n);
5568 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5570 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5572 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5576 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5578 /* For elemental dimensions, we only need the offset. */
5582 /* Vector subscripts need copying and are handled elsewhere. */
5584 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5586 /* Set the new lower bound. */
5587 from = loop.from[dim];
5590 /* If we have an array section or are assigning make sure that
5591 the lower bound is 1. References to the full
5592 array should otherwise keep the original bounds. */
5594 || info->ref->u.ar.type != AR_FULL)
5595 && !integer_onep (from))
5597 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5598 gfc_array_index_type, gfc_index_one_node,
5600 to = fold_build2_loc (input_location, PLUS_EXPR,
5601 gfc_array_index_type, to, tmp);
5602 from = gfc_index_one_node;
5604 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5605 gfc_rank_cst[dim], from);
5607 /* Set the new upper bound. */
5608 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5609 gfc_rank_cst[dim], to);
5611 /* Multiply the stride by the section stride to get the
5613 stride = fold_build2_loc (input_location, MULT_EXPR,
5614 gfc_array_index_type,
5615 stride, info->stride[n]);
5617 if (se->direct_byref
5619 && info->ref->u.ar.type != AR_FULL)
5621 base = fold_build2_loc (input_location, MINUS_EXPR,
5622 TREE_TYPE (base), base, stride);
5624 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5626 tmp = gfc_conv_array_lbound (desc, n);
5627 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5628 TREE_TYPE (base), tmp, loop.from[dim]);
5629 tmp = fold_build2_loc (input_location, MULT_EXPR,
5630 TREE_TYPE (base), tmp,
5631 gfc_conv_array_stride (desc, n));
5632 base = fold_build2_loc (input_location, PLUS_EXPR,
5633 TREE_TYPE (base), tmp, base);
5636 /* Store the new stride. */
5637 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5638 gfc_rank_cst[dim], stride);
5643 if (se->data_not_needed)
5644 gfc_conv_descriptor_data_set (&loop.pre, parm,
5645 gfc_index_zero_node);
5647 /* Point the data pointer at the 1st element in the section. */
5648 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5649 subref_array_target, expr);
5651 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5652 && !se->data_not_needed)
5654 /* Set the offset. */
5655 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5659 /* Only the callee knows what the correct offset it, so just set
5661 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5666 if (!se->direct_byref || se->byref_noassign)
5668 /* Get a pointer to the new descriptor. */
5669 if (se->want_pointer)
5670 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5675 gfc_add_block_to_block (&se->pre, &loop.pre);
5676 gfc_add_block_to_block (&se->post, &loop.post);
5678 /* Cleanup the scalarizer. */
5679 gfc_cleanup_loop (&loop);
5682 /* Helper function for gfc_conv_array_parameter if array size needs to be
5686 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5689 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5690 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5691 else if (expr->rank > 1)
5692 *size = build_call_expr_loc (input_location,
5693 gfor_fndecl_size0, 1,
5694 gfc_build_addr_expr (NULL, desc));
5697 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5698 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5700 *size = fold_build2_loc (input_location, MINUS_EXPR,
5701 gfc_array_index_type, ubound, lbound);
5702 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5703 *size, gfc_index_one_node);
5704 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5705 *size, gfc_index_zero_node);
5707 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5708 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5709 *size, fold_convert (gfc_array_index_type, elem));
5712 /* Convert an array for passing as an actual parameter. */
5713 /* TODO: Optimize passing g77 arrays. */
5716 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5717 const gfc_symbol *fsym, const char *proc_name,
5722 tree tmp = NULL_TREE;
5724 tree parent = DECL_CONTEXT (current_function_decl);
5725 bool full_array_var;
5726 bool this_array_result;
5729 bool array_constructor;
5730 bool good_allocatable;
5731 bool ultimate_ptr_comp;
5732 bool ultimate_alloc_comp;
5737 ultimate_ptr_comp = false;
5738 ultimate_alloc_comp = false;
5740 for (ref = expr->ref; ref; ref = ref->next)
5742 if (ref->next == NULL)
5745 if (ref->type == REF_COMPONENT)
5747 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5748 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5752 full_array_var = false;
5755 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5756 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5758 sym = full_array_var ? expr->symtree->n.sym : NULL;
5760 /* The symbol should have an array specification. */
5761 gcc_assert (!sym || sym->as || ref->u.ar.as);
5763 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5765 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5766 expr->ts.u.cl->backend_decl = tmp;
5767 se->string_length = tmp;
5770 /* Is this the result of the enclosing procedure? */
5771 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5772 if (this_array_result
5773 && (sym->backend_decl != current_function_decl)
5774 && (sym->backend_decl != parent))
5775 this_array_result = false;
5777 /* Passing address of the array if it is not pointer or assumed-shape. */
5778 if (full_array_var && g77 && !this_array_result)
5780 tmp = gfc_get_symbol_decl (sym);
5782 if (sym->ts.type == BT_CHARACTER)
5783 se->string_length = sym->ts.u.cl->backend_decl;
5785 if (sym->ts.type == BT_DERIVED)
5787 gfc_conv_expr_descriptor (se, expr, ss);
5788 se->expr = gfc_conv_array_data (se->expr);
5792 if (!sym->attr.pointer
5794 && sym->as->type != AS_ASSUMED_SHAPE
5795 && !sym->attr.allocatable)
5797 /* Some variables are declared directly, others are declared as
5798 pointers and allocated on the heap. */
5799 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5802 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5804 array_parameter_size (tmp, expr, size);
5808 if (sym->attr.allocatable)
5810 if (sym->attr.dummy || sym->attr.result)
5812 gfc_conv_expr_descriptor (se, expr, ss);
5816 array_parameter_size (tmp, expr, size);
5817 se->expr = gfc_conv_array_data (tmp);
5822 /* A convenient reduction in scope. */
5823 contiguous = g77 && !this_array_result && contiguous;
5825 /* There is no need to pack and unpack the array, if it is contiguous
5826 and not a deferred- or assumed-shape array, or if it is simply
5828 no_pack = ((sym && sym->as
5829 && !sym->attr.pointer
5830 && sym->as->type != AS_DEFERRED
5831 && sym->as->type != AS_ASSUMED_SHAPE)
5833 (ref && ref->u.ar.as
5834 && ref->u.ar.as->type != AS_DEFERRED
5835 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
5837 gfc_is_simply_contiguous (expr, false));
5839 no_pack = contiguous && no_pack;
5841 /* Array constructors are always contiguous and do not need packing. */
5842 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5844 /* Same is true of contiguous sections from allocatable variables. */
5845 good_allocatable = contiguous
5847 && expr->symtree->n.sym->attr.allocatable;
5849 /* Or ultimate allocatable components. */
5850 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5852 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5854 gfc_conv_expr_descriptor (se, expr, ss);
5855 if (expr->ts.type == BT_CHARACTER)
5856 se->string_length = expr->ts.u.cl->backend_decl;
5858 array_parameter_size (se->expr, expr, size);
5859 se->expr = gfc_conv_array_data (se->expr);
5863 if (this_array_result)
5865 /* Result of the enclosing function. */
5866 gfc_conv_expr_descriptor (se, expr, ss);
5868 array_parameter_size (se->expr, expr, size);
5869 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5871 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5872 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5873 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5880 /* Every other type of array. */
5881 se->want_pointer = 1;
5882 gfc_conv_expr_descriptor (se, expr, ss);
5884 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5889 /* Deallocate the allocatable components of structures that are
5891 if (expr->ts.type == BT_DERIVED
5892 && expr->ts.u.derived->attr.alloc_comp
5893 && expr->expr_type != EXPR_VARIABLE)
5895 tmp = build_fold_indirect_ref_loc (input_location,
5897 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5898 gfc_add_expr_to_block (&se->post, tmp);
5901 if (g77 || (fsym && fsym->attr.contiguous
5902 && !gfc_is_simply_contiguous (expr, false)))
5904 tree origptr = NULL_TREE;
5908 /* For contiguous arrays, save the original value of the descriptor. */
5911 origptr = gfc_create_var (pvoid_type_node, "origptr");
5912 tmp = build_fold_indirect_ref_loc (input_location, desc);
5913 tmp = gfc_conv_array_data (tmp);
5914 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5915 TREE_TYPE (origptr), origptr,
5916 fold_convert (TREE_TYPE (origptr), tmp));
5917 gfc_add_expr_to_block (&se->pre, tmp);
5920 /* Repack the array. */
5921 if (gfc_option.warn_array_temp)
5924 gfc_warning ("Creating array temporary at %L for argument '%s'",
5925 &expr->where, fsym->name);
5927 gfc_warning ("Creating array temporary at %L", &expr->where);
5930 ptr = build_call_expr_loc (input_location,
5931 gfor_fndecl_in_pack, 1, desc);
5933 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5935 tmp = gfc_conv_expr_present (sym);
5936 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
5937 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
5938 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5941 ptr = gfc_evaluate_now (ptr, &se->pre);
5943 /* Use the packed data for the actual argument, except for contiguous arrays,
5944 where the descriptor's data component is set. */
5949 tmp = build_fold_indirect_ref_loc (input_location, desc);
5950 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
5953 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5957 if (fsym && proc_name)
5958 asprintf (&msg, "An array temporary was created for argument "
5959 "'%s' of procedure '%s'", fsym->name, proc_name);
5961 asprintf (&msg, "An array temporary was created");
5963 tmp = build_fold_indirect_ref_loc (input_location,
5965 tmp = gfc_conv_array_data (tmp);
5966 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5967 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5969 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5970 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5972 gfc_conv_expr_present (sym), tmp);
5974 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5979 gfc_start_block (&block);
5981 /* Copy the data back. */
5982 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5984 tmp = build_call_expr_loc (input_location,
5985 gfor_fndecl_in_unpack, 2, desc, ptr);
5986 gfc_add_expr_to_block (&block, tmp);
5989 /* Free the temporary. */
5990 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5991 gfc_add_expr_to_block (&block, tmp);
5993 stmt = gfc_finish_block (&block);
5995 gfc_init_block (&block);
5996 /* Only if it was repacked. This code needs to be executed before the
5997 loop cleanup code. */
5998 tmp = build_fold_indirect_ref_loc (input_location,
6000 tmp = gfc_conv_array_data (tmp);
6001 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6002 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6004 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6005 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6007 gfc_conv_expr_present (sym), tmp);
6009 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6011 gfc_add_expr_to_block (&block, tmp);
6012 gfc_add_block_to_block (&block, &se->post);
6014 gfc_init_block (&se->post);
6016 /* Reset the descriptor pointer. */
6019 tmp = build_fold_indirect_ref_loc (input_location, desc);
6020 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6023 gfc_add_block_to_block (&se->post, &block);
6028 /* Generate code to deallocate an array, if it is allocated. */
6031 gfc_trans_dealloc_allocated (tree descriptor)
6037 gfc_start_block (&block);
6039 var = gfc_conv_descriptor_data_get (descriptor);
6042 /* Call array_deallocate with an int * present in the second argument.
6043 Although it is ignored here, it's presence ensures that arrays that
6044 are already deallocated are ignored. */
6045 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6046 gfc_add_expr_to_block (&block, tmp);
6048 /* Zero the data pointer. */
6049 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6050 var, build_int_cst (TREE_TYPE (var), 0));
6051 gfc_add_expr_to_block (&block, tmp);
6053 return gfc_finish_block (&block);
6057 /* This helper function calculates the size in words of a full array. */
6060 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6065 idx = gfc_rank_cst[rank - 1];
6066 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6067 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6068 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6070 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6071 tmp, gfc_index_one_node);
6072 tmp = gfc_evaluate_now (tmp, block);
6074 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6075 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6077 return gfc_evaluate_now (tmp, block);
6081 /* Allocate dest to the same size as src, and copy src -> dest.
6082 If no_malloc is set, only the copy is done. */
6085 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6095 /* If the source is null, set the destination to null. Then,
6096 allocate memory to the destination. */
6097 gfc_init_block (&block);
6101 tmp = null_pointer_node;
6102 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6103 gfc_add_expr_to_block (&block, tmp);
6104 null_data = gfc_finish_block (&block);
6106 gfc_init_block (&block);
6107 size = TYPE_SIZE_UNIT (type);
6110 tmp = gfc_call_malloc (&block, type, size);
6111 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6112 dest, fold_convert (type, tmp));
6113 gfc_add_expr_to_block (&block, tmp);
6116 tmp = built_in_decls[BUILT_IN_MEMCPY];
6117 tmp = build_call_expr_loc (input_location, tmp, 3,
6122 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6123 null_data = gfc_finish_block (&block);
6125 gfc_init_block (&block);
6126 nelems = get_full_array_size (&block, src, rank);
6127 tmp = fold_convert (gfc_array_index_type,
6128 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6129 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6133 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6134 tmp = gfc_call_malloc (&block, tmp, size);
6135 gfc_conv_descriptor_data_set (&block, dest, tmp);
6138 /* We know the temporary and the value will be the same length,
6139 so can use memcpy. */
6140 tmp = built_in_decls[BUILT_IN_MEMCPY];
6141 tmp = build_call_expr_loc (input_location,
6142 tmp, 3, gfc_conv_descriptor_data_get (dest),
6143 gfc_conv_descriptor_data_get (src), size);
6146 gfc_add_expr_to_block (&block, tmp);
6147 tmp = gfc_finish_block (&block);
6149 /* Null the destination if the source is null; otherwise do
6150 the allocate and copy. */
6154 null_cond = gfc_conv_descriptor_data_get (src);
6156 null_cond = convert (pvoid_type_node, null_cond);
6157 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6158 null_cond, null_pointer_node);
6159 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6163 /* Allocate dest to the same size as src, and copy data src -> dest. */
6166 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6168 return duplicate_allocatable (dest, src, type, rank, false);
6172 /* Copy data src -> dest. */
6175 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6177 return duplicate_allocatable (dest, src, type, rank, true);
6181 /* Recursively traverse an object of derived type, generating code to
6182 deallocate, nullify or copy allocatable components. This is the work horse
6183 function for the functions named in this enum. */
6185 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6186 COPY_ONLY_ALLOC_COMP};
6189 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6190 tree dest, int rank, int purpose)
6194 stmtblock_t fnblock;
6195 stmtblock_t loopbody;
6206 tree null_cond = NULL_TREE;
6208 gfc_init_block (&fnblock);
6210 decl_type = TREE_TYPE (decl);
6212 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6213 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6215 decl = build_fold_indirect_ref_loc (input_location,
6218 /* Just in case in gets dereferenced. */
6219 decl_type = TREE_TYPE (decl);
6221 /* If this an array of derived types with allocatable components
6222 build a loop and recursively call this function. */
6223 if (TREE_CODE (decl_type) == ARRAY_TYPE
6224 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6226 tmp = gfc_conv_array_data (decl);
6227 var = build_fold_indirect_ref_loc (input_location,
6230 /* Get the number of elements - 1 and set the counter. */
6231 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6233 /* Use the descriptor for an allocatable array. Since this
6234 is a full array reference, we only need the descriptor
6235 information from dimension = rank. */
6236 tmp = get_full_array_size (&fnblock, decl, rank);
6237 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6238 gfc_array_index_type, tmp,
6239 gfc_index_one_node);
6241 null_cond = gfc_conv_descriptor_data_get (decl);
6242 null_cond = fold_build2_loc (input_location, NE_EXPR,
6243 boolean_type_node, null_cond,
6244 build_int_cst (TREE_TYPE (null_cond), 0));
6248 /* Otherwise use the TYPE_DOMAIN information. */
6249 tmp = array_type_nelts (decl_type);
6250 tmp = fold_convert (gfc_array_index_type, tmp);
6253 /* Remember that this is, in fact, the no. of elements - 1. */
6254 nelems = gfc_evaluate_now (tmp, &fnblock);
6255 index = gfc_create_var (gfc_array_index_type, "S");
6257 /* Build the body of the loop. */
6258 gfc_init_block (&loopbody);
6260 vref = gfc_build_array_ref (var, index, NULL);
6262 if (purpose == COPY_ALLOC_COMP)
6264 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6266 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6267 gfc_add_expr_to_block (&fnblock, tmp);
6269 tmp = build_fold_indirect_ref_loc (input_location,
6270 gfc_conv_array_data (dest));
6271 dref = gfc_build_array_ref (tmp, index, NULL);
6272 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6274 else if (purpose == COPY_ONLY_ALLOC_COMP)
6276 tmp = build_fold_indirect_ref_loc (input_location,
6277 gfc_conv_array_data (dest));
6278 dref = gfc_build_array_ref (tmp, index, NULL);
6279 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6283 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6285 gfc_add_expr_to_block (&loopbody, tmp);
6287 /* Build the loop and return. */
6288 gfc_init_loopinfo (&loop);
6290 loop.from[0] = gfc_index_zero_node;
6291 loop.loopvar[0] = index;
6292 loop.to[0] = nelems;
6293 gfc_trans_scalarizing_loops (&loop, &loopbody);
6294 gfc_add_block_to_block (&fnblock, &loop.pre);
6296 tmp = gfc_finish_block (&fnblock);
6297 if (null_cond != NULL_TREE)
6298 tmp = build3_v (COND_EXPR, null_cond, tmp,
6299 build_empty_stmt (input_location));
6304 /* Otherwise, act on the components or recursively call self to
6305 act on a chain of components. */
6306 for (c = der_type->components; c; c = c->next)
6308 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6309 && c->ts.u.derived->attr.alloc_comp;
6310 cdecl = c->backend_decl;
6311 ctype = TREE_TYPE (cdecl);
6315 case DEALLOCATE_ALLOC_COMP:
6316 /* Do not deallocate the components of ultimate pointer
6318 if (cmp_has_alloc_comps && !c->attr.pointer)
6320 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6321 decl, cdecl, NULL_TREE);
6322 rank = c->as ? c->as->rank : 0;
6323 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6325 gfc_add_expr_to_block (&fnblock, tmp);
6328 if (c->attr.allocatable && c->attr.dimension)
6330 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6331 decl, cdecl, NULL_TREE);
6332 tmp = gfc_trans_dealloc_allocated (comp);
6333 gfc_add_expr_to_block (&fnblock, tmp);
6335 else if (c->attr.allocatable)
6337 /* Allocatable scalar components. */
6338 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6339 decl, cdecl, NULL_TREE);
6341 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6342 gfc_add_expr_to_block (&fnblock, tmp);
6344 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6345 void_type_node, comp,
6346 build_int_cst (TREE_TYPE (comp), 0));
6347 gfc_add_expr_to_block (&fnblock, tmp);
6349 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6351 /* Allocatable scalar CLASS components. */
6352 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6353 decl, cdecl, NULL_TREE);
6355 /* Add reference to '$data' component. */
6356 tmp = CLASS_DATA (c)->backend_decl;
6357 comp = fold_build3_loc (input_location, COMPONENT_REF,
6358 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6360 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6361 gfc_add_expr_to_block (&fnblock, tmp);
6363 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6364 void_type_node, comp,
6365 build_int_cst (TREE_TYPE (comp), 0));
6366 gfc_add_expr_to_block (&fnblock, tmp);
6370 case NULLIFY_ALLOC_COMP:
6371 if (c->attr.pointer)
6373 else if (c->attr.allocatable && c->attr.dimension)
6375 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6376 decl, cdecl, NULL_TREE);
6377 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6379 else if (c->attr.allocatable)
6381 /* Allocatable scalar components. */
6382 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6383 decl, cdecl, NULL_TREE);
6384 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6385 void_type_node, comp,
6386 build_int_cst (TREE_TYPE (comp), 0));
6387 gfc_add_expr_to_block (&fnblock, tmp);
6389 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6391 /* Allocatable scalar CLASS components. */
6392 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6393 decl, cdecl, NULL_TREE);
6394 /* Add reference to '$data' component. */
6395 tmp = CLASS_DATA (c)->backend_decl;
6396 comp = fold_build3_loc (input_location, COMPONENT_REF,
6397 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6398 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6399 void_type_node, comp,
6400 build_int_cst (TREE_TYPE (comp), 0));
6401 gfc_add_expr_to_block (&fnblock, tmp);
6403 else if (cmp_has_alloc_comps)
6405 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6406 decl, cdecl, NULL_TREE);
6407 rank = c->as ? c->as->rank : 0;
6408 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6410 gfc_add_expr_to_block (&fnblock, tmp);
6414 case COPY_ALLOC_COMP:
6415 if (c->attr.pointer)
6418 /* We need source and destination components. */
6419 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6421 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6423 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6425 if (c->attr.allocatable && !cmp_has_alloc_comps)
6427 rank = c->as ? c->as->rank : 0;
6428 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6429 gfc_add_expr_to_block (&fnblock, tmp);
6432 if (cmp_has_alloc_comps)
6434 rank = c->as ? c->as->rank : 0;
6435 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6436 gfc_add_modify (&fnblock, dcmp, tmp);
6437 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6439 gfc_add_expr_to_block (&fnblock, tmp);
6449 return gfc_finish_block (&fnblock);
6452 /* Recursively traverse an object of derived type, generating code to
6453 nullify allocatable components. */
6456 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6458 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6459 NULLIFY_ALLOC_COMP);
6463 /* Recursively traverse an object of derived type, generating code to
6464 deallocate allocatable components. */
6467 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6469 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6470 DEALLOCATE_ALLOC_COMP);
6474 /* Recursively traverse an object of derived type, generating code to
6475 copy it and its allocatable components. */
6478 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6480 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6484 /* Recursively traverse an object of derived type, generating code to
6485 copy only its allocatable components. */
6488 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6490 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6494 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6495 Do likewise, recursively if necessary, with the allocatable components of
6499 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
6505 stmtblock_t cleanup;
6508 bool sym_has_alloc_comp;
6510 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6511 && sym->ts.u.derived->attr.alloc_comp;
6513 /* Make sure the frontend gets these right. */
6514 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6515 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6516 "allocatable attribute or derived type without allocatable "
6519 gfc_init_block (&init);
6521 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6522 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6524 if (sym->ts.type == BT_CHARACTER
6525 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6527 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6528 gfc_trans_vla_type_sizes (sym, &init);
6531 /* Dummy, use associated and result variables don't need anything special. */
6532 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6534 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6538 gfc_get_backend_locus (&loc);
6539 gfc_set_backend_locus (&sym->declared_at);
6540 descriptor = sym->backend_decl;
6542 /* Although static, derived types with default initializers and
6543 allocatable components must not be nulled wholesale; instead they
6544 are treated component by component. */
6545 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6547 /* SAVEd variables are not freed on exit. */
6548 gfc_trans_static_array_pointer (sym);
6550 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6554 /* Get the descriptor type. */
6555 type = TREE_TYPE (sym->backend_decl);
6557 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6560 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6562 if (sym->value == NULL
6563 || !gfc_has_default_initializer (sym->ts.u.derived))
6565 rank = sym->as ? sym->as->rank : 0;
6566 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
6568 gfc_add_expr_to_block (&init, tmp);
6571 gfc_init_default_dt (sym, &init, false);
6574 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6576 /* If the backend_decl is not a descriptor, we must have a pointer
6578 descriptor = build_fold_indirect_ref_loc (input_location,
6580 type = TREE_TYPE (descriptor);
6583 /* NULLIFY the data pointer. */
6584 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6585 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
6587 gfc_init_block (&cleanup);
6588 gfc_set_backend_locus (&loc);
6590 /* Allocatable arrays need to be freed when they go out of scope.
6591 The allocatable components of pointers must not be touched. */
6592 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6593 && !sym->attr.pointer && !sym->attr.save)
6596 rank = sym->as ? sym->as->rank : 0;
6597 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6598 gfc_add_expr_to_block (&cleanup, tmp);
6601 if (sym->attr.allocatable && sym->attr.dimension
6602 && !sym->attr.save && !sym->attr.result)
6604 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6605 gfc_add_expr_to_block (&cleanup, tmp);
6608 gfc_add_init_cleanup (block, gfc_finish_block (&init),
6609 gfc_finish_block (&cleanup));
6612 /************ Expression Walking Functions ******************/
6614 /* Walk a variable reference.
6616 Possible extension - multiple component subscripts.
6617 x(:,:) = foo%a(:)%b(:)
6619 forall (i=..., j=...)
6620 x(i,j) = foo%a(j)%b(i)
6622 This adds a fair amount of complexity because you need to deal with more
6623 than one ref. Maybe handle in a similar manner to vector subscripts.
6624 Maybe not worth the effort. */
6628 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6635 for (ref = expr->ref; ref; ref = ref->next)
6636 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6639 for (; ref; ref = ref->next)
6641 if (ref->type == REF_SUBSTRING)
6643 newss = gfc_get_ss ();
6644 newss->type = GFC_SS_SCALAR;
6645 newss->expr = ref->u.ss.start;
6649 newss = gfc_get_ss ();
6650 newss->type = GFC_SS_SCALAR;
6651 newss->expr = ref->u.ss.end;
6656 /* We're only interested in array sections from now on. */
6657 if (ref->type != REF_ARRAY)
6662 if (ar->as->rank == 0)
6664 /* Scalar coarray. */
6671 for (n = 0; n < ar->dimen; n++)
6673 newss = gfc_get_ss ();
6674 newss->type = GFC_SS_SCALAR;
6675 newss->expr = ar->start[n];
6682 newss = gfc_get_ss ();
6683 newss->type = GFC_SS_SECTION;
6686 newss->data.info.dimen = ar->as->rank;
6687 newss->data.info.ref = ref;
6689 /* Make sure array is the same as array(:,:), this way
6690 we don't need to special case all the time. */
6691 ar->dimen = ar->as->rank;
6692 for (n = 0; n < ar->dimen; n++)
6694 newss->data.info.dim[n] = n;
6695 ar->dimen_type[n] = DIMEN_RANGE;
6697 gcc_assert (ar->start[n] == NULL);
6698 gcc_assert (ar->end[n] == NULL);
6699 gcc_assert (ar->stride[n] == NULL);
6705 newss = gfc_get_ss ();
6706 newss->type = GFC_SS_SECTION;
6709 newss->data.info.dimen = 0;
6710 newss->data.info.ref = ref;
6712 /* We add SS chains for all the subscripts in the section. */
6713 for (n = 0; n < ar->dimen; n++)
6717 switch (ar->dimen_type[n])
6720 /* Add SS for elemental (scalar) subscripts. */
6721 gcc_assert (ar->start[n]);
6722 indexss = gfc_get_ss ();
6723 indexss->type = GFC_SS_SCALAR;
6724 indexss->expr = ar->start[n];
6725 indexss->next = gfc_ss_terminator;
6726 indexss->loop_chain = gfc_ss_terminator;
6727 newss->data.info.subscript[n] = indexss;
6731 /* We don't add anything for sections, just remember this
6732 dimension for later. */
6733 newss->data.info.dim[newss->data.info.dimen] = n;
6734 newss->data.info.dimen++;
6738 /* Create a GFC_SS_VECTOR index in which we can store
6739 the vector's descriptor. */
6740 indexss = gfc_get_ss ();
6741 indexss->type = GFC_SS_VECTOR;
6742 indexss->expr = ar->start[n];
6743 indexss->next = gfc_ss_terminator;
6744 indexss->loop_chain = gfc_ss_terminator;
6745 newss->data.info.subscript[n] = indexss;
6746 newss->data.info.dim[newss->data.info.dimen] = n;
6747 newss->data.info.dimen++;
6751 /* We should know what sort of section it is by now. */
6755 /* We should have at least one non-elemental dimension. */
6756 gcc_assert (newss->data.info.dimen > 0);
6761 /* We should know what sort of section it is by now. */
6770 /* Walk an expression operator. If only one operand of a binary expression is
6771 scalar, we must also add the scalar term to the SS chain. */
6774 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6780 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6781 if (expr->value.op.op2 == NULL)
6784 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6786 /* All operands are scalar. Pass back and let the caller deal with it. */
6790 /* All operands require scalarization. */
6791 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6794 /* One of the operands needs scalarization, the other is scalar.
6795 Create a gfc_ss for the scalar expression. */
6796 newss = gfc_get_ss ();
6797 newss->type = GFC_SS_SCALAR;
6800 /* First operand is scalar. We build the chain in reverse order, so
6801 add the scalar SS after the second operand. */
6803 while (head && head->next != ss)
6805 /* Check we haven't somehow broken the chain. */
6809 newss->expr = expr->value.op.op1;
6811 else /* head2 == head */
6813 gcc_assert (head2 == head);
6814 /* Second operand is scalar. */
6815 newss->next = head2;
6817 newss->expr = expr->value.op.op2;
6824 /* Reverse a SS chain. */
6827 gfc_reverse_ss (gfc_ss * ss)
6832 gcc_assert (ss != NULL);
6834 head = gfc_ss_terminator;
6835 while (ss != gfc_ss_terminator)
6838 /* Check we didn't somehow break the chain. */
6839 gcc_assert (next != NULL);
6849 /* Walk the arguments of an elemental function. */
6852 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6860 head = gfc_ss_terminator;
6863 for (; arg; arg = arg->next)
6868 newss = gfc_walk_subexpr (head, arg->expr);
6871 /* Scalar argument. */
6872 newss = gfc_get_ss ();
6874 newss->expr = arg->expr;
6884 while (tail->next != gfc_ss_terminator)
6891 /* If all the arguments are scalar we don't need the argument SS. */
6892 gfc_free_ss_chain (head);
6897 /* Add it onto the existing chain. */
6903 /* Walk a function call. Scalar functions are passed back, and taken out of
6904 scalarization loops. For elemental functions we walk their arguments.
6905 The result of functions returning arrays is stored in a temporary outside
6906 the loop, so that the function is only called once. Hence we do not need
6907 to walk their arguments. */
6910 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6913 gfc_intrinsic_sym *isym;
6915 gfc_component *comp = NULL;
6918 isym = expr->value.function.isym;
6920 /* Handle intrinsic functions separately. */
6922 return gfc_walk_intrinsic_function (ss, expr, isym);
6924 sym = expr->value.function.esym;
6926 sym = expr->symtree->n.sym;
6928 /* A function that returns arrays. */
6929 gfc_is_proc_ptr_comp (expr, &comp);
6930 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6931 || (comp && comp->attr.dimension))
6933 newss = gfc_get_ss ();
6934 newss->type = GFC_SS_FUNCTION;
6937 newss->data.info.dimen = expr->rank;
6938 for (n = 0; n < newss->data.info.dimen; n++)
6939 newss->data.info.dim[n] = n;
6943 /* Walk the parameters of an elemental function. For now we always pass
6945 if (sym->attr.elemental)
6946 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6949 /* Scalar functions are OK as these are evaluated outside the scalarization
6950 loop. Pass back and let the caller deal with it. */
6955 /* An array temporary is constructed for array constructors. */
6958 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6963 newss = gfc_get_ss ();
6964 newss->type = GFC_SS_CONSTRUCTOR;
6967 newss->data.info.dimen = expr->rank;
6968 for (n = 0; n < expr->rank; n++)
6969 newss->data.info.dim[n] = n;
6975 /* Walk an expression. Add walked expressions to the head of the SS chain.
6976 A wholly scalar expression will not be added. */
6979 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6983 switch (expr->expr_type)
6986 head = gfc_walk_variable_expr (ss, expr);
6990 head = gfc_walk_op_expr (ss, expr);
6994 head = gfc_walk_function_expr (ss, expr);
6999 case EXPR_STRUCTURE:
7000 /* Pass back and let the caller deal with it. */
7004 head = gfc_walk_array_constructor (ss, expr);
7007 case EXPR_SUBSTRING:
7008 /* Pass back and let the caller deal with it. */
7012 internal_error ("bad expression type during walk (%d)",
7019 /* Entry point for expression walking.
7020 A return value equal to the passed chain means this is
7021 a scalar expression. It is up to the caller to take whatever action is
7022 necessary to translate these. */
7025 gfc_walk_expr (gfc_expr * expr)
7029 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7030 return gfc_reverse_ss (res);