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 (LE_EXPR, boolean_type_node,
2948 loop->loopvar[n], loop->to[n]);
2949 OMP_FOR_COND (stmt) = cond;
2950 /* Increment the loopvar. */
2951 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2952 loop->loopvar[n], gfc_index_one_node);
2953 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2954 void_type_node, loop->loopvar[n], tmp);
2955 OMP_FOR_INCR (stmt) = incr;
2957 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2958 gfc_add_expr_to_block (&loop->code[n], stmt);
2962 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2963 && (loop->temp_ss == NULL);
2965 loopbody = gfc_finish_block (pbody);
2969 tmp = loop->from[n];
2970 loop->from[n] = loop->to[n];
2974 /* Initialize the loopvar. */
2975 if (loop->loopvar[n] != loop->from[n])
2976 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2978 exit_label = gfc_build_label_decl (NULL_TREE);
2980 /* Generate the loop body. */
2981 gfc_init_block (&block);
2983 /* The exit condition. */
2984 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2985 boolean_type_node, loop->loopvar[n], loop->to[n]);
2986 tmp = build1_v (GOTO_EXPR, exit_label);
2987 TREE_USED (exit_label) = 1;
2988 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2989 gfc_add_expr_to_block (&block, tmp);
2991 /* The main body. */
2992 gfc_add_expr_to_block (&block, loopbody);
2994 /* Increment the loopvar. */
2995 tmp = fold_build2_loc (input_location,
2996 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2997 gfc_array_index_type, loop->loopvar[n],
2998 gfc_index_one_node);
3000 gfc_add_modify (&block, loop->loopvar[n], tmp);
3002 /* Build the loop. */
3003 tmp = gfc_finish_block (&block);
3004 tmp = build1_v (LOOP_EXPR, tmp);
3005 gfc_add_expr_to_block (&loop->code[n], tmp);
3007 /* Add the exit label. */
3008 tmp = build1_v (LABEL_EXPR, exit_label);
3009 gfc_add_expr_to_block (&loop->code[n], tmp);
3015 /* Finishes and generates the loops for a scalarized expression. */
3018 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3023 stmtblock_t *pblock;
3027 /* Generate the loops. */
3028 for (dim = 0; dim < loop->dimen; dim++)
3030 n = loop->order[dim];
3031 gfc_trans_scalarized_loop_end (loop, n, pblock);
3032 loop->loopvar[n] = NULL_TREE;
3033 pblock = &loop->code[n];
3036 tmp = gfc_finish_block (pblock);
3037 gfc_add_expr_to_block (&loop->pre, tmp);
3039 /* Clear all the used flags. */
3040 for (ss = loop->ss; ss; ss = ss->loop_chain)
3045 /* Finish the main body of a scalarized expression, and start the secondary
3049 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3053 stmtblock_t *pblock;
3057 /* We finish as many loops as are used by the temporary. */
3058 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3060 n = loop->order[dim];
3061 gfc_trans_scalarized_loop_end (loop, n, pblock);
3062 loop->loopvar[n] = NULL_TREE;
3063 pblock = &loop->code[n];
3066 /* We don't want to finish the outermost loop entirely. */
3067 n = loop->order[loop->temp_dim - 1];
3068 gfc_trans_scalarized_loop_end (loop, n, pblock);
3070 /* Restore the initial offsets. */
3071 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3073 if ((ss->useflags & 2) == 0)
3076 if (ss->type != GFC_SS_SECTION
3077 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3078 && ss->type != GFC_SS_COMPONENT)
3081 ss->data.info.offset = ss->data.info.saved_offset;
3084 /* Restart all the inner loops we just finished. */
3085 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3087 n = loop->order[dim];
3089 gfc_start_block (&loop->code[n]);
3091 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3093 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3096 /* Start a block for the secondary copying code. */
3097 gfc_start_block (body);
3101 /* Calculate the lower bound of an array section. */
3104 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3113 gcc_assert (ss->type == GFC_SS_SECTION);
3115 info = &ss->data.info;
3117 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3119 /* We use a zero-based index to access the vector. */
3120 info->start[dim] = gfc_index_zero_node;
3121 info->stride[dim] = gfc_index_one_node;
3122 info->end[dim] = NULL;
3126 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3127 desc = info->descriptor;
3128 start = info->ref->u.ar.start[dim];
3129 end = info->ref->u.ar.end[dim];
3130 stride = info->ref->u.ar.stride[dim];
3132 /* Calculate the start of the range. For vector subscripts this will
3133 be the range of the vector. */
3136 /* Specified section start. */
3137 gfc_init_se (&se, NULL);
3138 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3139 gfc_add_block_to_block (&loop->pre, &se.pre);
3140 info->start[dim] = se.expr;
3144 /* No lower bound specified so use the bound of the array. */
3145 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3147 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3149 /* Similarly calculate the end. Although this is not used in the
3150 scalarizer, it is needed when checking bounds and where the end
3151 is an expression with side-effects. */
3154 /* Specified section start. */
3155 gfc_init_se (&se, NULL);
3156 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3157 gfc_add_block_to_block (&loop->pre, &se.pre);
3158 info->end[dim] = se.expr;
3162 /* No upper bound specified so use the bound of the array. */
3163 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3165 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3167 /* Calculate the stride. */
3169 info->stride[dim] = gfc_index_one_node;
3172 gfc_init_se (&se, NULL);
3173 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3174 gfc_add_block_to_block (&loop->pre, &se.pre);
3175 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3180 /* Calculates the range start and stride for a SS chain. Also gets the
3181 descriptor and data pointer. The range of vector subscripts is the size
3182 of the vector. Array bounds are also checked. */
3185 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3193 /* Determine the rank of the loop. */
3195 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3199 case GFC_SS_SECTION:
3200 case GFC_SS_CONSTRUCTOR:
3201 case GFC_SS_FUNCTION:
3202 case GFC_SS_COMPONENT:
3203 loop->dimen = ss->data.info.dimen;
3206 /* As usual, lbound and ubound are exceptions!. */
3207 case GFC_SS_INTRINSIC:
3208 switch (ss->expr->value.function.isym->id)
3210 case GFC_ISYM_LBOUND:
3211 case GFC_ISYM_UBOUND:
3212 loop->dimen = ss->data.info.dimen;
3223 /* We should have determined the rank of the expression by now. If
3224 not, that's bad news. */
3225 gcc_assert (loop->dimen != 0);
3227 /* Loop over all the SS in the chain. */
3228 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3230 if (ss->expr && ss->expr->shape && !ss->shape)
3231 ss->shape = ss->expr->shape;
3235 case GFC_SS_SECTION:
3236 /* Get the descriptor for the array. */
3237 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3239 for (n = 0; n < ss->data.info.dimen; n++)
3240 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
3243 case GFC_SS_INTRINSIC:
3244 switch (ss->expr->value.function.isym->id)
3246 /* Fall through to supply start and stride. */
3247 case GFC_ISYM_LBOUND:
3248 case GFC_ISYM_UBOUND:
3254 case GFC_SS_CONSTRUCTOR:
3255 case GFC_SS_FUNCTION:
3256 for (n = 0; n < ss->data.info.dimen; n++)
3258 ss->data.info.start[n] = gfc_index_zero_node;
3259 ss->data.info.end[n] = gfc_index_zero_node;
3260 ss->data.info.stride[n] = gfc_index_one_node;
3269 /* The rest is just runtime bound checking. */
3270 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3273 tree lbound, ubound;
3275 tree size[GFC_MAX_DIMENSIONS];
3276 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3281 gfc_start_block (&block);
3283 for (n = 0; n < loop->dimen; n++)
3284 size[n] = NULL_TREE;
3286 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3290 if (ss->type != GFC_SS_SECTION)
3293 gfc_start_block (&inner);
3295 /* TODO: range checking for mapped dimensions. */
3296 info = &ss->data.info;
3298 /* This code only checks ranges. Elemental and vector
3299 dimensions are checked later. */
3300 for (n = 0; n < loop->dimen; n++)
3305 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3308 if (dim == info->ref->u.ar.dimen - 1
3309 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3310 check_upper = false;
3314 /* Zero stride is not allowed. */
3315 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3316 info->stride[dim], gfc_index_zero_node);
3317 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3318 "of array '%s'", dim + 1, ss->expr->symtree->name);
3319 gfc_trans_runtime_check (true, false, tmp, &inner,
3320 &ss->expr->where, msg);
3323 desc = ss->data.info.descriptor;
3325 /* This is the run-time equivalent of resolve.c's
3326 check_dimension(). The logical is more readable there
3327 than it is here, with all the trees. */
3328 lbound = gfc_conv_array_lbound (desc, dim);
3329 end = info->end[dim];
3331 ubound = gfc_conv_array_ubound (desc, dim);
3335 /* non_zerosized is true when the selected range is not
3337 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3338 boolean_type_node, info->stride[dim],
3339 gfc_index_zero_node);
3340 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3341 info->start[dim], end);
3342 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3343 boolean_type_node, stride_pos, tmp);
3345 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3347 info->stride[dim], gfc_index_zero_node);
3348 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3349 info->start[dim], end);
3350 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3353 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3355 stride_pos, stride_neg);
3357 /* Check the start of the range against the lower and upper
3358 bounds of the array, if the range is not empty.
3359 If upper bound is present, include both bounds in the
3363 tmp = fold_build2_loc (input_location, LT_EXPR,
3365 info->start[dim], lbound);
3366 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3368 non_zerosized, tmp);
3369 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3371 info->start[dim], ubound);
3372 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3374 non_zerosized, tmp2);
3375 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3376 "outside of expected range (%%ld:%%ld)",
3377 dim + 1, ss->expr->symtree->name);
3378 gfc_trans_runtime_check (true, false, tmp, &inner,
3379 &ss->expr->where, msg,
3380 fold_convert (long_integer_type_node, info->start[dim]),
3381 fold_convert (long_integer_type_node, lbound),
3382 fold_convert (long_integer_type_node, ubound));
3383 gfc_trans_runtime_check (true, false, tmp2, &inner,
3384 &ss->expr->where, msg,
3385 fold_convert (long_integer_type_node, info->start[dim]),
3386 fold_convert (long_integer_type_node, lbound),
3387 fold_convert (long_integer_type_node, ubound));
3392 tmp = fold_build2_loc (input_location, LT_EXPR,
3394 info->start[dim], lbound);
3395 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3396 boolean_type_node, non_zerosized, tmp);
3397 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3398 "below lower bound of %%ld",
3399 dim + 1, ss->expr->symtree->name);
3400 gfc_trans_runtime_check (true, false, tmp, &inner,
3401 &ss->expr->where, msg,
3402 fold_convert (long_integer_type_node, info->start[dim]),
3403 fold_convert (long_integer_type_node, lbound));
3407 /* Compute the last element of the range, which is not
3408 necessarily "end" (think 0:5:3, which doesn't contain 5)
3409 and check it against both lower and upper bounds. */
3411 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3412 gfc_array_index_type, end,
3414 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3415 gfc_array_index_type, tmp,
3417 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3418 gfc_array_index_type, end, tmp);
3419 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3420 boolean_type_node, tmp, lbound);
3421 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3422 boolean_type_node, non_zerosized, tmp2);
3425 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3426 boolean_type_node, tmp, ubound);
3427 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3428 boolean_type_node, non_zerosized, tmp3);
3429 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3430 "outside of expected range (%%ld:%%ld)",
3431 dim + 1, ss->expr->symtree->name);
3432 gfc_trans_runtime_check (true, false, tmp2, &inner,
3433 &ss->expr->where, msg,
3434 fold_convert (long_integer_type_node, tmp),
3435 fold_convert (long_integer_type_node, ubound),
3436 fold_convert (long_integer_type_node, lbound));
3437 gfc_trans_runtime_check (true, false, tmp3, &inner,
3438 &ss->expr->where, msg,
3439 fold_convert (long_integer_type_node, tmp),
3440 fold_convert (long_integer_type_node, ubound),
3441 fold_convert (long_integer_type_node, lbound));
3446 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3447 "below lower bound of %%ld",
3448 dim + 1, ss->expr->symtree->name);
3449 gfc_trans_runtime_check (true, false, tmp2, &inner,
3450 &ss->expr->where, msg,
3451 fold_convert (long_integer_type_node, tmp),
3452 fold_convert (long_integer_type_node, lbound));
3456 /* Check the section sizes match. */
3457 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3458 gfc_array_index_type, end,
3460 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3461 gfc_array_index_type, tmp,
3463 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3464 gfc_array_index_type,
3465 gfc_index_one_node, tmp);
3466 tmp = fold_build2_loc (input_location, MAX_EXPR,
3467 gfc_array_index_type, tmp,
3468 build_int_cst (gfc_array_index_type, 0));
3469 /* We remember the size of the first section, and check all the
3470 others against this. */
3473 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3474 boolean_type_node, tmp, size[n]);
3475 asprintf (&msg, "Array bound mismatch for dimension %d "
3476 "of array '%s' (%%ld/%%ld)",
3477 dim + 1, ss->expr->symtree->name);
3479 gfc_trans_runtime_check (true, false, tmp3, &inner,
3480 &ss->expr->where, msg,
3481 fold_convert (long_integer_type_node, tmp),
3482 fold_convert (long_integer_type_node, size[n]));
3487 size[n] = gfc_evaluate_now (tmp, &inner);
3490 tmp = gfc_finish_block (&inner);
3492 /* For optional arguments, only check bounds if the argument is
3494 if (ss->expr->symtree->n.sym->attr.optional
3495 || ss->expr->symtree->n.sym->attr.not_always_present)
3496 tmp = build3_v (COND_EXPR,
3497 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3498 tmp, build_empty_stmt (input_location));
3500 gfc_add_expr_to_block (&block, tmp);
3504 tmp = gfc_finish_block (&block);
3505 gfc_add_expr_to_block (&loop->pre, tmp);
3510 /* Return true if the two SS could be aliased, i.e. both point to the same data
3512 /* TODO: resolve aliases based on frontend expressions. */
3515 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3522 lsym = lss->expr->symtree->n.sym;
3523 rsym = rss->expr->symtree->n.sym;
3524 if (gfc_symbols_could_alias (lsym, rsym))
3527 if (rsym->ts.type != BT_DERIVED
3528 && lsym->ts.type != BT_DERIVED)
3531 /* For derived types we must check all the component types. We can ignore
3532 array references as these will have the same base type as the previous
3534 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3536 if (lref->type != REF_COMPONENT)
3539 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3542 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3545 if (rref->type != REF_COMPONENT)
3548 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3553 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3555 if (rref->type != REF_COMPONENT)
3558 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3566 /* Resolve array data dependencies. Creates a temporary if required. */
3567 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3571 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3579 loop->temp_ss = NULL;
3581 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3583 if (ss->type != GFC_SS_SECTION)
3586 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3588 if (gfc_could_be_alias (dest, ss)
3589 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3597 lref = dest->expr->ref;
3598 rref = ss->expr->ref;
3600 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3605 /* TODO : loop shifting. */
3608 /* Mark the dimensions for LOOP SHIFTING */
3609 for (n = 0; n < loop->dimen; n++)
3611 int dim = dest->data.info.dim[n];
3613 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3615 else if (! gfc_is_same_range (&lref->u.ar,
3616 &rref->u.ar, dim, 0))
3620 /* Put all the dimensions with dependencies in the
3623 for (n = 0; n < loop->dimen; n++)
3625 gcc_assert (loop->order[n] == n);
3627 loop->order[dim++] = n;
3629 for (n = 0; n < loop->dimen; n++)
3632 loop->order[dim++] = n;
3635 gcc_assert (dim == loop->dimen);
3644 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3645 if (GFC_ARRAY_TYPE_P (base_type)
3646 || GFC_DESCRIPTOR_TYPE_P (base_type))
3647 base_type = gfc_get_element_type (base_type);
3648 loop->temp_ss = gfc_get_ss ();
3649 loop->temp_ss->type = GFC_SS_TEMP;
3650 loop->temp_ss->data.temp.type = base_type;
3651 loop->temp_ss->string_length = dest->string_length;
3652 loop->temp_ss->data.temp.dimen = loop->dimen;
3653 loop->temp_ss->next = gfc_ss_terminator;
3654 gfc_add_ss_to_loop (loop, loop->temp_ss);
3657 loop->temp_ss = NULL;
3661 /* Initialize the scalarization loop. Creates the loop variables. Determines
3662 the range of the loop variables. Creates a temporary if required.
3663 Calculates how to transform from loop variables to array indices for each
3664 expression. Also generates code for scalar expressions which have been
3665 moved outside the loop. */
3668 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3670 int n, dim, spec_dim;
3672 gfc_ss_info *specinfo;
3675 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3676 bool dynamic[GFC_MAX_DIMENSIONS];
3681 for (n = 0; n < loop->dimen; n++)
3685 /* We use one SS term, and use that to determine the bounds of the
3686 loop for this dimension. We try to pick the simplest term. */
3687 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3689 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3692 info = &ss->data.info;
3695 if (loopspec[n] != NULL)
3697 specinfo = &loopspec[n]->data.info;
3698 spec_dim = specinfo->dim[n];
3702 /* Silence unitialized warnings. */
3709 gcc_assert (ss->shape[dim]);
3710 /* The frontend has worked out the size for us. */
3712 || !loopspec[n]->shape
3713 || !integer_zerop (specinfo->start[spec_dim]))
3714 /* Prefer zero-based descriptors if possible. */
3719 if (ss->type == GFC_SS_CONSTRUCTOR)
3721 gfc_constructor_base base;
3722 /* An unknown size constructor will always be rank one.
3723 Higher rank constructors will either have known shape,
3724 or still be wrapped in a call to reshape. */
3725 gcc_assert (loop->dimen == 1);
3727 /* Always prefer to use the constructor bounds if the size
3728 can be determined at compile time. Prefer not to otherwise,
3729 since the general case involves realloc, and it's better to
3730 avoid that overhead if possible. */
3731 base = ss->expr->value.constructor;
3732 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3733 if (!dynamic[n] || !loopspec[n])
3738 /* TODO: Pick the best bound if we have a choice between a
3739 function and something else. */
3740 if (ss->type == GFC_SS_FUNCTION)
3746 if (ss->type != GFC_SS_SECTION)
3751 /* Criteria for choosing a loop specifier (most important first):
3752 doesn't need realloc
3758 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3760 else if (integer_onep (info->stride[dim])
3761 && !integer_onep (specinfo->stride[spec_dim]))
3763 else if (INTEGER_CST_P (info->stride[dim])
3764 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3766 else if (INTEGER_CST_P (info->start[dim])
3767 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3769 /* We don't work out the upper bound.
3770 else if (INTEGER_CST_P (info->finish[n])
3771 && ! INTEGER_CST_P (specinfo->finish[n]))
3772 loopspec[n] = ss; */
3775 /* We should have found the scalarization loop specifier. If not,
3777 gcc_assert (loopspec[n]);
3779 info = &loopspec[n]->data.info;
3782 /* Set the extents of this range. */
3783 cshape = loopspec[n]->shape;
3784 if (cshape && INTEGER_CST_P (info->start[dim])
3785 && INTEGER_CST_P (info->stride[dim]))
3787 loop->from[n] = info->start[dim];
3788 mpz_set (i, cshape[n]);
3789 mpz_sub_ui (i, i, 1);
3790 /* To = from + (size - 1) * stride. */
3791 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3792 if (!integer_onep (info->stride[dim]))
3793 tmp = fold_build2_loc (input_location, MULT_EXPR,
3794 gfc_array_index_type, tmp,
3796 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3797 gfc_array_index_type,
3798 loop->from[n], tmp);
3802 loop->from[n] = info->start[dim];
3803 switch (loopspec[n]->type)
3805 case GFC_SS_CONSTRUCTOR:
3806 /* The upper bound is calculated when we expand the
3808 gcc_assert (loop->to[n] == NULL_TREE);
3811 case GFC_SS_SECTION:
3812 /* Use the end expression if it exists and is not constant,
3813 so that it is only evaluated once. */
3814 loop->to[n] = info->end[dim];
3817 case GFC_SS_FUNCTION:
3818 /* The loop bound will be set when we generate the call. */
3819 gcc_assert (loop->to[n] == NULL_TREE);
3827 /* Transform everything so we have a simple incrementing variable. */
3828 if (integer_onep (info->stride[dim]))
3829 info->delta[dim] = gfc_index_zero_node;
3832 /* Set the delta for this section. */
3833 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3834 /* Number of iterations is (end - start + step) / step.
3835 with start = 0, this simplifies to
3837 for (i = 0; i<=last; i++){...}; */
3838 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3839 gfc_array_index_type, loop->to[n],
3841 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3842 gfc_array_index_type, tmp, info->stride[dim]);
3843 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3844 tmp, build_int_cst (gfc_array_index_type, -1));
3845 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3846 /* Make the loop variable start at 0. */
3847 loop->from[n] = gfc_index_zero_node;
3851 /* Add all the scalar code that can be taken out of the loops.
3852 This may include calculating the loop bounds, so do it before
3853 allocating the temporary. */
3854 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3856 /* If we want a temporary then create it. */
3857 if (loop->temp_ss != NULL)
3859 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3861 /* Make absolutely sure that this is a complete type. */
3862 if (loop->temp_ss->string_length)
3863 loop->temp_ss->data.temp.type
3864 = gfc_get_character_type_len_for_eltype
3865 (TREE_TYPE (loop->temp_ss->data.temp.type),
3866 loop->temp_ss->string_length);
3868 tmp = loop->temp_ss->data.temp.type;
3869 n = loop->temp_ss->data.temp.dimen;
3870 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3871 loop->temp_ss->type = GFC_SS_SECTION;
3872 loop->temp_ss->data.info.dimen = n;
3874 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3875 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3876 loop->temp_ss->data.info.dim[n] = n;
3878 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3879 &loop->temp_ss->data.info, tmp, NULL_TREE,
3880 false, true, false, where);
3883 for (n = 0; n < loop->temp_dim; n++)
3884 loopspec[loop->order[n]] = NULL;
3888 /* For array parameters we don't have loop variables, so don't calculate the
3890 if (loop->array_parameter)
3893 /* Calculate the translation from loop variables to array indices. */
3894 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3896 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3897 && ss->type != GFC_SS_CONSTRUCTOR)
3901 info = &ss->data.info;
3903 for (n = 0; n < info->dimen; n++)
3905 /* If we are specifying the range the delta is already set. */
3906 if (loopspec[n] != ss)
3908 dim = ss->data.info.dim[n];
3910 /* Calculate the offset relative to the loop variable.
3911 First multiply by the stride. */
3912 tmp = loop->from[n];
3913 if (!integer_onep (info->stride[dim]))
3914 tmp = fold_build2_loc (input_location, MULT_EXPR,
3915 gfc_array_index_type,
3916 tmp, info->stride[dim]);
3918 /* Then subtract this from our starting value. */
3919 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3920 gfc_array_index_type,
3921 info->start[dim], tmp);
3923 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
3930 /* Calculate the size of a given array dimension from the bounds. This
3931 is simply (ubound - lbound + 1) if this expression is positive
3932 or 0 if it is negative (pick either one if it is zero). Optionally
3933 (if or_expr is present) OR the (expression != 0) condition to it. */
3936 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
3941 /* Calculate (ubound - lbound + 1). */
3942 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3944 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
3945 gfc_index_one_node);
3947 /* Check whether the size for this dimension is negative. */
3948 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
3949 gfc_index_zero_node);
3950 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
3951 gfc_index_zero_node, res);
3953 /* Build OR expression. */
3955 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3956 boolean_type_node, *or_expr, cond);
3962 /* For an array descriptor, get the total number of elements. This is just
3963 the product of the extents along all dimensions. */
3966 gfc_conv_descriptor_size (tree desc, int rank)
3971 res = gfc_index_one_node;
3973 for (dim = 0; dim < rank; ++dim)
3979 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
3980 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
3982 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
3983 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3991 /* Fills in an array descriptor, and returns the size of the array. The size
3992 will be a simple_val, ie a variable or a constant. Also calculates the
3993 offset of the base. Returns the size of the array.
3997 for (n = 0; n < rank; n++)
3999 a.lbound[n] = specified_lower_bound;
4000 offset = offset + a.lbond[n] * stride;
4002 a.ubound[n] = specified_upper_bound;
4003 a.stride[n] = stride;
4004 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4005 stride = stride * size;
4012 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4013 gfc_expr ** lower, gfc_expr ** upper,
4014 stmtblock_t * pblock)
4025 stmtblock_t thenblock;
4026 stmtblock_t elseblock;
4031 type = TREE_TYPE (descriptor);
4033 stride = gfc_index_one_node;
4034 offset = gfc_index_zero_node;
4036 /* Set the dtype. */
4037 tmp = gfc_conv_descriptor_dtype (descriptor);
4038 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4040 or_expr = boolean_false_node;
4042 for (n = 0; n < rank; n++)
4047 /* We have 3 possibilities for determining the size of the array:
4048 lower == NULL => lbound = 1, ubound = upper[n]
4049 upper[n] = NULL => lbound = 1, ubound = lower[n]
4050 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4053 /* Set lower bound. */
4054 gfc_init_se (&se, NULL);
4056 se.expr = gfc_index_one_node;
4059 gcc_assert (lower[n]);
4062 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4063 gfc_add_block_to_block (pblock, &se.pre);
4067 se.expr = gfc_index_one_node;
4071 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4073 conv_lbound = se.expr;
4075 /* Work out the offset for this component. */
4076 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4078 offset = fold_build2_loc (input_location, MINUS_EXPR,
4079 gfc_array_index_type, offset, tmp);
4081 /* Set upper bound. */
4082 gfc_init_se (&se, NULL);
4083 gcc_assert (ubound);
4084 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4085 gfc_add_block_to_block (pblock, &se.pre);
4087 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4088 gfc_rank_cst[n], se.expr);
4089 conv_ubound = se.expr;
4091 /* Store the stride. */
4092 gfc_conv_descriptor_stride_set (pblock, descriptor,
4093 gfc_rank_cst[n], stride);
4095 /* Calculate size and check whether extent is negative. */
4096 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4098 /* Multiply the stride by the number of elements in this dimension. */
4099 stride = fold_build2_loc (input_location, MULT_EXPR,
4100 gfc_array_index_type, stride, size);
4101 stride = gfc_evaluate_now (stride, pblock);
4104 for (n = rank; n < rank + corank; n++)
4108 /* Set lower bound. */
4109 gfc_init_se (&se, NULL);
4110 if (lower == NULL || lower[n] == NULL)
4112 gcc_assert (n == rank + corank - 1);
4113 se.expr = gfc_index_one_node;
4117 if (ubound || n == rank + corank - 1)
4119 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4120 gfc_add_block_to_block (pblock, &se.pre);
4124 se.expr = gfc_index_one_node;
4128 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4131 if (n < rank + corank - 1)
4133 gfc_init_se (&se, NULL);
4134 gcc_assert (ubound);
4135 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4136 gfc_add_block_to_block (pblock, &se.pre);
4137 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4138 gfc_rank_cst[n], se.expr);
4142 /* The stride is the number of elements in the array, so multiply by the
4143 size of an element to get the total size. */
4144 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4145 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4146 stride, fold_convert (gfc_array_index_type, tmp));
4148 if (poffset != NULL)
4150 offset = gfc_evaluate_now (offset, pblock);
4154 if (integer_zerop (or_expr))
4156 if (integer_onep (or_expr))
4157 return gfc_index_zero_node;
4159 var = gfc_create_var (TREE_TYPE (size), "size");
4160 gfc_start_block (&thenblock);
4161 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
4162 thencase = gfc_finish_block (&thenblock);
4164 gfc_start_block (&elseblock);
4165 gfc_add_modify (&elseblock, var, size);
4166 elsecase = gfc_finish_block (&elseblock);
4168 tmp = gfc_evaluate_now (or_expr, pblock);
4169 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4170 gfc_add_expr_to_block (pblock, tmp);
4176 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4177 the work for an ALLOCATE statement. */
4181 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4189 gfc_ref *ref, *prev_ref = NULL;
4190 bool allocatable_array, coarray;
4194 /* Find the last reference in the chain. */
4195 while (ref && ref->next != NULL)
4197 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4198 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4203 if (ref == NULL || ref->type != REF_ARRAY)
4208 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4209 coarray = expr->symtree->n.sym->attr.codimension;
4213 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4214 coarray = prev_ref->u.c.component->attr.codimension;
4217 /* Return if this is a scalar coarray. */
4218 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4219 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4221 gcc_assert (coarray);
4225 /* Figure out the size of the array. */
4226 switch (ref->u.ar.type)
4232 upper = ref->u.ar.start;
4238 lower = ref->u.ar.start;
4239 upper = ref->u.ar.end;
4243 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4245 lower = ref->u.ar.as->lower;
4246 upper = ref->u.ar.as->upper;
4254 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4255 ref->u.ar.as->corank, &offset, lower, upper,
4258 /* Allocate memory to store the data. */
4259 pointer = gfc_conv_descriptor_data_get (se->expr);
4260 STRIP_NOPS (pointer);
4262 /* The allocate_array variants take the old pointer as first argument. */
4263 if (allocatable_array)
4264 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4266 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4267 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4269 gfc_add_expr_to_block (&se->pre, tmp);
4271 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4273 if (expr->ts.type == BT_DERIVED
4274 && expr->ts.u.derived->attr.alloc_comp)
4276 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4277 ref->u.ar.as->rank);
4278 gfc_add_expr_to_block (&se->pre, tmp);
4285 /* Deallocate an array variable. Also used when an allocated variable goes
4290 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4296 gfc_start_block (&block);
4297 /* Get a pointer to the data. */
4298 var = gfc_conv_descriptor_data_get (descriptor);
4301 /* Parameter is the address of the data component. */
4302 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4303 gfc_add_expr_to_block (&block, tmp);
4305 /* Zero the data pointer. */
4306 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4307 var, build_int_cst (TREE_TYPE (var), 0));
4308 gfc_add_expr_to_block (&block, tmp);
4310 return gfc_finish_block (&block);
4314 /* Create an array constructor from an initialization expression.
4315 We assume the frontend already did any expansions and conversions. */
4318 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4324 unsigned HOST_WIDE_INT lo;
4326 VEC(constructor_elt,gc) *v = NULL;
4328 switch (expr->expr_type)
4331 case EXPR_STRUCTURE:
4332 /* A single scalar or derived type value. Create an array with all
4333 elements equal to that value. */
4334 gfc_init_se (&se, NULL);
4336 if (expr->expr_type == EXPR_CONSTANT)
4337 gfc_conv_constant (&se, expr);
4339 gfc_conv_structure (&se, expr, 1);
4341 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4342 gcc_assert (tmp && INTEGER_CST_P (tmp));
4343 hi = TREE_INT_CST_HIGH (tmp);
4344 lo = TREE_INT_CST_LOW (tmp);
4348 /* This will probably eat buckets of memory for large arrays. */
4349 while (hi != 0 || lo != 0)
4351 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4359 /* Create a vector of all the elements. */
4360 for (c = gfc_constructor_first (expr->value.constructor);
4361 c; c = gfc_constructor_next (c))
4365 /* Problems occur when we get something like
4366 integer :: a(lots) = (/(i, i=1, lots)/) */
4367 gfc_fatal_error ("The number of elements in the array constructor "
4368 "at %L requires an increase of the allowed %d "
4369 "upper limit. See -fmax-array-constructor "
4370 "option", &expr->where,
4371 gfc_option.flag_max_array_constructor);
4374 if (mpz_cmp_si (c->offset, 0) != 0)
4375 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4379 gfc_init_se (&se, NULL);
4380 switch (c->expr->expr_type)
4383 gfc_conv_constant (&se, c->expr);
4384 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4387 case EXPR_STRUCTURE:
4388 gfc_conv_structure (&se, c->expr, 1);
4389 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4394 /* Catch those occasional beasts that do not simplify
4395 for one reason or another, assuming that if they are
4396 standard defying the frontend will catch them. */
4397 gfc_conv_expr (&se, c->expr);
4398 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4405 return gfc_build_null_descriptor (type);
4411 /* Create a constructor from the list of elements. */
4412 tmp = build_constructor (type, v);
4413 TREE_CONSTANT (tmp) = 1;
4418 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4419 returns the size (in elements) of the array. */
4422 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4423 stmtblock_t * pblock)
4438 size = gfc_index_one_node;
4439 offset = gfc_index_zero_node;
4440 for (dim = 0; dim < as->rank; dim++)
4442 /* Evaluate non-constant array bound expressions. */
4443 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4444 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4446 gfc_init_se (&se, NULL);
4447 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4448 gfc_add_block_to_block (pblock, &se.pre);
4449 gfc_add_modify (pblock, lbound, se.expr);
4451 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4452 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4454 gfc_init_se (&se, NULL);
4455 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4456 gfc_add_block_to_block (pblock, &se.pre);
4457 gfc_add_modify (pblock, ubound, se.expr);
4459 /* The offset of this dimension. offset = offset - lbound * stride. */
4460 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4462 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4465 /* The size of this dimension, and the stride of the next. */
4466 if (dim + 1 < as->rank)
4467 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4469 stride = GFC_TYPE_ARRAY_SIZE (type);
4471 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4473 /* Calculate stride = size * (ubound + 1 - lbound). */
4474 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4475 gfc_array_index_type,
4476 gfc_index_one_node, lbound);
4477 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4478 gfc_array_index_type, ubound, tmp);
4479 tmp = fold_build2_loc (input_location, MULT_EXPR,
4480 gfc_array_index_type, size, tmp);
4482 gfc_add_modify (pblock, stride, tmp);
4484 stride = gfc_evaluate_now (tmp, pblock);
4486 /* Make sure that negative size arrays are translated
4487 to being zero size. */
4488 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4489 stride, gfc_index_zero_node);
4490 tmp = fold_build3_loc (input_location, COND_EXPR,
4491 gfc_array_index_type, tmp,
4492 stride, gfc_index_zero_node);
4493 gfc_add_modify (pblock, stride, tmp);
4499 gfc_trans_vla_type_sizes (sym, pblock);
4506 /* Generate code to initialize/allocate an array variable. */
4509 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4510 gfc_wrapped_block * block)
4519 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4521 /* Do nothing for USEd variables. */
4522 if (sym->attr.use_assoc)
4525 type = TREE_TYPE (decl);
4526 gcc_assert (GFC_ARRAY_TYPE_P (type));
4527 onstack = TREE_CODE (type) != POINTER_TYPE;
4529 gfc_start_block (&init);
4531 /* Evaluate character string length. */
4532 if (sym->ts.type == BT_CHARACTER
4533 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4535 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4537 gfc_trans_vla_type_sizes (sym, &init);
4539 /* Emit a DECL_EXPR for this variable, which will cause the
4540 gimplifier to allocate storage, and all that good stuff. */
4541 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4542 gfc_add_expr_to_block (&init, tmp);
4547 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4551 type = TREE_TYPE (type);
4553 gcc_assert (!sym->attr.use_assoc);
4554 gcc_assert (!TREE_STATIC (decl));
4555 gcc_assert (!sym->module);
4557 if (sym->ts.type == BT_CHARACTER
4558 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4559 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4561 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4563 /* Don't actually allocate space for Cray Pointees. */
4564 if (sym->attr.cray_pointee)
4566 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4567 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4569 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4573 /* The size is the number of elements in the array, so multiply by the
4574 size of an element to get the total size. */
4575 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4576 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4577 size, fold_convert (gfc_array_index_type, tmp));
4579 /* Allocate memory to hold the data. */
4580 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4581 gfc_add_modify (&init, decl, tmp);
4583 /* Set offset of the array. */
4584 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4585 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4587 /* Automatic arrays should not have initializers. */
4588 gcc_assert (!sym->value);
4590 /* Free the temporary. */
4591 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4593 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4597 /* Generate entry and exit code for g77 calling convention arrays. */
4600 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4610 gfc_get_backend_locus (&loc);
4611 gfc_set_backend_locus (&sym->declared_at);
4613 /* Descriptor type. */
4614 parm = sym->backend_decl;
4615 type = TREE_TYPE (parm);
4616 gcc_assert (GFC_ARRAY_TYPE_P (type));
4618 gfc_start_block (&init);
4620 if (sym->ts.type == BT_CHARACTER
4621 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4622 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4624 /* Evaluate the bounds of the array. */
4625 gfc_trans_array_bounds (type, sym, &offset, &init);
4627 /* Set the offset. */
4628 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4629 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4631 /* Set the pointer itself if we aren't using the parameter directly. */
4632 if (TREE_CODE (parm) != PARM_DECL)
4634 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4635 gfc_add_modify (&init, parm, tmp);
4637 stmt = gfc_finish_block (&init);
4639 gfc_set_backend_locus (&loc);
4641 /* Add the initialization code to the start of the function. */
4643 if (sym->attr.optional || sym->attr.not_always_present)
4645 tmp = gfc_conv_expr_present (sym);
4646 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4649 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4653 /* Modify the descriptor of an array parameter so that it has the
4654 correct lower bound. Also move the upper bound accordingly.
4655 If the array is not packed, it will be copied into a temporary.
4656 For each dimension we set the new lower and upper bounds. Then we copy the
4657 stride and calculate the offset for this dimension. We also work out
4658 what the stride of a packed array would be, and see it the two match.
4659 If the array need repacking, we set the stride to the values we just
4660 calculated, recalculate the offset and copy the array data.
4661 Code is also added to copy the data back at the end of the function.
4665 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4666 gfc_wrapped_block * block)
4673 tree stmtInit, stmtCleanup;
4680 tree stride, stride2;
4690 /* Do nothing for pointer and allocatable arrays. */
4691 if (sym->attr.pointer || sym->attr.allocatable)
4694 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4696 gfc_trans_g77_array (sym, block);
4700 gfc_get_backend_locus (&loc);
4701 gfc_set_backend_locus (&sym->declared_at);
4703 /* Descriptor type. */
4704 type = TREE_TYPE (tmpdesc);
4705 gcc_assert (GFC_ARRAY_TYPE_P (type));
4706 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4707 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4708 gfc_start_block (&init);
4710 if (sym->ts.type == BT_CHARACTER
4711 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4712 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4714 checkparm = (sym->as->type == AS_EXPLICIT
4715 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4717 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4718 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4720 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4722 /* For non-constant shape arrays we only check if the first dimension
4723 is contiguous. Repacking higher dimensions wouldn't gain us
4724 anything as we still don't know the array stride. */
4725 partial = gfc_create_var (boolean_type_node, "partial");
4726 TREE_USED (partial) = 1;
4727 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4728 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4729 gfc_index_one_node);
4730 gfc_add_modify (&init, partial, tmp);
4733 partial = NULL_TREE;
4735 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4736 here, however I think it does the right thing. */
4739 /* Set the first stride. */
4740 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4741 stride = gfc_evaluate_now (stride, &init);
4743 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4744 stride, gfc_index_zero_node);
4745 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4746 tmp, gfc_index_one_node, stride);
4747 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4748 gfc_add_modify (&init, stride, tmp);
4750 /* Allow the user to disable array repacking. */
4751 stmt_unpacked = NULL_TREE;
4755 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4756 /* A library call to repack the array if necessary. */
4757 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4758 stmt_unpacked = build_call_expr_loc (input_location,
4759 gfor_fndecl_in_pack, 1, tmp);
4761 stride = gfc_index_one_node;
4763 if (gfc_option.warn_array_temp)
4764 gfc_warning ("Creating array temporary at %L", &loc);
4767 /* This is for the case where the array data is used directly without
4768 calling the repack function. */
4769 if (no_repack || partial != NULL_TREE)
4770 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4772 stmt_packed = NULL_TREE;
4774 /* Assign the data pointer. */
4775 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4777 /* Don't repack unknown shape arrays when the first stride is 1. */
4778 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
4779 partial, stmt_packed, stmt_unpacked);
4782 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4783 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
4785 offset = gfc_index_zero_node;
4786 size = gfc_index_one_node;
4788 /* Evaluate the bounds of the array. */
4789 for (n = 0; n < sym->as->rank; n++)
4791 if (checkparm || !sym->as->upper[n])
4793 /* Get the bounds of the actual parameter. */
4794 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4795 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4799 dubound = NULL_TREE;
4800 dlbound = NULL_TREE;
4803 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4804 if (!INTEGER_CST_P (lbound))
4806 gfc_init_se (&se, NULL);
4807 gfc_conv_expr_type (&se, sym->as->lower[n],
4808 gfc_array_index_type);
4809 gfc_add_block_to_block (&init, &se.pre);
4810 gfc_add_modify (&init, lbound, se.expr);
4813 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4814 /* Set the desired upper bound. */
4815 if (sym->as->upper[n])
4817 /* We know what we want the upper bound to be. */
4818 if (!INTEGER_CST_P (ubound))
4820 gfc_init_se (&se, NULL);
4821 gfc_conv_expr_type (&se, sym->as->upper[n],
4822 gfc_array_index_type);
4823 gfc_add_block_to_block (&init, &se.pre);
4824 gfc_add_modify (&init, ubound, se.expr);
4827 /* Check the sizes match. */
4830 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4834 temp = fold_build2_loc (input_location, MINUS_EXPR,
4835 gfc_array_index_type, ubound, lbound);
4836 temp = fold_build2_loc (input_location, PLUS_EXPR,
4837 gfc_array_index_type,
4838 gfc_index_one_node, temp);
4839 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
4840 gfc_array_index_type, dubound,
4842 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
4843 gfc_array_index_type,
4844 gfc_index_one_node, stride2);
4845 tmp = fold_build2_loc (input_location, NE_EXPR,
4846 gfc_array_index_type, temp, stride2);
4847 asprintf (&msg, "Dimension %d of array '%s' has extent "
4848 "%%ld instead of %%ld", n+1, sym->name);
4850 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
4851 fold_convert (long_integer_type_node, temp),
4852 fold_convert (long_integer_type_node, stride2));
4859 /* For assumed shape arrays move the upper bound by the same amount
4860 as the lower bound. */
4861 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4862 gfc_array_index_type, dubound, dlbound);
4863 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4864 gfc_array_index_type, tmp, lbound);
4865 gfc_add_modify (&init, ubound, tmp);
4867 /* The offset of this dimension. offset = offset - lbound * stride. */
4868 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4870 offset = fold_build2_loc (input_location, MINUS_EXPR,
4871 gfc_array_index_type, offset, tmp);
4873 /* The size of this dimension, and the stride of the next. */
4874 if (n + 1 < sym->as->rank)
4876 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4878 if (no_repack || partial != NULL_TREE)
4880 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4882 /* Figure out the stride if not a known constant. */
4883 if (!INTEGER_CST_P (stride))
4886 stmt_packed = NULL_TREE;
4889 /* Calculate stride = size * (ubound + 1 - lbound). */
4890 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4891 gfc_array_index_type,
4892 gfc_index_one_node, lbound);
4893 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4894 gfc_array_index_type, ubound, tmp);
4895 size = fold_build2_loc (input_location, MULT_EXPR,
4896 gfc_array_index_type, size, tmp);
4900 /* Assign the stride. */
4901 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4902 tmp = fold_build3_loc (input_location, COND_EXPR,
4903 gfc_array_index_type, partial,
4904 stmt_unpacked, stmt_packed);
4906 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4907 gfc_add_modify (&init, stride, tmp);
4912 stride = GFC_TYPE_ARRAY_SIZE (type);
4914 if (stride && !INTEGER_CST_P (stride))
4916 /* Calculate size = stride * (ubound + 1 - lbound). */
4917 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4918 gfc_array_index_type,
4919 gfc_index_one_node, lbound);
4920 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4921 gfc_array_index_type,
4923 tmp = fold_build2_loc (input_location, MULT_EXPR,
4924 gfc_array_index_type,
4925 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4926 gfc_add_modify (&init, stride, tmp);
4931 /* Set the offset. */
4932 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4933 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4935 gfc_trans_vla_type_sizes (sym, &init);
4937 stmtInit = gfc_finish_block (&init);
4939 /* Only do the entry/initialization code if the arg is present. */
4940 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4941 optional_arg = (sym->attr.optional
4942 || (sym->ns->proc_name->attr.entry_master
4943 && sym->attr.dummy));
4946 tmp = gfc_conv_expr_present (sym);
4947 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
4948 build_empty_stmt (input_location));
4953 stmtCleanup = NULL_TREE;
4956 stmtblock_t cleanup;
4957 gfc_start_block (&cleanup);
4959 if (sym->attr.intent != INTENT_IN)
4961 /* Copy the data back. */
4962 tmp = build_call_expr_loc (input_location,
4963 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4964 gfc_add_expr_to_block (&cleanup, tmp);
4967 /* Free the temporary. */
4968 tmp = gfc_call_free (tmpdesc);
4969 gfc_add_expr_to_block (&cleanup, tmp);
4971 stmtCleanup = gfc_finish_block (&cleanup);
4973 /* Only do the cleanup if the array was repacked. */
4974 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
4975 tmp = gfc_conv_descriptor_data_get (tmp);
4976 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4978 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4979 build_empty_stmt (input_location));
4983 tmp = gfc_conv_expr_present (sym);
4984 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4985 build_empty_stmt (input_location));
4989 /* We don't need to free any memory allocated by internal_pack as it will
4990 be freed at the end of the function by pop_context. */
4991 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
4995 /* Calculate the overall offset, including subreferences. */
4997 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4998 bool subref, gfc_expr *expr)
5008 /* If offset is NULL and this is not a subreferenced array, there is
5010 if (offset == NULL_TREE)
5013 offset = gfc_index_zero_node;
5018 tmp = gfc_conv_array_data (desc);
5019 tmp = build_fold_indirect_ref_loc (input_location,
5021 tmp = gfc_build_array_ref (tmp, offset, NULL);
5023 /* Offset the data pointer for pointer assignments from arrays with
5024 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5027 /* Go past the array reference. */
5028 for (ref = expr->ref; ref; ref = ref->next)
5029 if (ref->type == REF_ARRAY &&
5030 ref->u.ar.type != AR_ELEMENT)
5036 /* Calculate the offset for each subsequent subreference. */
5037 for (; ref; ref = ref->next)
5042 field = ref->u.c.component->backend_decl;
5043 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5044 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5046 tmp, field, NULL_TREE);
5050 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5051 gfc_init_se (&start, NULL);
5052 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5053 gfc_add_block_to_block (block, &start.pre);
5054 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5058 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5059 && ref->u.ar.type == AR_ELEMENT);
5061 /* TODO - Add bounds checking. */
5062 stride = gfc_index_one_node;
5063 index = gfc_index_zero_node;
5064 for (n = 0; n < ref->u.ar.dimen; n++)
5069 /* Update the index. */
5070 gfc_init_se (&start, NULL);
5071 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5072 itmp = gfc_evaluate_now (start.expr, block);
5073 gfc_init_se (&start, NULL);
5074 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5075 jtmp = gfc_evaluate_now (start.expr, block);
5076 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5077 gfc_array_index_type, itmp, jtmp);
5078 itmp = fold_build2_loc (input_location, MULT_EXPR,
5079 gfc_array_index_type, itmp, stride);
5080 index = fold_build2_loc (input_location, PLUS_EXPR,
5081 gfc_array_index_type, itmp, index);
5082 index = gfc_evaluate_now (index, block);
5084 /* Update the stride. */
5085 gfc_init_se (&start, NULL);
5086 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5087 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5088 gfc_array_index_type, start.expr,
5090 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5091 gfc_array_index_type,
5092 gfc_index_one_node, itmp);
5093 stride = fold_build2_loc (input_location, MULT_EXPR,
5094 gfc_array_index_type, stride, itmp);
5095 stride = gfc_evaluate_now (stride, block);
5098 /* Apply the index to obtain the array element. */
5099 tmp = gfc_build_array_ref (tmp, index, NULL);
5109 /* Set the target data pointer. */
5110 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5111 gfc_conv_descriptor_data_set (block, parm, offset);
5115 /* gfc_conv_expr_descriptor needs the string length an expression
5116 so that the size of the temporary can be obtained. This is done
5117 by adding up the string lengths of all the elements in the
5118 expression. Function with non-constant expressions have their
5119 string lengths mapped onto the actual arguments using the
5120 interface mapping machinery in trans-expr.c. */
5122 get_array_charlen (gfc_expr *expr, gfc_se *se)
5124 gfc_interface_mapping mapping;
5125 gfc_formal_arglist *formal;
5126 gfc_actual_arglist *arg;
5129 if (expr->ts.u.cl->length
5130 && gfc_is_constant_expr (expr->ts.u.cl->length))
5132 if (!expr->ts.u.cl->backend_decl)
5133 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5137 switch (expr->expr_type)
5140 get_array_charlen (expr->value.op.op1, se);
5142 /* For parentheses the expression ts.u.cl is identical. */
5143 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5146 expr->ts.u.cl->backend_decl =
5147 gfc_create_var (gfc_charlen_type_node, "sln");
5149 if (expr->value.op.op2)
5151 get_array_charlen (expr->value.op.op2, se);
5153 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5155 /* Add the string lengths and assign them to the expression
5156 string length backend declaration. */
5157 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5158 fold_build2_loc (input_location, PLUS_EXPR,
5159 gfc_charlen_type_node,
5160 expr->value.op.op1->ts.u.cl->backend_decl,
5161 expr->value.op.op2->ts.u.cl->backend_decl));
5164 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5165 expr->value.op.op1->ts.u.cl->backend_decl);
5169 if (expr->value.function.esym == NULL
5170 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5172 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5176 /* Map expressions involving the dummy arguments onto the actual
5177 argument expressions. */
5178 gfc_init_interface_mapping (&mapping);
5179 formal = expr->symtree->n.sym->formal;
5180 arg = expr->value.function.actual;
5182 /* Set se = NULL in the calls to the interface mapping, to suppress any
5184 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5189 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5192 gfc_init_se (&tse, NULL);
5194 /* Build the expression for the character length and convert it. */
5195 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5197 gfc_add_block_to_block (&se->pre, &tse.pre);
5198 gfc_add_block_to_block (&se->post, &tse.post);
5199 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5200 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5201 gfc_charlen_type_node, tse.expr,
5202 build_int_cst (gfc_charlen_type_node, 0));
5203 expr->ts.u.cl->backend_decl = tse.expr;
5204 gfc_free_interface_mapping (&mapping);
5208 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5215 /* Convert an array for passing as an actual argument. Expressions and
5216 vector subscripts are evaluated and stored in a temporary, which is then
5217 passed. For whole arrays the descriptor is passed. For array sections
5218 a modified copy of the descriptor is passed, but using the original data.
5220 This function is also used for array pointer assignments, and there
5223 - se->want_pointer && !se->direct_byref
5224 EXPR is an actual argument. On exit, se->expr contains a
5225 pointer to the array descriptor.
5227 - !se->want_pointer && !se->direct_byref
5228 EXPR is an actual argument to an intrinsic function or the
5229 left-hand side of a pointer assignment. On exit, se->expr
5230 contains the descriptor for EXPR.
5232 - !se->want_pointer && se->direct_byref
5233 EXPR is the right-hand side of a pointer assignment and
5234 se->expr is the descriptor for the previously-evaluated
5235 left-hand side. The function creates an assignment from
5236 EXPR to se->expr. */
5239 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5252 bool subref_array_target = false;
5254 gcc_assert (ss != gfc_ss_terminator);
5256 /* Special case things we know we can pass easily. */
5257 switch (expr->expr_type)
5260 /* If we have a linear array section, we can pass it directly.
5261 Otherwise we need to copy it into a temporary. */
5263 /* Find the SS for the array section. */
5265 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5266 secss = secss->next;
5268 gcc_assert (secss != gfc_ss_terminator);
5269 info = &secss->data.info;
5271 /* Get the descriptor for the array. */
5272 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5273 desc = info->descriptor;
5275 subref_array_target = se->direct_byref && is_subref_array (expr);
5276 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5277 && !subref_array_target;
5281 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5283 /* Create a new descriptor if the array doesn't have one. */
5286 else if (info->ref->u.ar.type == AR_FULL)
5288 else if (se->direct_byref)
5291 full = gfc_full_array_ref_p (info->ref, NULL);
5295 if (se->direct_byref && !se->byref_noassign)
5297 /* Copy the descriptor for pointer assignments. */
5298 gfc_add_modify (&se->pre, se->expr, desc);
5300 /* Add any offsets from subreferences. */
5301 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5302 subref_array_target, expr);
5304 else if (se->want_pointer)
5306 /* We pass full arrays directly. This means that pointers and
5307 allocatable arrays should also work. */
5308 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5315 if (expr->ts.type == BT_CHARACTER)
5316 se->string_length = gfc_get_expr_charlen (expr);
5323 /* A transformational function return value will be a temporary
5324 array descriptor. We still need to go through the scalarizer
5325 to create the descriptor. Elemental functions ar handled as
5326 arbitrary expressions, i.e. copy to a temporary. */
5328 /* Look for the SS for this function. */
5329 while (secss != gfc_ss_terminator
5330 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5331 secss = secss->next;
5333 if (se->direct_byref)
5335 gcc_assert (secss != gfc_ss_terminator);
5337 /* For pointer assignments pass the descriptor directly. */
5339 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5340 gfc_conv_expr (se, expr);
5344 if (secss == gfc_ss_terminator)
5346 /* Elemental function. */
5348 if (expr->ts.type == BT_CHARACTER
5349 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5350 get_array_charlen (expr, se);
5356 /* Transformational function. */
5357 info = &secss->data.info;
5363 /* Constant array constructors don't need a temporary. */
5364 if (ss->type == GFC_SS_CONSTRUCTOR
5365 && expr->ts.type != BT_CHARACTER
5366 && gfc_constant_array_constructor_p (expr->value.constructor))
5369 info = &ss->data.info;
5381 /* Something complicated. Copy it into a temporary. */
5388 gfc_init_loopinfo (&loop);
5390 /* Associate the SS with the loop. */
5391 gfc_add_ss_to_loop (&loop, ss);
5393 /* Tell the scalarizer not to bother creating loop variables, etc. */
5395 loop.array_parameter = 1;
5397 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5398 gcc_assert (!se->direct_byref);
5400 /* Setup the scalarizing loops and bounds. */
5401 gfc_conv_ss_startstride (&loop);
5405 /* Tell the scalarizer to make a temporary. */
5406 loop.temp_ss = gfc_get_ss ();
5407 loop.temp_ss->type = GFC_SS_TEMP;
5408 loop.temp_ss->next = gfc_ss_terminator;
5410 if (expr->ts.type == BT_CHARACTER
5411 && !expr->ts.u.cl->backend_decl)
5412 get_array_charlen (expr, se);
5414 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5416 if (expr->ts.type == BT_CHARACTER)
5417 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5419 loop.temp_ss->string_length = NULL;
5421 se->string_length = loop.temp_ss->string_length;
5422 loop.temp_ss->data.temp.dimen = loop.dimen;
5423 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5426 gfc_conv_loop_setup (&loop, & expr->where);
5430 /* Copy into a temporary and pass that. We don't need to copy the data
5431 back because expressions and vector subscripts must be INTENT_IN. */
5432 /* TODO: Optimize passing function return values. */
5436 /* Start the copying loops. */
5437 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5438 gfc_mark_ss_chain_used (ss, 1);
5439 gfc_start_scalarized_body (&loop, &block);
5441 /* Copy each data element. */
5442 gfc_init_se (&lse, NULL);
5443 gfc_copy_loopinfo_to_se (&lse, &loop);
5444 gfc_init_se (&rse, NULL);
5445 gfc_copy_loopinfo_to_se (&rse, &loop);
5447 lse.ss = loop.temp_ss;
5450 gfc_conv_scalarized_array_ref (&lse, NULL);
5451 if (expr->ts.type == BT_CHARACTER)
5453 gfc_conv_expr (&rse, expr);
5454 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5455 rse.expr = build_fold_indirect_ref_loc (input_location,
5459 gfc_conv_expr_val (&rse, expr);
5461 gfc_add_block_to_block (&block, &rse.pre);
5462 gfc_add_block_to_block (&block, &lse.pre);
5464 lse.string_length = rse.string_length;
5465 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5466 expr->expr_type == EXPR_VARIABLE, true);
5467 gfc_add_expr_to_block (&block, tmp);
5469 /* Finish the copying loops. */
5470 gfc_trans_scalarizing_loops (&loop, &block);
5472 desc = loop.temp_ss->data.info.descriptor;
5474 else if (expr->expr_type == EXPR_FUNCTION)
5476 desc = info->descriptor;
5477 se->string_length = ss->string_length;
5481 /* We pass sections without copying to a temporary. Make a new
5482 descriptor and point it at the section we want. The loop variable
5483 limits will be the limits of the section.
5484 A function may decide to repack the array to speed up access, but
5485 we're not bothered about that here. */
5494 /* Set the string_length for a character array. */
5495 if (expr->ts.type == BT_CHARACTER)
5496 se->string_length = gfc_get_expr_charlen (expr);
5498 desc = info->descriptor;
5499 gcc_assert (secss && secss != gfc_ss_terminator);
5500 if (se->direct_byref && !se->byref_noassign)
5502 /* For pointer assignments we fill in the destination. */
5504 parmtype = TREE_TYPE (parm);
5508 /* Otherwise make a new one. */
5509 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5510 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5511 loop.from, loop.to, 0,
5512 GFC_ARRAY_UNKNOWN, false);
5513 parm = gfc_create_var (parmtype, "parm");
5516 offset = gfc_index_zero_node;
5519 /* The following can be somewhat confusing. We have two
5520 descriptors, a new one and the original array.
5521 {parm, parmtype, dim} refer to the new one.
5522 {desc, type, n, secss, loop} refer to the original, which maybe
5523 a descriptorless array.
5524 The bounds of the scalarization are the bounds of the section.
5525 We don't have to worry about numeric overflows when calculating
5526 the offsets because all elements are within the array data. */
5528 /* Set the dtype. */
5529 tmp = gfc_conv_descriptor_dtype (parm);
5530 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5532 /* Set offset for assignments to pointer only to zero if it is not
5534 if (se->direct_byref
5535 && info->ref && info->ref->u.ar.type != AR_FULL)
5536 base = gfc_index_zero_node;
5537 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5538 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5542 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5543 for (n = 0; n < ndim; n++)
5545 stride = gfc_conv_array_stride (desc, n);
5547 /* Work out the offset. */
5549 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5551 gcc_assert (info->subscript[n]
5552 && info->subscript[n]->type == GFC_SS_SCALAR);
5553 start = info->subscript[n]->data.scalar.expr;
5557 /* Check we haven't somehow got out of sync. */
5558 gcc_assert (info->dim[dim] == n);
5560 /* Evaluate and remember the start of the section. */
5561 start = info->start[n];
5562 stride = gfc_evaluate_now (stride, &loop.pre);
5565 tmp = gfc_conv_array_lbound (desc, n);
5566 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5568 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5570 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5574 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5576 /* For elemental dimensions, we only need the offset. */
5580 /* Vector subscripts need copying and are handled elsewhere. */
5582 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5584 /* Set the new lower bound. */
5585 from = loop.from[dim];
5588 /* If we have an array section or are assigning make sure that
5589 the lower bound is 1. References to the full
5590 array should otherwise keep the original bounds. */
5592 || info->ref->u.ar.type != AR_FULL)
5593 && !integer_onep (from))
5595 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5596 gfc_array_index_type, gfc_index_one_node,
5598 to = fold_build2_loc (input_location, PLUS_EXPR,
5599 gfc_array_index_type, to, tmp);
5600 from = gfc_index_one_node;
5602 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5603 gfc_rank_cst[dim], from);
5605 /* Set the new upper bound. */
5606 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5607 gfc_rank_cst[dim], to);
5609 /* Multiply the stride by the section stride to get the
5611 stride = fold_build2_loc (input_location, MULT_EXPR,
5612 gfc_array_index_type,
5613 stride, info->stride[n]);
5615 if (se->direct_byref
5617 && info->ref->u.ar.type != AR_FULL)
5619 base = fold_build2_loc (input_location, MINUS_EXPR,
5620 TREE_TYPE (base), base, stride);
5622 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5624 tmp = gfc_conv_array_lbound (desc, n);
5625 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5626 TREE_TYPE (base), tmp, loop.from[dim]);
5627 tmp = fold_build2_loc (input_location, MULT_EXPR,
5628 TREE_TYPE (base), tmp,
5629 gfc_conv_array_stride (desc, n));
5630 base = fold_build2_loc (input_location, PLUS_EXPR,
5631 TREE_TYPE (base), tmp, base);
5634 /* Store the new stride. */
5635 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5636 gfc_rank_cst[dim], stride);
5641 if (se->data_not_needed)
5642 gfc_conv_descriptor_data_set (&loop.pre, parm,
5643 gfc_index_zero_node);
5645 /* Point the data pointer at the 1st element in the section. */
5646 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5647 subref_array_target, expr);
5649 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5650 && !se->data_not_needed)
5652 /* Set the offset. */
5653 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5657 /* Only the callee knows what the correct offset it, so just set
5659 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5664 if (!se->direct_byref || se->byref_noassign)
5666 /* Get a pointer to the new descriptor. */
5667 if (se->want_pointer)
5668 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5673 gfc_add_block_to_block (&se->pre, &loop.pre);
5674 gfc_add_block_to_block (&se->post, &loop.post);
5676 /* Cleanup the scalarizer. */
5677 gfc_cleanup_loop (&loop);
5680 /* Helper function for gfc_conv_array_parameter if array size needs to be
5684 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5687 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5688 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5689 else if (expr->rank > 1)
5690 *size = build_call_expr_loc (input_location,
5691 gfor_fndecl_size0, 1,
5692 gfc_build_addr_expr (NULL, desc));
5695 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5696 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5698 *size = fold_build2_loc (input_location, MINUS_EXPR,
5699 gfc_array_index_type, ubound, lbound);
5700 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5701 *size, gfc_index_one_node);
5702 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5703 *size, gfc_index_zero_node);
5705 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5706 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5707 *size, fold_convert (gfc_array_index_type, elem));
5710 /* Convert an array for passing as an actual parameter. */
5711 /* TODO: Optimize passing g77 arrays. */
5714 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5715 const gfc_symbol *fsym, const char *proc_name,
5720 tree tmp = NULL_TREE;
5722 tree parent = DECL_CONTEXT (current_function_decl);
5723 bool full_array_var;
5724 bool this_array_result;
5727 bool array_constructor;
5728 bool good_allocatable;
5729 bool ultimate_ptr_comp;
5730 bool ultimate_alloc_comp;
5735 ultimate_ptr_comp = false;
5736 ultimate_alloc_comp = false;
5738 for (ref = expr->ref; ref; ref = ref->next)
5740 if (ref->next == NULL)
5743 if (ref->type == REF_COMPONENT)
5745 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5746 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5750 full_array_var = false;
5753 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5754 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5756 sym = full_array_var ? expr->symtree->n.sym : NULL;
5758 /* The symbol should have an array specification. */
5759 gcc_assert (!sym || sym->as || ref->u.ar.as);
5761 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5763 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5764 expr->ts.u.cl->backend_decl = tmp;
5765 se->string_length = tmp;
5768 /* Is this the result of the enclosing procedure? */
5769 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5770 if (this_array_result
5771 && (sym->backend_decl != current_function_decl)
5772 && (sym->backend_decl != parent))
5773 this_array_result = false;
5775 /* Passing address of the array if it is not pointer or assumed-shape. */
5776 if (full_array_var && g77 && !this_array_result)
5778 tmp = gfc_get_symbol_decl (sym);
5780 if (sym->ts.type == BT_CHARACTER)
5781 se->string_length = sym->ts.u.cl->backend_decl;
5783 if (sym->ts.type == BT_DERIVED)
5785 gfc_conv_expr_descriptor (se, expr, ss);
5786 se->expr = gfc_conv_array_data (se->expr);
5790 if (!sym->attr.pointer
5792 && sym->as->type != AS_ASSUMED_SHAPE
5793 && !sym->attr.allocatable)
5795 /* Some variables are declared directly, others are declared as
5796 pointers and allocated on the heap. */
5797 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5800 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5802 array_parameter_size (tmp, expr, size);
5806 if (sym->attr.allocatable)
5808 if (sym->attr.dummy || sym->attr.result)
5810 gfc_conv_expr_descriptor (se, expr, ss);
5814 array_parameter_size (tmp, expr, size);
5815 se->expr = gfc_conv_array_data (tmp);
5820 /* A convenient reduction in scope. */
5821 contiguous = g77 && !this_array_result && contiguous;
5823 /* There is no need to pack and unpack the array, if it is contiguous
5824 and not a deferred- or assumed-shape array, or if it is simply
5826 no_pack = ((sym && sym->as
5827 && !sym->attr.pointer
5828 && sym->as->type != AS_DEFERRED
5829 && sym->as->type != AS_ASSUMED_SHAPE)
5831 (ref && ref->u.ar.as
5832 && ref->u.ar.as->type != AS_DEFERRED
5833 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
5835 gfc_is_simply_contiguous (expr, false));
5837 no_pack = contiguous && no_pack;
5839 /* Array constructors are always contiguous and do not need packing. */
5840 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5842 /* Same is true of contiguous sections from allocatable variables. */
5843 good_allocatable = contiguous
5845 && expr->symtree->n.sym->attr.allocatable;
5847 /* Or ultimate allocatable components. */
5848 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5850 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5852 gfc_conv_expr_descriptor (se, expr, ss);
5853 if (expr->ts.type == BT_CHARACTER)
5854 se->string_length = expr->ts.u.cl->backend_decl;
5856 array_parameter_size (se->expr, expr, size);
5857 se->expr = gfc_conv_array_data (se->expr);
5861 if (this_array_result)
5863 /* Result of the enclosing function. */
5864 gfc_conv_expr_descriptor (se, expr, ss);
5866 array_parameter_size (se->expr, expr, size);
5867 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5869 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5870 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5871 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5878 /* Every other type of array. */
5879 se->want_pointer = 1;
5880 gfc_conv_expr_descriptor (se, expr, ss);
5882 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5887 /* Deallocate the allocatable components of structures that are
5889 if (expr->ts.type == BT_DERIVED
5890 && expr->ts.u.derived->attr.alloc_comp
5891 && expr->expr_type != EXPR_VARIABLE)
5893 tmp = build_fold_indirect_ref_loc (input_location,
5895 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5896 gfc_add_expr_to_block (&se->post, tmp);
5899 if (g77 || (fsym && fsym->attr.contiguous
5900 && !gfc_is_simply_contiguous (expr, false)))
5902 tree origptr = NULL_TREE;
5906 /* For contiguous arrays, save the original value of the descriptor. */
5909 origptr = gfc_create_var (pvoid_type_node, "origptr");
5910 tmp = build_fold_indirect_ref_loc (input_location, desc);
5911 tmp = gfc_conv_array_data (tmp);
5912 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5913 TREE_TYPE (origptr), origptr,
5914 fold_convert (TREE_TYPE (origptr), tmp));
5915 gfc_add_expr_to_block (&se->pre, tmp);
5918 /* Repack the array. */
5919 if (gfc_option.warn_array_temp)
5922 gfc_warning ("Creating array temporary at %L for argument '%s'",
5923 &expr->where, fsym->name);
5925 gfc_warning ("Creating array temporary at %L", &expr->where);
5928 ptr = build_call_expr_loc (input_location,
5929 gfor_fndecl_in_pack, 1, desc);
5931 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5933 tmp = gfc_conv_expr_present (sym);
5934 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5935 fold_convert (TREE_TYPE (se->expr), ptr),
5936 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5939 ptr = gfc_evaluate_now (ptr, &se->pre);
5941 /* Use the packed data for the actual argument, except for contiguous arrays,
5942 where the descriptor's data component is set. */
5947 tmp = build_fold_indirect_ref_loc (input_location, desc);
5948 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
5951 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5955 if (fsym && proc_name)
5956 asprintf (&msg, "An array temporary was created for argument "
5957 "'%s' of procedure '%s'", fsym->name, proc_name);
5959 asprintf (&msg, "An array temporary was created");
5961 tmp = build_fold_indirect_ref_loc (input_location,
5963 tmp = gfc_conv_array_data (tmp);
5964 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5965 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5967 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5968 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5970 gfc_conv_expr_present (sym), tmp);
5972 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5977 gfc_start_block (&block);
5979 /* Copy the data back. */
5980 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5982 tmp = build_call_expr_loc (input_location,
5983 gfor_fndecl_in_unpack, 2, desc, ptr);
5984 gfc_add_expr_to_block (&block, tmp);
5987 /* Free the temporary. */
5988 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5989 gfc_add_expr_to_block (&block, tmp);
5991 stmt = gfc_finish_block (&block);
5993 gfc_init_block (&block);
5994 /* Only if it was repacked. This code needs to be executed before the
5995 loop cleanup code. */
5996 tmp = build_fold_indirect_ref_loc (input_location,
5998 tmp = gfc_conv_array_data (tmp);
5999 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6000 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6002 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6003 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6005 gfc_conv_expr_present (sym), tmp);
6007 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6009 gfc_add_expr_to_block (&block, tmp);
6010 gfc_add_block_to_block (&block, &se->post);
6012 gfc_init_block (&se->post);
6014 /* Reset the descriptor pointer. */
6017 tmp = build_fold_indirect_ref_loc (input_location, desc);
6018 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6021 gfc_add_block_to_block (&se->post, &block);
6026 /* Generate code to deallocate an array, if it is allocated. */
6029 gfc_trans_dealloc_allocated (tree descriptor)
6035 gfc_start_block (&block);
6037 var = gfc_conv_descriptor_data_get (descriptor);
6040 /* Call array_deallocate with an int * present in the second argument.
6041 Although it is ignored here, it's presence ensures that arrays that
6042 are already deallocated are ignored. */
6043 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6044 gfc_add_expr_to_block (&block, tmp);
6046 /* Zero the data pointer. */
6047 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6048 var, build_int_cst (TREE_TYPE (var), 0));
6049 gfc_add_expr_to_block (&block, tmp);
6051 return gfc_finish_block (&block);
6055 /* This helper function calculates the size in words of a full array. */
6058 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6063 idx = gfc_rank_cst[rank - 1];
6064 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6065 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6066 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6068 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6069 tmp, gfc_index_one_node);
6070 tmp = gfc_evaluate_now (tmp, block);
6072 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6073 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6075 return gfc_evaluate_now (tmp, block);
6079 /* Allocate dest to the same size as src, and copy src -> dest.
6080 If no_malloc is set, only the copy is done. */
6083 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6093 /* If the source is null, set the destination to null. Then,
6094 allocate memory to the destination. */
6095 gfc_init_block (&block);
6099 tmp = null_pointer_node;
6100 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6101 gfc_add_expr_to_block (&block, tmp);
6102 null_data = gfc_finish_block (&block);
6104 gfc_init_block (&block);
6105 size = TYPE_SIZE_UNIT (type);
6108 tmp = gfc_call_malloc (&block, type, size);
6109 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6110 dest, fold_convert (type, tmp));
6111 gfc_add_expr_to_block (&block, tmp);
6114 tmp = built_in_decls[BUILT_IN_MEMCPY];
6115 tmp = build_call_expr_loc (input_location, tmp, 3,
6120 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6121 null_data = gfc_finish_block (&block);
6123 gfc_init_block (&block);
6124 nelems = get_full_array_size (&block, src, rank);
6125 tmp = fold_convert (gfc_array_index_type,
6126 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6127 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6131 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6132 tmp = gfc_call_malloc (&block, tmp, size);
6133 gfc_conv_descriptor_data_set (&block, dest, tmp);
6136 /* We know the temporary and the value will be the same length,
6137 so can use memcpy. */
6138 tmp = built_in_decls[BUILT_IN_MEMCPY];
6139 tmp = build_call_expr_loc (input_location,
6140 tmp, 3, gfc_conv_descriptor_data_get (dest),
6141 gfc_conv_descriptor_data_get (src), size);
6144 gfc_add_expr_to_block (&block, tmp);
6145 tmp = gfc_finish_block (&block);
6147 /* Null the destination if the source is null; otherwise do
6148 the allocate and copy. */
6152 null_cond = gfc_conv_descriptor_data_get (src);
6154 null_cond = convert (pvoid_type_node, null_cond);
6155 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6156 null_cond, null_pointer_node);
6157 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6161 /* Allocate dest to the same size as src, and copy data src -> dest. */
6164 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6166 return duplicate_allocatable (dest, src, type, rank, false);
6170 /* Copy data src -> dest. */
6173 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6175 return duplicate_allocatable (dest, src, type, rank, true);
6179 /* Recursively traverse an object of derived type, generating code to
6180 deallocate, nullify or copy allocatable components. This is the work horse
6181 function for the functions named in this enum. */
6183 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6184 COPY_ONLY_ALLOC_COMP};
6187 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6188 tree dest, int rank, int purpose)
6192 stmtblock_t fnblock;
6193 stmtblock_t loopbody;
6204 tree null_cond = NULL_TREE;
6206 gfc_init_block (&fnblock);
6208 decl_type = TREE_TYPE (decl);
6210 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6211 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6213 decl = build_fold_indirect_ref_loc (input_location,
6216 /* Just in case in gets dereferenced. */
6217 decl_type = TREE_TYPE (decl);
6219 /* If this an array of derived types with allocatable components
6220 build a loop and recursively call this function. */
6221 if (TREE_CODE (decl_type) == ARRAY_TYPE
6222 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6224 tmp = gfc_conv_array_data (decl);
6225 var = build_fold_indirect_ref_loc (input_location,
6228 /* Get the number of elements - 1 and set the counter. */
6229 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6231 /* Use the descriptor for an allocatable array. Since this
6232 is a full array reference, we only need the descriptor
6233 information from dimension = rank. */
6234 tmp = get_full_array_size (&fnblock, decl, rank);
6235 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6236 gfc_array_index_type, tmp,
6237 gfc_index_one_node);
6239 null_cond = gfc_conv_descriptor_data_get (decl);
6240 null_cond = fold_build2_loc (input_location, NE_EXPR,
6241 boolean_type_node, null_cond,
6242 build_int_cst (TREE_TYPE (null_cond), 0));
6246 /* Otherwise use the TYPE_DOMAIN information. */
6247 tmp = array_type_nelts (decl_type);
6248 tmp = fold_convert (gfc_array_index_type, tmp);
6251 /* Remember that this is, in fact, the no. of elements - 1. */
6252 nelems = gfc_evaluate_now (tmp, &fnblock);
6253 index = gfc_create_var (gfc_array_index_type, "S");
6255 /* Build the body of the loop. */
6256 gfc_init_block (&loopbody);
6258 vref = gfc_build_array_ref (var, index, NULL);
6260 if (purpose == COPY_ALLOC_COMP)
6262 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6264 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6265 gfc_add_expr_to_block (&fnblock, tmp);
6267 tmp = build_fold_indirect_ref_loc (input_location,
6268 gfc_conv_array_data (dest));
6269 dref = gfc_build_array_ref (tmp, index, NULL);
6270 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6272 else if (purpose == COPY_ONLY_ALLOC_COMP)
6274 tmp = build_fold_indirect_ref_loc (input_location,
6275 gfc_conv_array_data (dest));
6276 dref = gfc_build_array_ref (tmp, index, NULL);
6277 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6281 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6283 gfc_add_expr_to_block (&loopbody, tmp);
6285 /* Build the loop and return. */
6286 gfc_init_loopinfo (&loop);
6288 loop.from[0] = gfc_index_zero_node;
6289 loop.loopvar[0] = index;
6290 loop.to[0] = nelems;
6291 gfc_trans_scalarizing_loops (&loop, &loopbody);
6292 gfc_add_block_to_block (&fnblock, &loop.pre);
6294 tmp = gfc_finish_block (&fnblock);
6295 if (null_cond != NULL_TREE)
6296 tmp = build3_v (COND_EXPR, null_cond, tmp,
6297 build_empty_stmt (input_location));
6302 /* Otherwise, act on the components or recursively call self to
6303 act on a chain of components. */
6304 for (c = der_type->components; c; c = c->next)
6306 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6307 && c->ts.u.derived->attr.alloc_comp;
6308 cdecl = c->backend_decl;
6309 ctype = TREE_TYPE (cdecl);
6313 case DEALLOCATE_ALLOC_COMP:
6314 /* Do not deallocate the components of ultimate pointer
6316 if (cmp_has_alloc_comps && !c->attr.pointer)
6318 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6319 decl, cdecl, NULL_TREE);
6320 rank = c->as ? c->as->rank : 0;
6321 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6323 gfc_add_expr_to_block (&fnblock, tmp);
6326 if (c->attr.allocatable && c->attr.dimension)
6328 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6329 decl, cdecl, NULL_TREE);
6330 tmp = gfc_trans_dealloc_allocated (comp);
6331 gfc_add_expr_to_block (&fnblock, tmp);
6333 else if (c->attr.allocatable)
6335 /* Allocatable scalar components. */
6336 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6337 decl, cdecl, NULL_TREE);
6339 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6340 gfc_add_expr_to_block (&fnblock, tmp);
6342 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6343 void_type_node, comp,
6344 build_int_cst (TREE_TYPE (comp), 0));
6345 gfc_add_expr_to_block (&fnblock, tmp);
6347 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6349 /* Allocatable scalar CLASS components. */
6350 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6351 decl, cdecl, NULL_TREE);
6353 /* Add reference to '$data' component. */
6354 tmp = CLASS_DATA (c)->backend_decl;
6355 comp = fold_build3_loc (input_location, COMPONENT_REF,
6356 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6358 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6359 gfc_add_expr_to_block (&fnblock, tmp);
6361 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6362 void_type_node, comp,
6363 build_int_cst (TREE_TYPE (comp), 0));
6364 gfc_add_expr_to_block (&fnblock, tmp);
6368 case NULLIFY_ALLOC_COMP:
6369 if (c->attr.pointer)
6371 else if (c->attr.allocatable && c->attr.dimension)
6373 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6374 decl, cdecl, NULL_TREE);
6375 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6377 else if (c->attr.allocatable)
6379 /* Allocatable scalar components. */
6380 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6381 decl, cdecl, NULL_TREE);
6382 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6383 void_type_node, comp,
6384 build_int_cst (TREE_TYPE (comp), 0));
6385 gfc_add_expr_to_block (&fnblock, tmp);
6387 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6389 /* Allocatable scalar CLASS components. */
6390 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6391 decl, cdecl, NULL_TREE);
6392 /* Add reference to '$data' component. */
6393 tmp = CLASS_DATA (c)->backend_decl;
6394 comp = fold_build3_loc (input_location, COMPONENT_REF,
6395 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6396 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6397 void_type_node, comp,
6398 build_int_cst (TREE_TYPE (comp), 0));
6399 gfc_add_expr_to_block (&fnblock, tmp);
6401 else if (cmp_has_alloc_comps)
6403 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6404 decl, cdecl, NULL_TREE);
6405 rank = c->as ? c->as->rank : 0;
6406 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6408 gfc_add_expr_to_block (&fnblock, tmp);
6412 case COPY_ALLOC_COMP:
6413 if (c->attr.pointer)
6416 /* We need source and destination components. */
6417 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6419 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6421 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6423 if (c->attr.allocatable && !cmp_has_alloc_comps)
6425 rank = c->as ? c->as->rank : 0;
6426 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6427 gfc_add_expr_to_block (&fnblock, tmp);
6430 if (cmp_has_alloc_comps)
6432 rank = c->as ? c->as->rank : 0;
6433 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6434 gfc_add_modify (&fnblock, dcmp, tmp);
6435 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6437 gfc_add_expr_to_block (&fnblock, tmp);
6447 return gfc_finish_block (&fnblock);
6450 /* Recursively traverse an object of derived type, generating code to
6451 nullify allocatable components. */
6454 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6456 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6457 NULLIFY_ALLOC_COMP);
6461 /* Recursively traverse an object of derived type, generating code to
6462 deallocate allocatable components. */
6465 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6467 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6468 DEALLOCATE_ALLOC_COMP);
6472 /* Recursively traverse an object of derived type, generating code to
6473 copy it and its allocatable components. */
6476 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6478 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6482 /* Recursively traverse an object of derived type, generating code to
6483 copy only its allocatable components. */
6486 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6488 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6492 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6493 Do likewise, recursively if necessary, with the allocatable components of
6497 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
6503 stmtblock_t cleanup;
6506 bool sym_has_alloc_comp;
6508 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6509 && sym->ts.u.derived->attr.alloc_comp;
6511 /* Make sure the frontend gets these right. */
6512 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6513 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6514 "allocatable attribute or derived type without allocatable "
6517 gfc_init_block (&init);
6519 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6520 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6522 if (sym->ts.type == BT_CHARACTER
6523 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6525 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6526 gfc_trans_vla_type_sizes (sym, &init);
6529 /* Dummy, use associated and result variables don't need anything special. */
6530 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6532 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6536 gfc_get_backend_locus (&loc);
6537 gfc_set_backend_locus (&sym->declared_at);
6538 descriptor = sym->backend_decl;
6540 /* Although static, derived types with default initializers and
6541 allocatable components must not be nulled wholesale; instead they
6542 are treated component by component. */
6543 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6545 /* SAVEd variables are not freed on exit. */
6546 gfc_trans_static_array_pointer (sym);
6548 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6552 /* Get the descriptor type. */
6553 type = TREE_TYPE (sym->backend_decl);
6555 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6558 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6560 if (sym->value == NULL
6561 || !gfc_has_default_initializer (sym->ts.u.derived))
6563 rank = sym->as ? sym->as->rank : 0;
6564 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
6566 gfc_add_expr_to_block (&init, tmp);
6569 gfc_init_default_dt (sym, &init, false);
6572 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6574 /* If the backend_decl is not a descriptor, we must have a pointer
6576 descriptor = build_fold_indirect_ref_loc (input_location,
6578 type = TREE_TYPE (descriptor);
6581 /* NULLIFY the data pointer. */
6582 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6583 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
6585 gfc_init_block (&cleanup);
6586 gfc_set_backend_locus (&loc);
6588 /* Allocatable arrays need to be freed when they go out of scope.
6589 The allocatable components of pointers must not be touched. */
6590 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6591 && !sym->attr.pointer && !sym->attr.save)
6594 rank = sym->as ? sym->as->rank : 0;
6595 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6596 gfc_add_expr_to_block (&cleanup, tmp);
6599 if (sym->attr.allocatable && sym->attr.dimension
6600 && !sym->attr.save && !sym->attr.result)
6602 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6603 gfc_add_expr_to_block (&cleanup, tmp);
6606 gfc_add_init_cleanup (block, gfc_finish_block (&init),
6607 gfc_finish_block (&cleanup));
6610 /************ Expression Walking Functions ******************/
6612 /* Walk a variable reference.
6614 Possible extension - multiple component subscripts.
6615 x(:,:) = foo%a(:)%b(:)
6617 forall (i=..., j=...)
6618 x(i,j) = foo%a(j)%b(i)
6620 This adds a fair amount of complexity because you need to deal with more
6621 than one ref. Maybe handle in a similar manner to vector subscripts.
6622 Maybe not worth the effort. */
6626 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6633 for (ref = expr->ref; ref; ref = ref->next)
6634 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6637 for (; ref; ref = ref->next)
6639 if (ref->type == REF_SUBSTRING)
6641 newss = gfc_get_ss ();
6642 newss->type = GFC_SS_SCALAR;
6643 newss->expr = ref->u.ss.start;
6647 newss = gfc_get_ss ();
6648 newss->type = GFC_SS_SCALAR;
6649 newss->expr = ref->u.ss.end;
6654 /* We're only interested in array sections from now on. */
6655 if (ref->type != REF_ARRAY)
6660 if (ar->as->rank == 0)
6662 /* Scalar coarray. */
6669 for (n = 0; n < ar->dimen; n++)
6671 newss = gfc_get_ss ();
6672 newss->type = GFC_SS_SCALAR;
6673 newss->expr = ar->start[n];
6680 newss = gfc_get_ss ();
6681 newss->type = GFC_SS_SECTION;
6684 newss->data.info.dimen = ar->as->rank;
6685 newss->data.info.ref = ref;
6687 /* Make sure array is the same as array(:,:), this way
6688 we don't need to special case all the time. */
6689 ar->dimen = ar->as->rank;
6690 for (n = 0; n < ar->dimen; n++)
6692 newss->data.info.dim[n] = n;
6693 ar->dimen_type[n] = DIMEN_RANGE;
6695 gcc_assert (ar->start[n] == NULL);
6696 gcc_assert (ar->end[n] == NULL);
6697 gcc_assert (ar->stride[n] == NULL);
6703 newss = gfc_get_ss ();
6704 newss->type = GFC_SS_SECTION;
6707 newss->data.info.dimen = 0;
6708 newss->data.info.ref = ref;
6710 /* We add SS chains for all the subscripts in the section. */
6711 for (n = 0; n < ar->dimen; n++)
6715 switch (ar->dimen_type[n])
6718 /* Add SS for elemental (scalar) subscripts. */
6719 gcc_assert (ar->start[n]);
6720 indexss = gfc_get_ss ();
6721 indexss->type = GFC_SS_SCALAR;
6722 indexss->expr = ar->start[n];
6723 indexss->next = gfc_ss_terminator;
6724 indexss->loop_chain = gfc_ss_terminator;
6725 newss->data.info.subscript[n] = indexss;
6729 /* We don't add anything for sections, just remember this
6730 dimension for later. */
6731 newss->data.info.dim[newss->data.info.dimen] = n;
6732 newss->data.info.dimen++;
6736 /* Create a GFC_SS_VECTOR index in which we can store
6737 the vector's descriptor. */
6738 indexss = gfc_get_ss ();
6739 indexss->type = GFC_SS_VECTOR;
6740 indexss->expr = ar->start[n];
6741 indexss->next = gfc_ss_terminator;
6742 indexss->loop_chain = gfc_ss_terminator;
6743 newss->data.info.subscript[n] = indexss;
6744 newss->data.info.dim[newss->data.info.dimen] = n;
6745 newss->data.info.dimen++;
6749 /* We should know what sort of section it is by now. */
6753 /* We should have at least one non-elemental dimension. */
6754 gcc_assert (newss->data.info.dimen > 0);
6759 /* We should know what sort of section it is by now. */
6768 /* Walk an expression operator. If only one operand of a binary expression is
6769 scalar, we must also add the scalar term to the SS chain. */
6772 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6778 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6779 if (expr->value.op.op2 == NULL)
6782 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6784 /* All operands are scalar. Pass back and let the caller deal with it. */
6788 /* All operands require scalarization. */
6789 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6792 /* One of the operands needs scalarization, the other is scalar.
6793 Create a gfc_ss for the scalar expression. */
6794 newss = gfc_get_ss ();
6795 newss->type = GFC_SS_SCALAR;
6798 /* First operand is scalar. We build the chain in reverse order, so
6799 add the scalar SS after the second operand. */
6801 while (head && head->next != ss)
6803 /* Check we haven't somehow broken the chain. */
6807 newss->expr = expr->value.op.op1;
6809 else /* head2 == head */
6811 gcc_assert (head2 == head);
6812 /* Second operand is scalar. */
6813 newss->next = head2;
6815 newss->expr = expr->value.op.op2;
6822 /* Reverse a SS chain. */
6825 gfc_reverse_ss (gfc_ss * ss)
6830 gcc_assert (ss != NULL);
6832 head = gfc_ss_terminator;
6833 while (ss != gfc_ss_terminator)
6836 /* Check we didn't somehow break the chain. */
6837 gcc_assert (next != NULL);
6847 /* Walk the arguments of an elemental function. */
6850 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6858 head = gfc_ss_terminator;
6861 for (; arg; arg = arg->next)
6866 newss = gfc_walk_subexpr (head, arg->expr);
6869 /* Scalar argument. */
6870 newss = gfc_get_ss ();
6872 newss->expr = arg->expr;
6882 while (tail->next != gfc_ss_terminator)
6889 /* If all the arguments are scalar we don't need the argument SS. */
6890 gfc_free_ss_chain (head);
6895 /* Add it onto the existing chain. */
6901 /* Walk a function call. Scalar functions are passed back, and taken out of
6902 scalarization loops. For elemental functions we walk their arguments.
6903 The result of functions returning arrays is stored in a temporary outside
6904 the loop, so that the function is only called once. Hence we do not need
6905 to walk their arguments. */
6908 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6911 gfc_intrinsic_sym *isym;
6913 gfc_component *comp = NULL;
6916 isym = expr->value.function.isym;
6918 /* Handle intrinsic functions separately. */
6920 return gfc_walk_intrinsic_function (ss, expr, isym);
6922 sym = expr->value.function.esym;
6924 sym = expr->symtree->n.sym;
6926 /* A function that returns arrays. */
6927 gfc_is_proc_ptr_comp (expr, &comp);
6928 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6929 || (comp && comp->attr.dimension))
6931 newss = gfc_get_ss ();
6932 newss->type = GFC_SS_FUNCTION;
6935 newss->data.info.dimen = expr->rank;
6936 for (n = 0; n < newss->data.info.dimen; n++)
6937 newss->data.info.dim[n] = n;
6941 /* Walk the parameters of an elemental function. For now we always pass
6943 if (sym->attr.elemental)
6944 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6947 /* Scalar functions are OK as these are evaluated outside the scalarization
6948 loop. Pass back and let the caller deal with it. */
6953 /* An array temporary is constructed for array constructors. */
6956 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6961 newss = gfc_get_ss ();
6962 newss->type = GFC_SS_CONSTRUCTOR;
6965 newss->data.info.dimen = expr->rank;
6966 for (n = 0; n < expr->rank; n++)
6967 newss->data.info.dim[n] = n;
6973 /* Walk an expression. Add walked expressions to the head of the SS chain.
6974 A wholly scalar expression will not be added. */
6977 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6981 switch (expr->expr_type)
6984 head = gfc_walk_variable_expr (ss, expr);
6988 head = gfc_walk_op_expr (ss, expr);
6992 head = gfc_walk_function_expr (ss, expr);
6997 case EXPR_STRUCTURE:
6998 /* Pass back and let the caller deal with it. */
7002 head = gfc_walk_array_constructor (ss, expr);
7005 case EXPR_SUBSTRING:
7006 /* Pass back and let the caller deal with it. */
7010 internal_error ("bad expression type during walk (%d)",
7017 /* Entry point for expression walking.
7018 A return value equal to the passed chain means this is
7019 a scalar expression. It is up to the caller to take whatever action is
7020 necessary to translate these. */
7023 gfc_walk_expr (gfc_expr * expr)
7027 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7028 return gfc_reverse_ss (res);