1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subscripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
87 #include "constructor.h"
89 #include "trans-stmt.h"
90 #include "trans-types.h"
91 #include "trans-array.h"
92 #include "trans-const.h"
93 #include "dependency.h"
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 + se->loop->codimen; 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 if (se->loop->codimen == 0
580 || n < se->loop->dimen + se->loop->codimen - 1)
582 /* ...and the upper bound. */
583 gfc_init_se (&tmpse, NULL);
584 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
585 gfc_add_block_to_block (&se->pre, &tmpse.pre);
586 gfc_add_block_to_block (&se->post, &tmpse.post);
587 upper = fold_convert (gfc_array_index_type, tmpse.expr);
589 /* Set the upper bound of the loop to UPPER - LOWER. */
590 tmp = fold_build2_loc (input_location, MINUS_EXPR,
591 gfc_array_index_type, upper, lower);
592 tmp = gfc_evaluate_now (tmp, &se->pre);
593 se->loop->to[n] = tmp;
600 /* Generate code to allocate an array temporary, or create a variable to
601 hold the data. If size is NULL, zero the descriptor so that the
602 callee will allocate the array. If DEALLOC is true, also generate code to
603 free the array afterwards.
605 If INITIAL is not NULL, it is packed using internal_pack and the result used
606 as data instead of allocating a fresh, unitialized area of memory.
608 Initialization code is added to PRE and finalization code to POST.
609 DYNAMIC is true if the caller may want to extend the array later
610 using realloc. This prevents us from putting the array on the stack. */
613 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
614 gfc_ss_info * info, tree size, tree nelem,
615 tree initial, bool dynamic, bool dealloc)
621 desc = info->descriptor;
622 info->offset = gfc_index_zero_node;
623 if (size == NULL_TREE || integer_zerop (size))
625 /* A callee allocated array. */
626 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
631 /* Allocate the temporary. */
632 onstack = !dynamic && initial == NULL_TREE
633 && gfc_can_put_var_on_stack (size);
637 /* Make a temporary variable to hold the data. */
638 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
639 nelem, gfc_index_one_node);
640 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
642 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
644 tmp = gfc_create_var (tmp, "A");
645 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
646 gfc_conv_descriptor_data_set (pre, desc, tmp);
650 /* Allocate memory to hold the data or call internal_pack. */
651 if (initial == NULL_TREE)
653 tmp = gfc_call_malloc (pre, NULL, size);
654 tmp = gfc_evaluate_now (tmp, pre);
661 stmtblock_t do_copying;
663 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
664 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
665 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
666 tmp = gfc_get_element_type (tmp);
667 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
668 packed = gfc_create_var (build_pointer_type (tmp), "data");
670 tmp = build_call_expr_loc (input_location,
671 gfor_fndecl_in_pack, 1, initial);
672 tmp = fold_convert (TREE_TYPE (packed), tmp);
673 gfc_add_modify (pre, packed, tmp);
675 tmp = build_fold_indirect_ref_loc (input_location,
677 source_data = gfc_conv_descriptor_data_get (tmp);
679 /* internal_pack may return source->data without any allocation
680 or copying if it is already packed. If that's the case, we
681 need to allocate and copy manually. */
683 gfc_start_block (&do_copying);
684 tmp = gfc_call_malloc (&do_copying, NULL, size);
685 tmp = fold_convert (TREE_TYPE (packed), tmp);
686 gfc_add_modify (&do_copying, packed, tmp);
687 tmp = gfc_build_memcpy_call (packed, source_data, size);
688 gfc_add_expr_to_block (&do_copying, tmp);
690 was_packed = fold_build2_loc (input_location, EQ_EXPR,
691 boolean_type_node, packed,
693 tmp = gfc_finish_block (&do_copying);
694 tmp = build3_v (COND_EXPR, was_packed, tmp,
695 build_empty_stmt (input_location));
696 gfc_add_expr_to_block (pre, tmp);
698 tmp = fold_convert (pvoid_type_node, packed);
701 gfc_conv_descriptor_data_set (pre, desc, tmp);
704 info->data = gfc_conv_descriptor_data_get (desc);
706 /* The offset is zero because we create temporaries with a zero
708 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
710 if (dealloc && !onstack)
712 /* Free the temporary. */
713 tmp = gfc_conv_descriptor_data_get (desc);
714 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
715 gfc_add_expr_to_block (post, tmp);
720 /* Get the array reference dimension corresponding to the given loop dimension.
721 It is different from the true array dimension given by the dim array in
722 the case of a partial array reference
723 It is different from the loop dimension in the case of a transposed array.
727 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
729 int n, array_dim, array_ref_dim;
732 array_dim = info->dim[loop_dim];
734 for (n = 0; n < info->dimen; n++)
735 if (n != loop_dim && info->dim[n] < array_dim)
738 return array_ref_dim;
742 /* Generate code to create and initialize the descriptor for a temporary
743 array. This is used for both temporaries needed by the scalarizer, and
744 functions returning arrays. Adjusts the loop variables to be
745 zero-based, and calculates the loop bounds for callee allocated arrays.
746 Allocate the array unless it's callee allocated (we have a callee
747 allocated array if 'callee_alloc' is true, or if loop->to[n] is
748 NULL_TREE for any n). Also fills in the descriptor, data and offset
749 fields of info if known. Returns the size of the array, or NULL for a
750 callee allocated array.
752 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
753 gfc_trans_allocate_array_storage.
757 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
758 gfc_loopinfo * loop, gfc_ss_info * info,
759 tree eltype, tree initial, bool dynamic,
760 bool dealloc, bool callee_alloc, locus * where)
762 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
772 memset (from, 0, sizeof (from));
773 memset (to, 0, sizeof (to));
775 gcc_assert (info->dimen > 0);
776 gcc_assert (loop->dimen == info->dimen);
778 if (gfc_option.warn_array_temp && where)
779 gfc_warning ("Creating array temporary at %L", where);
781 /* Set the lower bound to zero. */
782 for (n = 0; n < loop->dimen; n++)
786 /* Callee allocated arrays may not have a known bound yet. */
788 loop->to[n] = gfc_evaluate_now (
789 fold_build2_loc (input_location, MINUS_EXPR,
790 gfc_array_index_type,
791 loop->to[n], loop->from[n]),
793 loop->from[n] = gfc_index_zero_node;
795 /* We are constructing the temporary's descriptor based on the loop
796 dimensions. As the dimensions may be accessed in arbitrary order
797 (think of transpose) the size taken from the n'th loop may not map
798 to the n'th dimension of the array. We need to reconstruct loop infos
799 in the right order before using it to set the descriptor
801 tmp_dim = get_array_ref_dim (info, n);
802 from[tmp_dim] = loop->from[n];
803 to[tmp_dim] = loop->to[n];
805 info->delta[dim] = gfc_index_zero_node;
806 info->start[dim] = gfc_index_zero_node;
807 info->end[dim] = gfc_index_zero_node;
808 info->stride[dim] = gfc_index_one_node;
811 /* Initialize the descriptor. */
813 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
814 GFC_ARRAY_UNKNOWN, true);
815 desc = gfc_create_var (type, "atmp");
816 GFC_DECL_PACKED_ARRAY (desc) = 1;
818 info->descriptor = desc;
819 size = gfc_index_one_node;
821 /* Fill in the array dtype. */
822 tmp = gfc_conv_descriptor_dtype (desc);
823 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
826 Fill in the bounds and stride. This is a packed array, so:
829 for (n = 0; n < rank; n++)
832 delta = ubound[n] + 1 - lbound[n];
835 size = size * sizeof(element);
840 /* If there is at least one null loop->to[n], it is a callee allocated
842 for (n = 0; n < loop->dimen; n++)
843 if (loop->to[n] == NULL_TREE)
849 for (n = 0; n < loop->dimen; n++)
853 if (size == NULL_TREE)
855 /* For a callee allocated array express the loop bounds in terms
856 of the descriptor fields. */
857 tmp = fold_build2_loc (input_location,
858 MINUS_EXPR, gfc_array_index_type,
859 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
860 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
865 /* Store the stride and bound components in the descriptor. */
866 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
868 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
869 gfc_index_zero_node);
871 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
874 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
875 to[n], gfc_index_one_node);
877 /* Check whether the size for this dimension is negative. */
878 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
879 gfc_index_zero_node);
880 cond = gfc_evaluate_now (cond, pre);
885 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
886 boolean_type_node, or_expr, cond);
888 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
890 size = gfc_evaluate_now (size, pre);
892 for (n = info->dimen; n < info->dimen + info->codimen; n++)
894 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
895 gfc_index_zero_node);
896 if (n < info->dimen + info->codimen - 1)
897 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
900 /* Get the size of the array. */
902 if (size && !callee_alloc)
904 /* If or_expr is true, then the extent in at least one
905 dimension is zero and the size is set to zero. */
906 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
907 or_expr, gfc_index_zero_node, size);
910 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
912 fold_convert (gfc_array_index_type,
913 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
921 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
924 if (info->dimen > loop->temp_dim)
925 loop->temp_dim = info->dimen;
931 /* Return the number of iterations in a loop that starts at START,
932 ends at END, and has step STEP. */
935 gfc_get_iteration_count (tree start, tree end, tree step)
940 type = TREE_TYPE (step);
941 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
942 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
943 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
944 build_int_cst (type, 1));
945 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
946 build_int_cst (type, 0));
947 return fold_convert (gfc_array_index_type, tmp);
951 /* Extend the data in array DESC by EXTRA elements. */
954 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
961 if (integer_zerop (extra))
964 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
966 /* Add EXTRA to the upper bound. */
967 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
969 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
971 /* Get the value of the current data pointer. */
972 arg0 = gfc_conv_descriptor_data_get (desc);
974 /* Calculate the new array size. */
975 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
976 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
977 ubound, gfc_index_one_node);
978 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
979 fold_convert (size_type_node, tmp),
980 fold_convert (size_type_node, size));
982 /* Call the realloc() function. */
983 tmp = gfc_call_realloc (pblock, arg0, arg1);
984 gfc_conv_descriptor_data_set (pblock, desc, tmp);
988 /* Return true if the bounds of iterator I can only be determined
992 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
994 return (i->start->expr_type != EXPR_CONSTANT
995 || i->end->expr_type != EXPR_CONSTANT
996 || i->step->expr_type != EXPR_CONSTANT);
1000 /* Split the size of constructor element EXPR into the sum of two terms,
1001 one of which can be determined at compile time and one of which must
1002 be calculated at run time. Set *SIZE to the former and return true
1003 if the latter might be nonzero. */
1006 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1008 if (expr->expr_type == EXPR_ARRAY)
1009 return gfc_get_array_constructor_size (size, expr->value.constructor);
1010 else if (expr->rank > 0)
1012 /* Calculate everything at run time. */
1013 mpz_set_ui (*size, 0);
1018 /* A single element. */
1019 mpz_set_ui (*size, 1);
1025 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1026 of array constructor C. */
1029 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1037 mpz_set_ui (*size, 0);
1042 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1045 if (i && gfc_iterator_has_dynamic_bounds (i))
1049 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1052 /* Multiply the static part of the element size by the
1053 number of iterations. */
1054 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1055 mpz_fdiv_q (val, val, i->step->value.integer);
1056 mpz_add_ui (val, val, 1);
1057 if (mpz_sgn (val) > 0)
1058 mpz_mul (len, len, val);
1060 mpz_set_ui (len, 0);
1062 mpz_add (*size, *size, len);
1071 /* Make sure offset is a variable. */
1074 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1077 /* We should have already created the offset variable. We cannot
1078 create it here because we may be in an inner scope. */
1079 gcc_assert (*offsetvar != NULL_TREE);
1080 gfc_add_modify (pblock, *offsetvar, *poffset);
1081 *poffset = *offsetvar;
1082 TREE_USED (*offsetvar) = 1;
1086 /* Variables needed for bounds-checking. */
1087 static bool first_len;
1088 static tree first_len_val;
1089 static bool typespec_chararray_ctor;
1092 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1093 tree offset, gfc_se * se, gfc_expr * expr)
1097 gfc_conv_expr (se, expr);
1099 /* Store the value. */
1100 tmp = build_fold_indirect_ref_loc (input_location,
1101 gfc_conv_descriptor_data_get (desc));
1102 tmp = gfc_build_array_ref (tmp, offset, NULL);
1104 if (expr->ts.type == BT_CHARACTER)
1106 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1109 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1110 esize = fold_convert (gfc_charlen_type_node, esize);
1111 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1112 gfc_charlen_type_node, esize,
1113 build_int_cst (gfc_charlen_type_node,
1114 gfc_character_kinds[i].bit_size / 8));
1116 gfc_conv_string_parameter (se);
1117 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1119 /* The temporary is an array of pointers. */
1120 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1121 gfc_add_modify (&se->pre, tmp, se->expr);
1125 /* The temporary is an array of string values. */
1126 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1127 /* We know the temporary and the value will be the same length,
1128 so can use memcpy. */
1129 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1130 se->string_length, se->expr, expr->ts.kind);
1132 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1136 gfc_add_modify (&se->pre, first_len_val,
1142 /* Verify that all constructor elements are of the same
1144 tree cond = fold_build2_loc (input_location, NE_EXPR,
1145 boolean_type_node, first_len_val,
1147 gfc_trans_runtime_check
1148 (true, false, cond, &se->pre, &expr->where,
1149 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1150 fold_convert (long_integer_type_node, first_len_val),
1151 fold_convert (long_integer_type_node, se->string_length));
1157 /* TODO: Should the frontend already have done this conversion? */
1158 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1159 gfc_add_modify (&se->pre, tmp, se->expr);
1162 gfc_add_block_to_block (pblock, &se->pre);
1163 gfc_add_block_to_block (pblock, &se->post);
1167 /* Add the contents of an array to the constructor. DYNAMIC is as for
1168 gfc_trans_array_constructor_value. */
1171 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1172 tree type ATTRIBUTE_UNUSED,
1173 tree desc, gfc_expr * expr,
1174 tree * poffset, tree * offsetvar,
1185 /* We need this to be a variable so we can increment it. */
1186 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1188 gfc_init_se (&se, NULL);
1190 /* Walk the array expression. */
1191 ss = gfc_walk_expr (expr);
1192 gcc_assert (ss != gfc_ss_terminator);
1194 /* Initialize the scalarizer. */
1195 gfc_init_loopinfo (&loop);
1196 gfc_add_ss_to_loop (&loop, ss);
1198 /* Initialize the loop. */
1199 gfc_conv_ss_startstride (&loop);
1200 gfc_conv_loop_setup (&loop, &expr->where);
1202 /* Make sure the constructed array has room for the new data. */
1205 /* Set SIZE to the total number of elements in the subarray. */
1206 size = gfc_index_one_node;
1207 for (n = 0; n < loop.dimen; n++)
1209 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1210 gfc_index_one_node);
1211 size = fold_build2_loc (input_location, MULT_EXPR,
1212 gfc_array_index_type, size, tmp);
1215 /* Grow the constructed array by SIZE elements. */
1216 gfc_grow_array (&loop.pre, desc, size);
1219 /* Make the loop body. */
1220 gfc_mark_ss_chain_used (ss, 1);
1221 gfc_start_scalarized_body (&loop, &body);
1222 gfc_copy_loopinfo_to_se (&se, &loop);
1225 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1226 gcc_assert (se.ss == gfc_ss_terminator);
1228 /* Increment the offset. */
1229 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1230 *poffset, gfc_index_one_node);
1231 gfc_add_modify (&body, *poffset, tmp);
1233 /* Finish the loop. */
1234 gfc_trans_scalarizing_loops (&loop, &body);
1235 gfc_add_block_to_block (&loop.pre, &loop.post);
1236 tmp = gfc_finish_block (&loop.pre);
1237 gfc_add_expr_to_block (pblock, tmp);
1239 gfc_cleanup_loop (&loop);
1243 /* Assign the values to the elements of an array constructor. DYNAMIC
1244 is true if descriptor DESC only contains enough data for the static
1245 size calculated by gfc_get_array_constructor_size. When true, memory
1246 for the dynamic parts must be allocated using realloc. */
1249 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1250 tree desc, gfc_constructor_base base,
1251 tree * poffset, tree * offsetvar,
1260 tree shadow_loopvar = NULL_TREE;
1261 gfc_saved_var saved_loopvar;
1264 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1266 /* If this is an iterator or an array, the offset must be a variable. */
1267 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1268 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1270 /* Shadowing the iterator avoids changing its value and saves us from
1271 keeping track of it. Further, it makes sure that there's always a
1272 backend-decl for the symbol, even if there wasn't one before,
1273 e.g. in the case of an iterator that appears in a specification
1274 expression in an interface mapping. */
1277 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1278 tree type = gfc_typenode_for_spec (&sym->ts);
1280 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1281 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1284 gfc_start_block (&body);
1286 if (c->expr->expr_type == EXPR_ARRAY)
1288 /* Array constructors can be nested. */
1289 gfc_trans_array_constructor_value (&body, type, desc,
1290 c->expr->value.constructor,
1291 poffset, offsetvar, dynamic);
1293 else if (c->expr->rank > 0)
1295 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1296 poffset, offsetvar, dynamic);
1300 /* This code really upsets the gimplifier so don't bother for now. */
1307 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1309 p = gfc_constructor_next (p);
1314 /* Scalar values. */
1315 gfc_init_se (&se, NULL);
1316 gfc_trans_array_ctor_element (&body, desc, *poffset,
1319 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1320 gfc_array_index_type,
1321 *poffset, gfc_index_one_node);
1325 /* Collect multiple scalar constants into a constructor. */
1326 VEC(constructor_elt,gc) *v = NULL;
1330 HOST_WIDE_INT idx = 0;
1333 /* Count the number of consecutive scalar constants. */
1334 while (p && !(p->iterator
1335 || p->expr->expr_type != EXPR_CONSTANT))
1337 gfc_init_se (&se, NULL);
1338 gfc_conv_constant (&se, p->expr);
1340 if (c->expr->ts.type != BT_CHARACTER)
1341 se.expr = fold_convert (type, se.expr);
1342 /* For constant character array constructors we build
1343 an array of pointers. */
1344 else if (POINTER_TYPE_P (type))
1345 se.expr = gfc_build_addr_expr
1346 (gfc_get_pchar_type (p->expr->ts.kind),
1349 CONSTRUCTOR_APPEND_ELT (v,
1350 build_int_cst (gfc_array_index_type,
1354 p = gfc_constructor_next (p);
1357 bound = build_int_cst (NULL_TREE, n - 1);
1358 /* Create an array type to hold them. */
1359 tmptype = build_range_type (gfc_array_index_type,
1360 gfc_index_zero_node, bound);
1361 tmptype = build_array_type (type, tmptype);
1363 init = build_constructor (tmptype, v);
1364 TREE_CONSTANT (init) = 1;
1365 TREE_STATIC (init) = 1;
1366 /* Create a static variable to hold the data. */
1367 tmp = gfc_create_var (tmptype, "data");
1368 TREE_STATIC (tmp) = 1;
1369 TREE_CONSTANT (tmp) = 1;
1370 TREE_READONLY (tmp) = 1;
1371 DECL_INITIAL (tmp) = init;
1374 /* Use BUILTIN_MEMCPY to assign the values. */
1375 tmp = gfc_conv_descriptor_data_get (desc);
1376 tmp = build_fold_indirect_ref_loc (input_location,
1378 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1379 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1380 init = gfc_build_addr_expr (NULL_TREE, init);
1382 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1383 bound = build_int_cst (NULL_TREE, n * size);
1384 tmp = build_call_expr_loc (input_location,
1385 built_in_decls[BUILT_IN_MEMCPY], 3,
1387 gfc_add_expr_to_block (&body, tmp);
1389 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1390 gfc_array_index_type, *poffset,
1391 build_int_cst (gfc_array_index_type, n));
1393 if (!INTEGER_CST_P (*poffset))
1395 gfc_add_modify (&body, *offsetvar, *poffset);
1396 *poffset = *offsetvar;
1400 /* The frontend should already have done any expansions
1404 /* Pass the code as is. */
1405 tmp = gfc_finish_block (&body);
1406 gfc_add_expr_to_block (pblock, tmp);
1410 /* Build the implied do-loop. */
1411 stmtblock_t implied_do_block;
1419 loopbody = gfc_finish_block (&body);
1421 /* Create a new block that holds the implied-do loop. A temporary
1422 loop-variable is used. */
1423 gfc_start_block(&implied_do_block);
1425 /* Initialize the loop. */
1426 gfc_init_se (&se, NULL);
1427 gfc_conv_expr_val (&se, c->iterator->start);
1428 gfc_add_block_to_block (&implied_do_block, &se.pre);
1429 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1431 gfc_init_se (&se, NULL);
1432 gfc_conv_expr_val (&se, c->iterator->end);
1433 gfc_add_block_to_block (&implied_do_block, &se.pre);
1434 end = gfc_evaluate_now (se.expr, &implied_do_block);
1436 gfc_init_se (&se, NULL);
1437 gfc_conv_expr_val (&se, c->iterator->step);
1438 gfc_add_block_to_block (&implied_do_block, &se.pre);
1439 step = gfc_evaluate_now (se.expr, &implied_do_block);
1441 /* If this array expands dynamically, and the number of iterations
1442 is not constant, we won't have allocated space for the static
1443 part of C->EXPR's size. Do that now. */
1444 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1446 /* Get the number of iterations. */
1447 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1449 /* Get the static part of C->EXPR's size. */
1450 gfc_get_array_constructor_element_size (&size, c->expr);
1451 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1453 /* Grow the array by TMP * TMP2 elements. */
1454 tmp = fold_build2_loc (input_location, MULT_EXPR,
1455 gfc_array_index_type, tmp, tmp2);
1456 gfc_grow_array (&implied_do_block, desc, tmp);
1459 /* Generate the loop body. */
1460 exit_label = gfc_build_label_decl (NULL_TREE);
1461 gfc_start_block (&body);
1463 /* Generate the exit condition. Depending on the sign of
1464 the step variable we have to generate the correct
1466 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1467 step, build_int_cst (TREE_TYPE (step), 0));
1468 cond = fold_build3_loc (input_location, COND_EXPR,
1469 boolean_type_node, tmp,
1470 fold_build2_loc (input_location, GT_EXPR,
1471 boolean_type_node, shadow_loopvar, end),
1472 fold_build2_loc (input_location, LT_EXPR,
1473 boolean_type_node, shadow_loopvar, end));
1474 tmp = build1_v (GOTO_EXPR, exit_label);
1475 TREE_USED (exit_label) = 1;
1476 tmp = build3_v (COND_EXPR, cond, tmp,
1477 build_empty_stmt (input_location));
1478 gfc_add_expr_to_block (&body, tmp);
1480 /* The main loop body. */
1481 gfc_add_expr_to_block (&body, loopbody);
1483 /* Increase loop variable by step. */
1484 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1485 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1487 gfc_add_modify (&body, shadow_loopvar, tmp);
1489 /* Finish the loop. */
1490 tmp = gfc_finish_block (&body);
1491 tmp = build1_v (LOOP_EXPR, tmp);
1492 gfc_add_expr_to_block (&implied_do_block, tmp);
1494 /* Add the exit label. */
1495 tmp = build1_v (LABEL_EXPR, exit_label);
1496 gfc_add_expr_to_block (&implied_do_block, tmp);
1498 /* Finishe the implied-do loop. */
1499 tmp = gfc_finish_block(&implied_do_block);
1500 gfc_add_expr_to_block(pblock, tmp);
1502 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1509 /* A catch-all to obtain the string length for anything that is not a
1510 a substring of non-constant length, a constant, array or variable. */
1513 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1518 /* Don't bother if we already know the length is a constant. */
1519 if (*len && INTEGER_CST_P (*len))
1522 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1523 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1526 gfc_conv_const_charlen (e->ts.u.cl);
1527 *len = e->ts.u.cl->backend_decl;
1531 /* Otherwise, be brutal even if inefficient. */
1532 ss = gfc_walk_expr (e);
1533 gfc_init_se (&se, NULL);
1535 /* No function call, in case of side effects. */
1536 se.no_function_call = 1;
1537 if (ss == gfc_ss_terminator)
1538 gfc_conv_expr (&se, e);
1540 gfc_conv_expr_descriptor (&se, e, ss);
1542 /* Fix the value. */
1543 *len = gfc_evaluate_now (se.string_length, &se.pre);
1545 gfc_add_block_to_block (block, &se.pre);
1546 gfc_add_block_to_block (block, &se.post);
1548 e->ts.u.cl->backend_decl = *len;
1553 /* Figure out the string length of a variable reference expression.
1554 Used by get_array_ctor_strlen. */
1557 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1563 /* Don't bother if we already know the length is a constant. */
1564 if (*len && INTEGER_CST_P (*len))
1567 ts = &expr->symtree->n.sym->ts;
1568 for (ref = expr->ref; ref; ref = ref->next)
1573 /* Array references don't change the string length. */
1577 /* Use the length of the component. */
1578 ts = &ref->u.c.component->ts;
1582 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1583 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1585 /* Note that this might evaluate expr. */
1586 get_array_ctor_all_strlen (block, expr, len);
1589 mpz_init_set_ui (char_len, 1);
1590 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1591 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1592 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1593 *len = convert (gfc_charlen_type_node, *len);
1594 mpz_clear (char_len);
1602 *len = ts->u.cl->backend_decl;
1606 /* Figure out the string length of a character array constructor.
1607 If len is NULL, don't calculate the length; this happens for recursive calls
1608 when a sub-array-constructor is an element but not at the first position,
1609 so when we're not interested in the length.
1610 Returns TRUE if all elements are character constants. */
1613 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1620 if (gfc_constructor_first (base) == NULL)
1623 *len = build_int_cstu (gfc_charlen_type_node, 0);
1627 /* Loop over all constructor elements to find out is_const, but in len we
1628 want to store the length of the first, not the last, element. We can
1629 of course exit the loop as soon as is_const is found to be false. */
1630 for (c = gfc_constructor_first (base);
1631 c && is_const; c = gfc_constructor_next (c))
1633 switch (c->expr->expr_type)
1636 if (len && !(*len && INTEGER_CST_P (*len)))
1637 *len = build_int_cstu (gfc_charlen_type_node,
1638 c->expr->value.character.length);
1642 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1649 get_array_ctor_var_strlen (block, c->expr, len);
1655 get_array_ctor_all_strlen (block, c->expr, len);
1659 /* After the first iteration, we don't want the length modified. */
1666 /* Check whether the array constructor C consists entirely of constant
1667 elements, and if so returns the number of those elements, otherwise
1668 return zero. Note, an empty or NULL array constructor returns zero. */
1670 unsigned HOST_WIDE_INT
1671 gfc_constant_array_constructor_p (gfc_constructor_base base)
1673 unsigned HOST_WIDE_INT nelem = 0;
1675 gfc_constructor *c = gfc_constructor_first (base);
1679 || c->expr->rank > 0
1680 || c->expr->expr_type != EXPR_CONSTANT)
1682 c = gfc_constructor_next (c);
1689 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1690 and the tree type of it's elements, TYPE, return a static constant
1691 variable that is compile-time initialized. */
1694 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1696 tree tmptype, init, tmp;
1697 HOST_WIDE_INT nelem;
1702 VEC(constructor_elt,gc) *v = NULL;
1704 /* First traverse the constructor list, converting the constants
1705 to tree to build an initializer. */
1707 c = gfc_constructor_first (expr->value.constructor);
1710 gfc_init_se (&se, NULL);
1711 gfc_conv_constant (&se, c->expr);
1712 if (c->expr->ts.type != BT_CHARACTER)
1713 se.expr = fold_convert (type, se.expr);
1714 else if (POINTER_TYPE_P (type))
1715 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1717 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1719 c = gfc_constructor_next (c);
1723 /* Next determine the tree type for the array. We use the gfortran
1724 front-end's gfc_get_nodesc_array_type in order to create a suitable
1725 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1727 memset (&as, 0, sizeof (gfc_array_spec));
1729 as.rank = expr->rank;
1730 as.type = AS_EXPLICIT;
1733 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1734 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1738 for (i = 0; i < expr->rank; i++)
1740 int tmp = (int) mpz_get_si (expr->shape[i]);
1741 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1742 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1746 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1748 /* as is not needed anymore. */
1749 for (i = 0; i < as.rank + as.corank; i++)
1751 gfc_free_expr (as.lower[i]);
1752 gfc_free_expr (as.upper[i]);
1755 init = build_constructor (tmptype, v);
1757 TREE_CONSTANT (init) = 1;
1758 TREE_STATIC (init) = 1;
1760 tmp = gfc_create_var (tmptype, "A");
1761 TREE_STATIC (tmp) = 1;
1762 TREE_CONSTANT (tmp) = 1;
1763 TREE_READONLY (tmp) = 1;
1764 DECL_INITIAL (tmp) = init;
1770 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1771 This mostly initializes the scalarizer state info structure with the
1772 appropriate values to directly use the array created by the function
1773 gfc_build_constant_array_constructor. */
1776 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1777 gfc_ss * ss, tree type)
1783 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1785 info = &ss->data.info;
1787 info->descriptor = tmp;
1788 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1789 info->offset = gfc_index_zero_node;
1791 for (i = 0; i < info->dimen + info->codimen; i++)
1793 info->delta[i] = gfc_index_zero_node;
1794 info->start[i] = gfc_index_zero_node;
1795 info->end[i] = gfc_index_zero_node;
1796 info->stride[i] = gfc_index_one_node;
1800 if (info->dimen > loop->temp_dim)
1801 loop->temp_dim = info->dimen;
1804 /* Helper routine of gfc_trans_array_constructor to determine if the
1805 bounds of the loop specified by LOOP are constant and simple enough
1806 to use with gfc_trans_constant_array_constructor. Returns the
1807 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1810 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1812 tree size = gfc_index_one_node;
1816 for (i = 0; i < loop->dimen; i++)
1818 /* If the bounds aren't constant, return NULL_TREE. */
1819 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1821 if (!integer_zerop (loop->from[i]))
1823 /* Only allow nonzero "from" in one-dimensional arrays. */
1824 if (loop->dimen != 1)
1826 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1827 gfc_array_index_type,
1828 loop->to[i], loop->from[i]);
1832 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1833 tmp, gfc_index_one_node);
1834 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1842 /* Array constructors are handled by constructing a temporary, then using that
1843 within the scalarization loop. This is not optimal, but seems by far the
1847 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1849 gfc_constructor_base c;
1856 bool old_first_len, old_typespec_chararray_ctor;
1857 tree old_first_len_val;
1859 /* Save the old values for nested checking. */
1860 old_first_len = first_len;
1861 old_first_len_val = first_len_val;
1862 old_typespec_chararray_ctor = typespec_chararray_ctor;
1864 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1865 typespec was given for the array constructor. */
1866 typespec_chararray_ctor = (ss->expr->ts.u.cl
1867 && ss->expr->ts.u.cl->length_from_typespec);
1869 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1870 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1872 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1876 ss->data.info.dimen = loop->dimen;
1878 c = ss->expr->value.constructor;
1879 if (ss->expr->ts.type == BT_CHARACTER)
1883 /* get_array_ctor_strlen walks the elements of the constructor, if a
1884 typespec was given, we already know the string length and want the one
1886 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1887 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1891 const_string = false;
1892 gfc_init_se (&length_se, NULL);
1893 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1894 gfc_charlen_type_node);
1895 ss->string_length = length_se.expr;
1896 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1897 gfc_add_block_to_block (&loop->post, &length_se.post);
1900 const_string = get_array_ctor_strlen (&loop->pre, c,
1901 &ss->string_length);
1903 /* Complex character array constructors should have been taken care of
1904 and not end up here. */
1905 gcc_assert (ss->string_length);
1907 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1909 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1911 type = build_pointer_type (type);
1914 type = gfc_typenode_for_spec (&ss->expr->ts);
1916 /* See if the constructor determines the loop bounds. */
1919 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1921 /* We have a multidimensional parameter. */
1923 for (n = 0; n < ss->expr->rank; n++)
1925 loop->from[n] = gfc_index_zero_node;
1926 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1927 gfc_index_integer_kind);
1928 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1929 gfc_array_index_type,
1930 loop->to[n], gfc_index_one_node);
1934 if (loop->to[0] == NULL_TREE)
1938 /* We should have a 1-dimensional, zero-based loop. */
1939 gcc_assert (loop->dimen == 1);
1940 gcc_assert (integer_zerop (loop->from[0]));
1942 /* Split the constructor size into a static part and a dynamic part.
1943 Allocate the static size up-front and record whether the dynamic
1944 size might be nonzero. */
1946 dynamic = gfc_get_array_constructor_size (&size, c);
1947 mpz_sub_ui (size, size, 1);
1948 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1952 /* Special case constant array constructors. */
1955 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1958 tree size = constant_array_constructor_loop_size (loop);
1959 if (size && compare_tree_int (size, nelem) == 0)
1961 gfc_trans_constant_array_constructor (loop, ss, type);
1967 if (TREE_CODE (loop->to[0]) == VAR_DECL)
1970 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1971 type, NULL_TREE, dynamic, true, false, where);
1973 desc = ss->data.info.descriptor;
1974 offset = gfc_index_zero_node;
1975 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1976 TREE_NO_WARNING (offsetvar) = 1;
1977 TREE_USED (offsetvar) = 0;
1978 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1979 &offset, &offsetvar, dynamic);
1981 /* If the array grows dynamically, the upper bound of the loop variable
1982 is determined by the array's final upper bound. */
1985 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1986 gfc_array_index_type,
1987 offsetvar, gfc_index_one_node);
1988 tmp = gfc_evaluate_now (tmp, &loop->pre);
1989 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
1990 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
1991 gfc_add_modify (&loop->pre, loop->to[0], tmp);
1996 if (TREE_USED (offsetvar))
1997 pushdecl (offsetvar);
1999 gcc_assert (INTEGER_CST_P (offset));
2002 /* Disable bound checking for now because it's probably broken. */
2003 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2010 /* Restore old values of globals. */
2011 first_len = old_first_len;
2012 first_len_val = old_first_len_val;
2013 typespec_chararray_ctor = old_typespec_chararray_ctor;
2017 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2018 called after evaluating all of INFO's vector dimensions. Go through
2019 each such vector dimension and see if we can now fill in any missing
2023 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2032 for (n = 0; n < loop->dimen + loop->codimen; n++)
2035 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2036 && loop->to[n] == NULL)
2038 /* Loop variable N indexes vector dimension DIM, and we don't
2039 yet know the upper bound of loop variable N. Set it to the
2040 difference between the vector's upper and lower bounds. */
2041 gcc_assert (loop->from[n] == gfc_index_zero_node);
2042 gcc_assert (info->subscript[dim]
2043 && info->subscript[dim]->type == GFC_SS_VECTOR);
2045 gfc_init_se (&se, NULL);
2046 desc = info->subscript[dim]->data.info.descriptor;
2047 zero = gfc_rank_cst[0];
2048 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2049 gfc_array_index_type,
2050 gfc_conv_descriptor_ubound_get (desc, zero),
2051 gfc_conv_descriptor_lbound_get (desc, zero));
2052 tmp = gfc_evaluate_now (tmp, &loop->pre);
2059 /* Add the pre and post chains for all the scalar expressions in a SS chain
2060 to loop. This is called after the loop parameters have been calculated,
2061 but before the actual scalarizing loops. */
2064 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2070 /* TODO: This can generate bad code if there are ordering dependencies,
2071 e.g., a callee allocated function and an unknown size constructor. */
2072 gcc_assert (ss != NULL);
2074 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2081 /* Scalar expression. Evaluate this now. This includes elemental
2082 dimension indices, but not array section bounds. */
2083 gfc_init_se (&se, NULL);
2084 gfc_conv_expr (&se, ss->expr);
2085 gfc_add_block_to_block (&loop->pre, &se.pre);
2087 if (ss->expr->ts.type != BT_CHARACTER)
2089 /* Move the evaluation of scalar expressions outside the
2090 scalarization loop, except for WHERE assignments. */
2092 se.expr = convert(gfc_array_index_type, se.expr);
2094 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2095 gfc_add_block_to_block (&loop->pre, &se.post);
2098 gfc_add_block_to_block (&loop->post, &se.post);
2100 ss->data.scalar.expr = se.expr;
2101 ss->string_length = se.string_length;
2104 case GFC_SS_REFERENCE:
2105 /* Scalar argument to elemental procedure. Evaluate this
2107 gfc_init_se (&se, NULL);
2108 gfc_conv_expr (&se, ss->expr);
2109 gfc_add_block_to_block (&loop->pre, &se.pre);
2110 gfc_add_block_to_block (&loop->post, &se.post);
2112 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2113 ss->string_length = se.string_length;
2116 case GFC_SS_SECTION:
2117 /* Add the expressions for scalar and vector subscripts. */
2118 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2119 if (ss->data.info.subscript[n])
2120 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2123 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2127 /* Get the vector's descriptor and store it in SS. */
2128 gfc_init_se (&se, NULL);
2129 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2130 gfc_add_block_to_block (&loop->pre, &se.pre);
2131 gfc_add_block_to_block (&loop->post, &se.post);
2132 ss->data.info.descriptor = se.expr;
2135 case GFC_SS_INTRINSIC:
2136 gfc_add_intrinsic_ss_code (loop, ss);
2139 case GFC_SS_FUNCTION:
2140 /* Array function return value. We call the function and save its
2141 result in a temporary for use inside the loop. */
2142 gfc_init_se (&se, NULL);
2145 gfc_conv_expr (&se, ss->expr);
2146 gfc_add_block_to_block (&loop->pre, &se.pre);
2147 gfc_add_block_to_block (&loop->post, &se.post);
2148 ss->string_length = se.string_length;
2151 case GFC_SS_CONSTRUCTOR:
2152 if (ss->expr->ts.type == BT_CHARACTER
2153 && ss->string_length == NULL
2154 && ss->expr->ts.u.cl
2155 && ss->expr->ts.u.cl->length)
2157 gfc_init_se (&se, NULL);
2158 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2159 gfc_charlen_type_node);
2160 ss->string_length = se.expr;
2161 gfc_add_block_to_block (&loop->pre, &se.pre);
2162 gfc_add_block_to_block (&loop->post, &se.post);
2164 gfc_trans_array_constructor (loop, ss, where);
2168 case GFC_SS_COMPONENT:
2169 /* Do nothing. These are handled elsewhere. */
2179 /* Translate expressions for the descriptor and data pointer of a SS. */
2183 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2188 /* Get the descriptor for the array to be scalarized. */
2189 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2190 gfc_init_se (&se, NULL);
2191 se.descriptor_only = 1;
2192 gfc_conv_expr_lhs (&se, ss->expr);
2193 gfc_add_block_to_block (block, &se.pre);
2194 ss->data.info.descriptor = se.expr;
2195 ss->string_length = se.string_length;
2199 /* Also the data pointer. */
2200 tmp = gfc_conv_array_data (se.expr);
2201 /* If this is a variable or address of a variable we use it directly.
2202 Otherwise we must evaluate it now to avoid breaking dependency
2203 analysis by pulling the expressions for elemental array indices
2206 || (TREE_CODE (tmp) == ADDR_EXPR
2207 && DECL_P (TREE_OPERAND (tmp, 0)))))
2208 tmp = gfc_evaluate_now (tmp, block);
2209 ss->data.info.data = tmp;
2211 tmp = gfc_conv_array_offset (se.expr);
2212 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2214 /* Make absolutely sure that the saved_offset is indeed saved
2215 so that the variable is still accessible after the loops
2217 ss->data.info.saved_offset = ss->data.info.offset;
2222 /* Initialize a gfc_loopinfo structure. */
2225 gfc_init_loopinfo (gfc_loopinfo * loop)
2229 memset (loop, 0, sizeof (gfc_loopinfo));
2230 gfc_init_block (&loop->pre);
2231 gfc_init_block (&loop->post);
2233 /* Initially scalarize in order and default to no loop reversal. */
2234 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2237 loop->reverse[n] = GFC_CANNOT_REVERSE;
2240 loop->ss = gfc_ss_terminator;
2244 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2248 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2254 /* Return an expression for the data pointer of an array. */
2257 gfc_conv_array_data (tree descriptor)
2261 type = TREE_TYPE (descriptor);
2262 if (GFC_ARRAY_TYPE_P (type))
2264 if (TREE_CODE (type) == POINTER_TYPE)
2268 /* Descriptorless arrays. */
2269 return gfc_build_addr_expr (NULL_TREE, descriptor);
2273 return gfc_conv_descriptor_data_get (descriptor);
2277 /* Return an expression for the base offset of an array. */
2280 gfc_conv_array_offset (tree descriptor)
2284 type = TREE_TYPE (descriptor);
2285 if (GFC_ARRAY_TYPE_P (type))
2286 return GFC_TYPE_ARRAY_OFFSET (type);
2288 return gfc_conv_descriptor_offset_get (descriptor);
2292 /* Get an expression for the array stride. */
2295 gfc_conv_array_stride (tree descriptor, int dim)
2300 type = TREE_TYPE (descriptor);
2302 /* For descriptorless arrays use the array size. */
2303 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2304 if (tmp != NULL_TREE)
2307 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2312 /* Like gfc_conv_array_stride, but for the lower bound. */
2315 gfc_conv_array_lbound (tree descriptor, int dim)
2320 type = TREE_TYPE (descriptor);
2322 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2323 if (tmp != NULL_TREE)
2326 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2331 /* Like gfc_conv_array_stride, but for the upper bound. */
2334 gfc_conv_array_ubound (tree descriptor, int dim)
2339 type = TREE_TYPE (descriptor);
2341 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2342 if (tmp != NULL_TREE)
2345 /* This should only ever happen when passing an assumed shape array
2346 as an actual parameter. The value will never be used. */
2347 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2348 return gfc_index_zero_node;
2350 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2355 /* Generate code to perform an array index bound check. */
2358 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2359 locus * where, bool check_upper)
2362 tree tmp_lo, tmp_up;
2364 const char * name = NULL;
2366 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2369 index = gfc_evaluate_now (index, &se->pre);
2371 /* We find a name for the error message. */
2373 name = se->ss->expr->symtree->name;
2375 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2376 && se->loop->ss->expr->symtree)
2377 name = se->loop->ss->expr->symtree->name;
2379 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2380 && se->loop->ss->loop_chain->expr
2381 && se->loop->ss->loop_chain->expr->symtree)
2382 name = se->loop->ss->loop_chain->expr->symtree->name;
2384 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2386 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2387 && se->loop->ss->expr->value.function.name)
2388 name = se->loop->ss->expr->value.function.name;
2390 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2391 || se->loop->ss->type == GFC_SS_SCALAR)
2392 name = "unnamed constant";
2395 if (TREE_CODE (descriptor) == VAR_DECL)
2396 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2398 /* If upper bound is present, include both bounds in the error message. */
2401 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2402 tmp_up = gfc_conv_array_ubound (descriptor, n);
2405 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2406 "outside of expected range (%%ld:%%ld)", n+1, name);
2408 asprintf (&msg, "Index '%%ld' of dimension %d "
2409 "outside of expected range (%%ld:%%ld)", n+1);
2411 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2413 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2414 fold_convert (long_integer_type_node, index),
2415 fold_convert (long_integer_type_node, tmp_lo),
2416 fold_convert (long_integer_type_node, tmp_up));
2417 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2419 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2420 fold_convert (long_integer_type_node, index),
2421 fold_convert (long_integer_type_node, tmp_lo),
2422 fold_convert (long_integer_type_node, tmp_up));
2427 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2430 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2431 "below lower bound of %%ld", n+1, name);
2433 asprintf (&msg, "Index '%%ld' of dimension %d "
2434 "below lower bound of %%ld", n+1);
2436 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2438 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2439 fold_convert (long_integer_type_node, index),
2440 fold_convert (long_integer_type_node, tmp_lo));
2448 /* Return the offset for an index. Performs bound checking for elemental
2449 dimensions. Single element references are processed separately.
2450 DIM is the array dimension, I is the loop dimension. */
2453 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2454 gfc_array_ref * ar, tree stride)
2460 /* Get the index into the array for this dimension. */
2463 gcc_assert (ar->type != AR_ELEMENT);
2464 switch (ar->dimen_type[dim])
2466 case DIMEN_THIS_IMAGE:
2470 /* Elemental dimension. */
2471 gcc_assert (info->subscript[dim]
2472 && info->subscript[dim]->type == GFC_SS_SCALAR);
2473 /* We've already translated this value outside the loop. */
2474 index = info->subscript[dim]->data.scalar.expr;
2476 index = gfc_trans_array_bound_check (se, info->descriptor,
2477 index, dim, &ar->where,
2478 ar->as->type != AS_ASSUMED_SIZE
2479 || dim < ar->dimen - 1);
2483 gcc_assert (info && se->loop);
2484 gcc_assert (info->subscript[dim]
2485 && info->subscript[dim]->type == GFC_SS_VECTOR);
2486 desc = info->subscript[dim]->data.info.descriptor;
2488 /* Get a zero-based index into the vector. */
2489 index = fold_build2_loc (input_location, MINUS_EXPR,
2490 gfc_array_index_type,
2491 se->loop->loopvar[i], se->loop->from[i]);
2493 /* Multiply the index by the stride. */
2494 index = fold_build2_loc (input_location, MULT_EXPR,
2495 gfc_array_index_type,
2496 index, gfc_conv_array_stride (desc, 0));
2498 /* Read the vector to get an index into info->descriptor. */
2499 data = build_fold_indirect_ref_loc (input_location,
2500 gfc_conv_array_data (desc));
2501 index = gfc_build_array_ref (data, index, NULL);
2502 index = gfc_evaluate_now (index, &se->pre);
2503 index = fold_convert (gfc_array_index_type, index);
2505 /* Do any bounds checking on the final info->descriptor index. */
2506 index = gfc_trans_array_bound_check (se, info->descriptor,
2507 index, dim, &ar->where,
2508 ar->as->type != AS_ASSUMED_SIZE
2509 || dim < ar->dimen - 1);
2513 /* Scalarized dimension. */
2514 gcc_assert (info && se->loop);
2516 /* Multiply the loop variable by the stride and delta. */
2517 index = se->loop->loopvar[i];
2518 if (!integer_onep (info->stride[dim]))
2519 index = fold_build2_loc (input_location, MULT_EXPR,
2520 gfc_array_index_type, index,
2522 if (!integer_zerop (info->delta[dim]))
2523 index = fold_build2_loc (input_location, PLUS_EXPR,
2524 gfc_array_index_type, index,
2534 /* Temporary array or derived type component. */
2535 gcc_assert (se->loop);
2536 index = se->loop->loopvar[se->loop->order[i]];
2537 if (!integer_zerop (info->delta[dim]))
2538 index = fold_build2_loc (input_location, PLUS_EXPR,
2539 gfc_array_index_type, index, info->delta[dim]);
2542 /* Multiply by the stride. */
2543 if (!integer_onep (stride))
2544 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2551 /* Build a scalarized reference to an array. */
2554 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2557 tree decl = NULL_TREE;
2562 info = &se->ss->data.info;
2564 n = se->loop->order[0];
2568 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2570 /* Add the offset for this dimension to the stored offset for all other
2572 if (!integer_zerop (info->offset))
2573 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2574 index, info->offset);
2576 if (se->ss->expr && is_subref_array (se->ss->expr))
2577 decl = se->ss->expr->symtree->n.sym->backend_decl;
2579 tmp = build_fold_indirect_ref_loc (input_location,
2581 se->expr = gfc_build_array_ref (tmp, index, decl);
2585 /* Translate access of temporary array. */
2588 gfc_conv_tmp_array_ref (gfc_se * se)
2590 se->string_length = se->ss->string_length;
2591 gfc_conv_scalarized_array_ref (se, NULL);
2592 gfc_advance_se_ss_chain (se);
2596 /* Build an array reference. se->expr already holds the array descriptor.
2597 This should be either a variable, indirect variable reference or component
2598 reference. For arrays which do not have a descriptor, se->expr will be
2600 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2603 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2616 /* Handle scalarized references separately. */
2617 if (ar->type != AR_ELEMENT)
2619 gfc_conv_scalarized_array_ref (se, ar);
2620 gfc_advance_se_ss_chain (se);
2624 index = gfc_index_zero_node;
2626 /* Calculate the offsets from all the dimensions. */
2627 for (n = 0; n < ar->dimen; n++)
2629 /* Calculate the index for this dimension. */
2630 gfc_init_se (&indexse, se);
2631 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2632 gfc_add_block_to_block (&se->pre, &indexse.pre);
2634 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2636 /* Check array bounds. */
2640 /* Evaluate the indexse.expr only once. */
2641 indexse.expr = save_expr (indexse.expr);
2644 tmp = gfc_conv_array_lbound (se->expr, n);
2645 if (sym->attr.temporary)
2647 gfc_init_se (&tmpse, se);
2648 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2649 gfc_array_index_type);
2650 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2654 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2656 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2657 "below lower bound of %%ld", n+1, sym->name);
2658 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2659 fold_convert (long_integer_type_node,
2661 fold_convert (long_integer_type_node, tmp));
2664 /* Upper bound, but not for the last dimension of assumed-size
2666 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2668 tmp = gfc_conv_array_ubound (se->expr, n);
2669 if (sym->attr.temporary)
2671 gfc_init_se (&tmpse, se);
2672 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2673 gfc_array_index_type);
2674 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2678 cond = fold_build2_loc (input_location, GT_EXPR,
2679 boolean_type_node, indexse.expr, tmp);
2680 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2681 "above upper bound of %%ld", n+1, sym->name);
2682 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2683 fold_convert (long_integer_type_node,
2685 fold_convert (long_integer_type_node, tmp));
2690 /* Multiply the index by the stride. */
2691 stride = gfc_conv_array_stride (se->expr, n);
2692 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2693 indexse.expr, stride);
2695 /* And add it to the total. */
2696 index = fold_build2_loc (input_location, PLUS_EXPR,
2697 gfc_array_index_type, index, tmp);
2700 tmp = gfc_conv_array_offset (se->expr);
2701 if (!integer_zerop (tmp))
2702 index = fold_build2_loc (input_location, PLUS_EXPR,
2703 gfc_array_index_type, index, tmp);
2705 /* Access the calculated element. */
2706 tmp = gfc_conv_array_data (se->expr);
2707 tmp = build_fold_indirect_ref (tmp);
2708 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2712 /* Generate the code to be executed immediately before entering a
2713 scalarization loop. */
2716 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2717 stmtblock_t * pblock)
2726 /* This code will be executed before entering the scalarization loop
2727 for this dimension. */
2728 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2730 if ((ss->useflags & flag) == 0)
2733 if (ss->type != GFC_SS_SECTION
2734 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2735 && ss->type != GFC_SS_COMPONENT)
2738 info = &ss->data.info;
2740 if (dim >= info->dimen)
2743 if (dim == info->dimen - 1)
2745 /* For the outermost loop calculate the offset due to any
2746 elemental dimensions. It will have been initialized with the
2747 base offset of the array. */
2750 for (i = 0; i < info->ref->u.ar.dimen; i++)
2752 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2755 gfc_init_se (&se, NULL);
2757 se.expr = info->descriptor;
2758 stride = gfc_conv_array_stride (info->descriptor, i);
2759 index = gfc_conv_array_index_offset (&se, info, i, -1,
2762 gfc_add_block_to_block (pblock, &se.pre);
2764 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2765 gfc_array_index_type,
2766 info->offset, index);
2767 info->offset = gfc_evaluate_now (info->offset, pblock);
2772 /* For the time being, the innermost loop is unconditionally on
2773 the first dimension of the scalarization loop. */
2774 gcc_assert (i == 0);
2775 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2777 /* Calculate the stride of the innermost loop. Hopefully this will
2778 allow the backend optimizers to do their stuff more effectively.
2780 info->stride0 = gfc_evaluate_now (stride, pblock);
2784 /* Add the offset for the previous loop dimension. */
2789 ar = &info->ref->u.ar;
2790 i = loop->order[dim + 1];
2798 gfc_init_se (&se, NULL);
2800 se.expr = info->descriptor;
2801 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2802 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2804 gfc_add_block_to_block (pblock, &se.pre);
2805 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2806 gfc_array_index_type, info->offset,
2808 info->offset = gfc_evaluate_now (info->offset, pblock);
2811 /* Remember this offset for the second loop. */
2812 if (dim == loop->temp_dim - 1)
2813 info->saved_offset = info->offset;
2818 /* Start a scalarized expression. Creates a scope and declares loop
2822 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2828 gcc_assert (!loop->array_parameter);
2830 for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
2832 n = loop->order[dim];
2834 gfc_start_block (&loop->code[n]);
2836 /* Create the loop variable. */
2837 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2839 if (dim < loop->temp_dim)
2843 /* Calculate values that will be constant within this loop. */
2844 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2846 gfc_start_block (pbody);
2850 /* Generates the actual loop code for a scalarization loop. */
2853 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2854 stmtblock_t * pbody)
2865 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2866 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2867 && n == loop->dimen - 1)
2869 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2870 init = make_tree_vec (1);
2871 cond = make_tree_vec (1);
2872 incr = make_tree_vec (1);
2874 /* Cycle statement is implemented with a goto. Exit statement must not
2875 be present for this loop. */
2876 exit_label = gfc_build_label_decl (NULL_TREE);
2877 TREE_USED (exit_label) = 1;
2879 /* Label for cycle statements (if needed). */
2880 tmp = build1_v (LABEL_EXPR, exit_label);
2881 gfc_add_expr_to_block (pbody, tmp);
2883 stmt = make_node (OMP_FOR);
2885 TREE_TYPE (stmt) = void_type_node;
2886 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2888 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2889 OMP_CLAUSE_SCHEDULE);
2890 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2891 = OMP_CLAUSE_SCHEDULE_STATIC;
2892 if (ompws_flags & OMPWS_NOWAIT)
2893 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2894 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2896 /* Initialize the loopvar. */
2897 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2899 OMP_FOR_INIT (stmt) = init;
2900 /* The exit condition. */
2901 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2903 loop->loopvar[n], loop->to[n]);
2904 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2905 OMP_FOR_COND (stmt) = cond;
2906 /* Increment the loopvar. */
2907 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2908 loop->loopvar[n], gfc_index_one_node);
2909 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2910 void_type_node, loop->loopvar[n], tmp);
2911 OMP_FOR_INCR (stmt) = incr;
2913 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2914 gfc_add_expr_to_block (&loop->code[n], stmt);
2918 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2919 && (loop->temp_ss == NULL);
2921 loopbody = gfc_finish_block (pbody);
2925 tmp = loop->from[n];
2926 loop->from[n] = loop->to[n];
2930 /* Initialize the loopvar. */
2931 if (loop->loopvar[n] != loop->from[n])
2932 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2934 exit_label = gfc_build_label_decl (NULL_TREE);
2936 /* Generate the loop body. */
2937 gfc_init_block (&block);
2939 /* The exit condition. */
2940 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2941 boolean_type_node, loop->loopvar[n], loop->to[n]);
2942 tmp = build1_v (GOTO_EXPR, exit_label);
2943 TREE_USED (exit_label) = 1;
2944 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2945 gfc_add_expr_to_block (&block, tmp);
2947 /* The main body. */
2948 gfc_add_expr_to_block (&block, loopbody);
2950 /* Increment the loopvar. */
2951 tmp = fold_build2_loc (input_location,
2952 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2953 gfc_array_index_type, loop->loopvar[n],
2954 gfc_index_one_node);
2956 gfc_add_modify (&block, loop->loopvar[n], tmp);
2958 /* Build the loop. */
2959 tmp = gfc_finish_block (&block);
2960 tmp = build1_v (LOOP_EXPR, tmp);
2961 gfc_add_expr_to_block (&loop->code[n], tmp);
2963 /* Add the exit label. */
2964 tmp = build1_v (LABEL_EXPR, exit_label);
2965 gfc_add_expr_to_block (&loop->code[n], tmp);
2971 /* Finishes and generates the loops for a scalarized expression. */
2974 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2979 stmtblock_t *pblock;
2983 /* Generate the loops. */
2984 for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
2986 n = loop->order[dim];
2987 gfc_trans_scalarized_loop_end (loop, n, pblock);
2988 loop->loopvar[n] = NULL_TREE;
2989 pblock = &loop->code[n];
2992 tmp = gfc_finish_block (pblock);
2993 gfc_add_expr_to_block (&loop->pre, tmp);
2995 /* Clear all the used flags. */
2996 for (ss = loop->ss; ss; ss = ss->loop_chain)
3001 /* Finish the main body of a scalarized expression, and start the secondary
3005 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3009 stmtblock_t *pblock;
3013 /* We finish as many loops as are used by the temporary. */
3014 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3016 n = loop->order[dim];
3017 gfc_trans_scalarized_loop_end (loop, n, pblock);
3018 loop->loopvar[n] = NULL_TREE;
3019 pblock = &loop->code[n];
3022 /* We don't want to finish the outermost loop entirely. */
3023 n = loop->order[loop->temp_dim - 1];
3024 gfc_trans_scalarized_loop_end (loop, n, pblock);
3026 /* Restore the initial offsets. */
3027 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3029 if ((ss->useflags & 2) == 0)
3032 if (ss->type != GFC_SS_SECTION
3033 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3034 && ss->type != GFC_SS_COMPONENT)
3037 ss->data.info.offset = ss->data.info.saved_offset;
3040 /* Restart all the inner loops we just finished. */
3041 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3043 n = loop->order[dim];
3045 gfc_start_block (&loop->code[n]);
3047 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3049 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3052 /* Start a block for the secondary copying code. */
3053 gfc_start_block (body);
3057 /* Calculate the lower bound of an array section. */
3060 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
3061 bool coarray, bool coarray_last)
3065 gfc_expr *stride = NULL;
3070 gcc_assert (ss->type == GFC_SS_SECTION);
3072 info = &ss->data.info;
3074 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3076 /* We use a zero-based index to access the vector. */
3077 info->start[dim] = gfc_index_zero_node;
3078 info->end[dim] = NULL;
3080 info->stride[dim] = gfc_index_one_node;
3084 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3085 desc = info->descriptor;
3086 start = info->ref->u.ar.start[dim];
3087 end = info->ref->u.ar.end[dim];
3089 stride = info->ref->u.ar.stride[dim];
3091 /* Calculate the start of the range. For vector subscripts this will
3092 be the range of the vector. */
3095 /* Specified section start. */
3096 gfc_init_se (&se, NULL);
3097 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3098 gfc_add_block_to_block (&loop->pre, &se.pre);
3099 info->start[dim] = se.expr;
3103 /* No lower bound specified so use the bound of the array. */
3104 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3106 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3108 /* Similarly calculate the end. Although this is not used in the
3109 scalarizer, it is needed when checking bounds and where the end
3110 is an expression with side-effects. */
3115 /* Specified section start. */
3116 gfc_init_se (&se, NULL);
3117 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3118 gfc_add_block_to_block (&loop->pre, &se.pre);
3119 info->end[dim] = se.expr;
3123 /* No upper bound specified so use the bound of the array. */
3124 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3126 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3129 /* Calculate the stride. */
3130 if (!coarray && stride == NULL)
3131 info->stride[dim] = gfc_index_one_node;
3134 gfc_init_se (&se, NULL);
3135 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3136 gfc_add_block_to_block (&loop->pre, &se.pre);
3137 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3142 /* Calculates the range start and stride for a SS chain. Also gets the
3143 descriptor and data pointer. The range of vector subscripts is the size
3144 of the vector. Array bounds are also checked. */
3147 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3155 /* Determine the rank of the loop. */
3157 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3161 case GFC_SS_SECTION:
3162 case GFC_SS_CONSTRUCTOR:
3163 case GFC_SS_FUNCTION:
3164 case GFC_SS_COMPONENT:
3165 loop->dimen = ss->data.info.dimen;
3166 loop->codimen = ss->data.info.codimen;
3169 /* As usual, lbound and ubound are exceptions!. */
3170 case GFC_SS_INTRINSIC:
3171 switch (ss->expr->value.function.isym->id)
3173 case GFC_ISYM_LBOUND:
3174 case GFC_ISYM_UBOUND:
3175 loop->dimen = ss->data.info.dimen;
3179 case GFC_ISYM_LCOBOUND:
3180 case GFC_ISYM_UCOBOUND:
3181 case GFC_ISYM_THIS_IMAGE:
3182 loop->dimen = ss->data.info.dimen;
3183 loop->codimen = ss->data.info.codimen;
3195 /* We should have determined the rank of the expression by now. If
3196 not, that's bad news. */
3197 gcc_assert (loop->dimen + loop->codimen != 0);
3199 /* Loop over all the SS in the chain. */
3200 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3202 if (ss->expr && ss->expr->shape && !ss->shape)
3203 ss->shape = ss->expr->shape;
3207 case GFC_SS_SECTION:
3208 /* Get the descriptor for the array. */
3209 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3211 for (n = 0; n < ss->data.info.dimen; n++)
3212 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3214 for (n = ss->data.info.dimen;
3215 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3216 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3217 n == ss->data.info.dimen
3218 + ss->data.info.codimen -1);
3222 case GFC_SS_INTRINSIC:
3223 switch (ss->expr->value.function.isym->id)
3225 /* Fall through to supply start and stride. */
3226 case GFC_ISYM_LBOUND:
3227 case GFC_ISYM_UBOUND:
3228 case GFC_ISYM_LCOBOUND:
3229 case GFC_ISYM_UCOBOUND:
3230 case GFC_ISYM_THIS_IMAGE:
3237 case GFC_SS_CONSTRUCTOR:
3238 case GFC_SS_FUNCTION:
3239 for (n = 0; n < ss->data.info.dimen; n++)
3241 ss->data.info.start[n] = gfc_index_zero_node;
3242 ss->data.info.end[n] = gfc_index_zero_node;
3243 ss->data.info.stride[n] = gfc_index_one_node;
3252 /* The rest is just runtime bound checking. */
3253 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3256 tree lbound, ubound;
3258 tree size[GFC_MAX_DIMENSIONS];
3259 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3264 gfc_start_block (&block);
3266 for (n = 0; n < loop->dimen; n++)
3267 size[n] = NULL_TREE;
3269 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3273 if (ss->type != GFC_SS_SECTION)
3276 /* Catch allocatable lhs in f2003. */
3277 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3280 gfc_start_block (&inner);
3282 /* TODO: range checking for mapped dimensions. */
3283 info = &ss->data.info;
3285 /* This code only checks ranges. Elemental and vector
3286 dimensions are checked later. */
3287 for (n = 0; n < loop->dimen; n++)
3292 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3295 if (dim == info->ref->u.ar.dimen - 1
3296 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3297 check_upper = false;
3301 /* Zero stride is not allowed. */
3302 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3303 info->stride[dim], gfc_index_zero_node);
3304 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3305 "of array '%s'", dim + 1, ss->expr->symtree->name);
3306 gfc_trans_runtime_check (true, false, tmp, &inner,
3307 &ss->expr->where, msg);
3310 desc = ss->data.info.descriptor;
3312 /* This is the run-time equivalent of resolve.c's
3313 check_dimension(). The logical is more readable there
3314 than it is here, with all the trees. */
3315 lbound = gfc_conv_array_lbound (desc, dim);
3316 end = info->end[dim];
3318 ubound = gfc_conv_array_ubound (desc, dim);
3322 /* non_zerosized is true when the selected range is not
3324 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3325 boolean_type_node, info->stride[dim],
3326 gfc_index_zero_node);
3327 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3328 info->start[dim], end);
3329 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3330 boolean_type_node, stride_pos, tmp);
3332 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3334 info->stride[dim], gfc_index_zero_node);
3335 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3336 info->start[dim], end);
3337 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3340 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3342 stride_pos, stride_neg);
3344 /* Check the start of the range against the lower and upper
3345 bounds of the array, if the range is not empty.
3346 If upper bound is present, include both bounds in the
3350 tmp = fold_build2_loc (input_location, LT_EXPR,
3352 info->start[dim], lbound);
3353 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3355 non_zerosized, tmp);
3356 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3358 info->start[dim], ubound);
3359 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3361 non_zerosized, tmp2);
3362 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3363 "outside of expected range (%%ld:%%ld)",
3364 dim + 1, ss->expr->symtree->name);
3365 gfc_trans_runtime_check (true, false, tmp, &inner,
3366 &ss->expr->where, msg,
3367 fold_convert (long_integer_type_node, info->start[dim]),
3368 fold_convert (long_integer_type_node, lbound),
3369 fold_convert (long_integer_type_node, ubound));
3370 gfc_trans_runtime_check (true, false, tmp2, &inner,
3371 &ss->expr->where, msg,
3372 fold_convert (long_integer_type_node, info->start[dim]),
3373 fold_convert (long_integer_type_node, lbound),
3374 fold_convert (long_integer_type_node, ubound));
3379 tmp = fold_build2_loc (input_location, LT_EXPR,
3381 info->start[dim], lbound);
3382 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3383 boolean_type_node, non_zerosized, tmp);
3384 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3385 "below lower bound of %%ld",
3386 dim + 1, ss->expr->symtree->name);
3387 gfc_trans_runtime_check (true, false, tmp, &inner,
3388 &ss->expr->where, msg,
3389 fold_convert (long_integer_type_node, info->start[dim]),
3390 fold_convert (long_integer_type_node, lbound));
3394 /* Compute the last element of the range, which is not
3395 necessarily "end" (think 0:5:3, which doesn't contain 5)
3396 and check it against both lower and upper bounds. */
3398 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3399 gfc_array_index_type, end,
3401 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3402 gfc_array_index_type, tmp,
3404 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3405 gfc_array_index_type, end, tmp);
3406 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3407 boolean_type_node, tmp, lbound);
3408 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3409 boolean_type_node, non_zerosized, tmp2);
3412 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3413 boolean_type_node, tmp, ubound);
3414 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3415 boolean_type_node, non_zerosized, tmp3);
3416 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3417 "outside of expected range (%%ld:%%ld)",
3418 dim + 1, ss->expr->symtree->name);
3419 gfc_trans_runtime_check (true, false, tmp2, &inner,
3420 &ss->expr->where, msg,
3421 fold_convert (long_integer_type_node, tmp),
3422 fold_convert (long_integer_type_node, ubound),
3423 fold_convert (long_integer_type_node, lbound));
3424 gfc_trans_runtime_check (true, false, tmp3, &inner,
3425 &ss->expr->where, msg,
3426 fold_convert (long_integer_type_node, tmp),
3427 fold_convert (long_integer_type_node, ubound),
3428 fold_convert (long_integer_type_node, lbound));
3433 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3434 "below lower bound of %%ld",
3435 dim + 1, ss->expr->symtree->name);
3436 gfc_trans_runtime_check (true, false, tmp2, &inner,
3437 &ss->expr->where, msg,
3438 fold_convert (long_integer_type_node, tmp),
3439 fold_convert (long_integer_type_node, lbound));
3443 /* Check the section sizes match. */
3444 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3445 gfc_array_index_type, end,
3447 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3448 gfc_array_index_type, tmp,
3450 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3451 gfc_array_index_type,
3452 gfc_index_one_node, tmp);
3453 tmp = fold_build2_loc (input_location, MAX_EXPR,
3454 gfc_array_index_type, tmp,
3455 build_int_cst (gfc_array_index_type, 0));
3456 /* We remember the size of the first section, and check all the
3457 others against this. */
3460 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3461 boolean_type_node, tmp, size[n]);
3462 asprintf (&msg, "Array bound mismatch for dimension %d "
3463 "of array '%s' (%%ld/%%ld)",
3464 dim + 1, ss->expr->symtree->name);
3466 gfc_trans_runtime_check (true, false, tmp3, &inner,
3467 &ss->expr->where, msg,
3468 fold_convert (long_integer_type_node, tmp),
3469 fold_convert (long_integer_type_node, size[n]));
3474 size[n] = gfc_evaluate_now (tmp, &inner);
3477 tmp = gfc_finish_block (&inner);
3479 /* For optional arguments, only check bounds if the argument is
3481 if (ss->expr->symtree->n.sym->attr.optional
3482 || ss->expr->symtree->n.sym->attr.not_always_present)
3483 tmp = build3_v (COND_EXPR,
3484 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3485 tmp, build_empty_stmt (input_location));
3487 gfc_add_expr_to_block (&block, tmp);
3491 tmp = gfc_finish_block (&block);
3492 gfc_add_expr_to_block (&loop->pre, tmp);
3496 /* Return true if both symbols could refer to the same data object. Does
3497 not take account of aliasing due to equivalence statements. */
3500 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3501 bool lsym_target, bool rsym_pointer, bool rsym_target)
3503 /* Aliasing isn't possible if the symbols have different base types. */
3504 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3507 /* Pointers can point to other pointers and target objects. */
3509 if ((lsym_pointer && (rsym_pointer || rsym_target))
3510 || (rsym_pointer && (lsym_pointer || lsym_target)))
3513 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3514 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3516 if (lsym_target && rsym_target
3517 && ((lsym->attr.dummy && !lsym->attr.contiguous
3518 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3519 || (rsym->attr.dummy && !rsym->attr.contiguous
3520 && (!rsym->attr.dimension
3521 || rsym->as->type == AS_ASSUMED_SHAPE))))
3528 /* Return true if the two SS could be aliased, i.e. both point to the same data
3530 /* TODO: resolve aliases based on frontend expressions. */
3533 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3539 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3541 lsym = lss->expr->symtree->n.sym;
3542 rsym = rss->expr->symtree->n.sym;
3544 lsym_pointer = lsym->attr.pointer;
3545 lsym_target = lsym->attr.target;
3546 rsym_pointer = rsym->attr.pointer;
3547 rsym_target = rsym->attr.target;
3549 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3550 rsym_pointer, rsym_target))
3553 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3554 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3557 /* For derived types we must check all the component types. We can ignore
3558 array references as these will have the same base type as the previous
3560 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3562 if (lref->type != REF_COMPONENT)
3565 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3566 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3568 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3569 rsym_pointer, rsym_target))
3572 if ((lsym_pointer && (rsym_pointer || rsym_target))
3573 || (rsym_pointer && (lsym_pointer || lsym_target)))
3575 if (gfc_compare_types (&lref->u.c.component->ts,
3580 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3583 if (rref->type != REF_COMPONENT)
3586 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3587 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3589 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3590 lsym_pointer, lsym_target,
3591 rsym_pointer, rsym_target))
3594 if ((lsym_pointer && (rsym_pointer || rsym_target))
3595 || (rsym_pointer && (lsym_pointer || lsym_target)))
3597 if (gfc_compare_types (&lref->u.c.component->ts,
3598 &rref->u.c.sym->ts))
3600 if (gfc_compare_types (&lref->u.c.sym->ts,
3601 &rref->u.c.component->ts))
3603 if (gfc_compare_types (&lref->u.c.component->ts,
3604 &rref->u.c.component->ts))
3610 lsym_pointer = lsym->attr.pointer;
3611 lsym_target = lsym->attr.target;
3612 lsym_pointer = lsym->attr.pointer;
3613 lsym_target = lsym->attr.target;
3615 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3617 if (rref->type != REF_COMPONENT)
3620 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3621 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3623 if (symbols_could_alias (rref->u.c.sym, lsym,
3624 lsym_pointer, lsym_target,
3625 rsym_pointer, rsym_target))
3628 if ((lsym_pointer && (rsym_pointer || rsym_target))
3629 || (rsym_pointer && (lsym_pointer || lsym_target)))
3631 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3640 /* Resolve array data dependencies. Creates a temporary if required. */
3641 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3645 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3654 loop->temp_ss = NULL;
3656 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3658 if (ss->type != GFC_SS_SECTION)
3661 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3663 if (gfc_could_be_alias (dest, ss)
3664 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3672 lref = dest->expr->ref;
3673 rref = ss->expr->ref;
3675 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3680 for (i = 0; i < dest->data.info.dimen; i++)
3681 for (j = 0; j < ss->data.info.dimen; j++)
3683 && dest->data.info.dim[i] == ss->data.info.dim[j])
3685 /* If we don't access array elements in the same order,
3686 there is a dependency. */
3691 /* TODO : loop shifting. */
3694 /* Mark the dimensions for LOOP SHIFTING */
3695 for (n = 0; n < loop->dimen; n++)
3697 int dim = dest->data.info.dim[n];
3699 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3701 else if (! gfc_is_same_range (&lref->u.ar,
3702 &rref->u.ar, dim, 0))
3706 /* Put all the dimensions with dependencies in the
3709 for (n = 0; n < loop->dimen; n++)
3711 gcc_assert (loop->order[n] == n);
3713 loop->order[dim++] = n;
3715 for (n = 0; n < loop->dimen; n++)
3718 loop->order[dim++] = n;
3721 gcc_assert (dim == loop->dimen);
3732 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3733 if (GFC_ARRAY_TYPE_P (base_type)
3734 || GFC_DESCRIPTOR_TYPE_P (base_type))
3735 base_type = gfc_get_element_type (base_type);
3736 loop->temp_ss = gfc_get_ss ();
3737 loop->temp_ss->type = GFC_SS_TEMP;
3738 loop->temp_ss->data.temp.type = base_type;
3739 loop->temp_ss->string_length = dest->string_length;
3740 loop->temp_ss->data.temp.dimen = loop->dimen;
3741 loop->temp_ss->data.temp.codimen = loop->codimen;
3742 loop->temp_ss->next = gfc_ss_terminator;
3743 gfc_add_ss_to_loop (loop, loop->temp_ss);
3746 loop->temp_ss = NULL;
3750 /* Initialize the scalarization loop. Creates the loop variables. Determines
3751 the range of the loop variables. Creates a temporary if required.
3752 Calculates how to transform from loop variables to array indices for each
3753 expression. Also generates code for scalar expressions which have been
3754 moved outside the loop. */
3757 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3759 int n, dim, spec_dim;
3761 gfc_ss_info *specinfo;
3764 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3765 bool dynamic[GFC_MAX_DIMENSIONS];
3770 for (n = 0; n < loop->dimen + loop->codimen; n++)
3774 /* We use one SS term, and use that to determine the bounds of the
3775 loop for this dimension. We try to pick the simplest term. */
3776 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3778 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3781 info = &ss->data.info;
3784 if (loopspec[n] != NULL)
3786 specinfo = &loopspec[n]->data.info;
3787 spec_dim = specinfo->dim[n];
3791 /* Silence unitialized warnings. */
3798 gcc_assert (ss->shape[dim]);
3799 /* The frontend has worked out the size for us. */
3801 || !loopspec[n]->shape
3802 || !integer_zerop (specinfo->start[spec_dim]))
3803 /* Prefer zero-based descriptors if possible. */
3808 if (ss->type == GFC_SS_CONSTRUCTOR)
3810 gfc_constructor_base base;
3811 /* An unknown size constructor will always be rank one.
3812 Higher rank constructors will either have known shape,
3813 or still be wrapped in a call to reshape. */
3814 gcc_assert (loop->dimen == 1);
3816 /* Always prefer to use the constructor bounds if the size
3817 can be determined at compile time. Prefer not to otherwise,
3818 since the general case involves realloc, and it's better to
3819 avoid that overhead if possible. */
3820 base = ss->expr->value.constructor;
3821 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3822 if (!dynamic[n] || !loopspec[n])
3827 /* TODO: Pick the best bound if we have a choice between a
3828 function and something else. */
3829 if (ss->type == GFC_SS_FUNCTION)
3835 /* Avoid using an allocatable lhs in an assignment, since
3836 there might be a reallocation coming. */
3837 if (loopspec[n] && ss->is_alloc_lhs)
3840 if (ss->type != GFC_SS_SECTION)
3845 /* Criteria for choosing a loop specifier (most important first):
3846 doesn't need realloc
3852 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3853 || n >= loop->dimen)
3855 else if (integer_onep (info->stride[dim])
3856 && !integer_onep (specinfo->stride[spec_dim]))
3858 else if (INTEGER_CST_P (info->stride[dim])
3859 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3861 else if (INTEGER_CST_P (info->start[dim])
3862 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3864 /* We don't work out the upper bound.
3865 else if (INTEGER_CST_P (info->finish[n])
3866 && ! INTEGER_CST_P (specinfo->finish[n]))
3867 loopspec[n] = ss; */
3870 /* We should have found the scalarization loop specifier. If not,
3872 gcc_assert (loopspec[n]);
3874 info = &loopspec[n]->data.info;
3877 /* Set the extents of this range. */
3878 cshape = loopspec[n]->shape;
3879 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
3880 && INTEGER_CST_P (info->stride[dim]))
3882 loop->from[n] = info->start[dim];
3883 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3884 mpz_sub_ui (i, i, 1);
3885 /* To = from + (size - 1) * stride. */
3886 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3887 if (!integer_onep (info->stride[dim]))
3888 tmp = fold_build2_loc (input_location, MULT_EXPR,
3889 gfc_array_index_type, tmp,
3891 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3892 gfc_array_index_type,
3893 loop->from[n], tmp);
3897 loop->from[n] = info->start[dim];
3898 switch (loopspec[n]->type)
3900 case GFC_SS_CONSTRUCTOR:
3901 /* The upper bound is calculated when we expand the
3903 gcc_assert (loop->to[n] == NULL_TREE);
3906 case GFC_SS_SECTION:
3907 /* Use the end expression if it exists and is not constant,
3908 so that it is only evaluated once. */
3909 loop->to[n] = info->end[dim];
3912 case GFC_SS_FUNCTION:
3913 /* The loop bound will be set when we generate the call. */
3914 gcc_assert (loop->to[n] == NULL_TREE);
3922 /* Transform everything so we have a simple incrementing variable. */
3923 if (n < loop->dimen && integer_onep (info->stride[dim]))
3924 info->delta[dim] = gfc_index_zero_node;
3925 else if (n < loop->dimen)
3927 /* Set the delta for this section. */
3928 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3929 /* Number of iterations is (end - start + step) / step.
3930 with start = 0, this simplifies to
3932 for (i = 0; i<=last; i++){...}; */
3933 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3934 gfc_array_index_type, loop->to[n],
3936 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3937 gfc_array_index_type, tmp, info->stride[dim]);
3938 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3939 tmp, build_int_cst (gfc_array_index_type, -1));
3940 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3941 /* Make the loop variable start at 0. */
3942 loop->from[n] = gfc_index_zero_node;
3946 /* Add all the scalar code that can be taken out of the loops.
3947 This may include calculating the loop bounds, so do it before
3948 allocating the temporary. */
3949 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3951 /* If we want a temporary then create it. */
3952 if (loop->temp_ss != NULL)
3954 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3956 /* Make absolutely sure that this is a complete type. */
3957 if (loop->temp_ss->string_length)
3958 loop->temp_ss->data.temp.type
3959 = gfc_get_character_type_len_for_eltype
3960 (TREE_TYPE (loop->temp_ss->data.temp.type),
3961 loop->temp_ss->string_length);
3963 tmp = loop->temp_ss->data.temp.type;
3964 n = loop->temp_ss->data.temp.dimen;
3965 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3966 loop->temp_ss->type = GFC_SS_SECTION;
3967 loop->temp_ss->data.info.dimen = n;
3969 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3970 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3971 loop->temp_ss->data.info.dim[n] = n;
3973 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3974 &loop->temp_ss->data.info, tmp, NULL_TREE,
3975 false, true, false, where);
3978 for (n = 0; n < loop->temp_dim; n++)
3979 loopspec[loop->order[n]] = NULL;
3983 /* For array parameters we don't have loop variables, so don't calculate the
3985 if (loop->array_parameter)
3988 /* Calculate the translation from loop variables to array indices. */
3989 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3991 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3992 && ss->type != GFC_SS_CONSTRUCTOR)
3996 info = &ss->data.info;
3998 for (n = 0; n < info->dimen; n++)
4000 /* If we are specifying the range the delta is already set. */
4001 if (loopspec[n] != ss)
4003 dim = ss->data.info.dim[n];
4005 /* Calculate the offset relative to the loop variable.
4006 First multiply by the stride. */
4007 tmp = loop->from[n];
4008 if (!integer_onep (info->stride[dim]))
4009 tmp = fold_build2_loc (input_location, MULT_EXPR,
4010 gfc_array_index_type,
4011 tmp, info->stride[dim]);
4013 /* Then subtract this from our starting value. */
4014 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4015 gfc_array_index_type,
4016 info->start[dim], tmp);
4018 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4025 /* Calculate the size of a given array dimension from the bounds. This
4026 is simply (ubound - lbound + 1) if this expression is positive
4027 or 0 if it is negative (pick either one if it is zero). Optionally
4028 (if or_expr is present) OR the (expression != 0) condition to it. */
4031 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4036 /* Calculate (ubound - lbound + 1). */
4037 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4039 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4040 gfc_index_one_node);
4042 /* Check whether the size for this dimension is negative. */
4043 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4044 gfc_index_zero_node);
4045 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4046 gfc_index_zero_node, res);
4048 /* Build OR expression. */
4050 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4051 boolean_type_node, *or_expr, cond);
4057 /* For an array descriptor, get the total number of elements. This is just
4058 the product of the extents along all dimensions. */
4061 gfc_conv_descriptor_size (tree desc, int rank)
4066 res = gfc_index_one_node;
4068 for (dim = 0; dim < rank; ++dim)
4074 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4075 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4077 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4078 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4086 /* Helper function for marking a boolean expression tree as unlikely. */
4089 gfc_unlikely (tree cond)
4093 cond = fold_convert (long_integer_type_node, cond);
4094 tmp = build_zero_cst (long_integer_type_node);
4095 cond = build_call_expr_loc (input_location,
4096 built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
4097 cond = fold_convert (boolean_type_node, cond);
4101 /* Fills in an array descriptor, and returns the size of the array.
4102 The size will be a simple_val, ie a variable or a constant. Also
4103 calculates the offset of the base. The pointer argument overflow,
4104 which should be of integer type, will increase in value if overflow
4105 occurs during the size calculation. Returns the size of the array.
4109 for (n = 0; n < rank; n++)
4111 a.lbound[n] = specified_lower_bound;
4112 offset = offset + a.lbond[n] * stride;
4114 a.ubound[n] = specified_upper_bound;
4115 a.stride[n] = stride;
4116 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4117 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4118 stride = stride * size;
4120 element_size = sizeof (array element);
4121 stride = (size_t) stride;
4122 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4123 stride = stride * element_size;
4129 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4130 gfc_expr ** lower, gfc_expr ** upper,
4131 stmtblock_t * pblock, tree * overflow)
4144 stmtblock_t thenblock;
4145 stmtblock_t elseblock;
4150 type = TREE_TYPE (descriptor);
4152 stride = gfc_index_one_node;
4153 offset = gfc_index_zero_node;
4155 /* Set the dtype. */
4156 tmp = gfc_conv_descriptor_dtype (descriptor);
4157 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4159 or_expr = boolean_false_node;
4161 for (n = 0; n < rank; n++)
4166 /* We have 3 possibilities for determining the size of the array:
4167 lower == NULL => lbound = 1, ubound = upper[n]
4168 upper[n] = NULL => lbound = 1, ubound = lower[n]
4169 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4172 /* Set lower bound. */
4173 gfc_init_se (&se, NULL);
4175 se.expr = gfc_index_one_node;
4178 gcc_assert (lower[n]);
4181 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4182 gfc_add_block_to_block (pblock, &se.pre);
4186 se.expr = gfc_index_one_node;
4190 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4192 conv_lbound = se.expr;
4194 /* Work out the offset for this component. */
4195 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4197 offset = fold_build2_loc (input_location, MINUS_EXPR,
4198 gfc_array_index_type, offset, tmp);
4200 /* Set upper bound. */
4201 gfc_init_se (&se, NULL);
4202 gcc_assert (ubound);
4203 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4204 gfc_add_block_to_block (pblock, &se.pre);
4206 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4207 gfc_rank_cst[n], se.expr);
4208 conv_ubound = se.expr;
4210 /* Store the stride. */
4211 gfc_conv_descriptor_stride_set (pblock, descriptor,
4212 gfc_rank_cst[n], stride);
4214 /* Calculate size and check whether extent is negative. */
4215 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4216 size = gfc_evaluate_now (size, pblock);
4218 /* Check whether multiplying the stride by the number of
4219 elements in this dimension would overflow. We must also check
4220 whether the current dimension has zero size in order to avoid
4223 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4224 gfc_array_index_type,
4225 fold_convert (gfc_array_index_type,
4226 TYPE_MAX_VALUE (gfc_array_index_type)),
4228 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4229 boolean_type_node, tmp, stride));
4230 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4231 integer_one_node, integer_zero_node);
4232 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4233 boolean_type_node, size,
4234 gfc_index_zero_node));
4235 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4236 integer_zero_node, tmp);
4237 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4239 *overflow = gfc_evaluate_now (tmp, pblock);
4241 /* Multiply the stride by the number of elements in this dimension. */
4242 stride = fold_build2_loc (input_location, MULT_EXPR,
4243 gfc_array_index_type, stride, size);
4244 stride = gfc_evaluate_now (stride, pblock);
4247 for (n = rank; n < rank + corank; n++)
4251 /* Set lower bound. */
4252 gfc_init_se (&se, NULL);
4253 if (lower == NULL || lower[n] == NULL)
4255 gcc_assert (n == rank + corank - 1);
4256 se.expr = gfc_index_one_node;
4260 if (ubound || n == rank + corank - 1)
4262 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4263 gfc_add_block_to_block (pblock, &se.pre);
4267 se.expr = gfc_index_one_node;
4271 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4274 if (n < rank + corank - 1)
4276 gfc_init_se (&se, NULL);
4277 gcc_assert (ubound);
4278 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4279 gfc_add_block_to_block (pblock, &se.pre);
4280 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4281 gfc_rank_cst[n], se.expr);
4285 /* The stride is the number of elements in the array, so multiply by the
4286 size of an element to get the total size. */
4287 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4288 /* Convert to size_t. */
4289 element_size = fold_convert (size_type_node, tmp);
4290 stride = fold_convert (size_type_node, stride);
4292 /* First check for overflow. Since an array of type character can
4293 have zero element_size, we must check for that before
4295 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4297 TYPE_MAX_VALUE (size_type_node), element_size);
4298 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4299 boolean_type_node, tmp, stride));
4300 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4301 integer_one_node, integer_zero_node);
4302 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4303 boolean_type_node, element_size,
4304 build_int_cst (size_type_node, 0)));
4305 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4306 integer_zero_node, tmp);
4307 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4309 *overflow = gfc_evaluate_now (tmp, pblock);
4311 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4312 stride, element_size);
4314 if (poffset != NULL)
4316 offset = gfc_evaluate_now (offset, pblock);
4320 if (integer_zerop (or_expr))
4322 if (integer_onep (or_expr))
4323 return build_int_cst (size_type_node, 0);
4325 var = gfc_create_var (TREE_TYPE (size), "size");
4326 gfc_start_block (&thenblock);
4327 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4328 thencase = gfc_finish_block (&thenblock);
4330 gfc_start_block (&elseblock);
4331 gfc_add_modify (&elseblock, var, size);
4332 elsecase = gfc_finish_block (&elseblock);
4334 tmp = gfc_evaluate_now (or_expr, pblock);
4335 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4336 gfc_add_expr_to_block (pblock, tmp);
4342 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4343 the work for an ALLOCATE statement. */
4347 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4355 tree overflow; /* Boolean storing whether size calculation overflows. */
4358 stmtblock_t elseblock;
4361 gfc_ref *ref, *prev_ref = NULL;
4362 bool allocatable_array, coarray;
4366 /* Find the last reference in the chain. */
4367 while (ref && ref->next != NULL)
4369 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4370 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4375 if (ref == NULL || ref->type != REF_ARRAY)
4380 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4381 coarray = expr->symtree->n.sym->attr.codimension;
4385 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4386 coarray = prev_ref->u.c.component->attr.codimension;
4389 /* Return if this is a scalar coarray. */
4390 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4391 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4393 gcc_assert (coarray);
4397 /* Figure out the size of the array. */
4398 switch (ref->u.ar.type)
4404 upper = ref->u.ar.start;
4410 lower = ref->u.ar.start;
4411 upper = ref->u.ar.end;
4415 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4417 lower = ref->u.ar.as->lower;
4418 upper = ref->u.ar.as->upper;
4426 overflow = integer_zero_node;
4427 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4428 ref->u.ar.as->corank, &offset, lower, upper,
4429 &se->pre, &overflow);
4431 var_overflow = gfc_create_var (integer_type_node, "overflow");
4432 gfc_add_modify (&se->pre, var_overflow, overflow);
4434 /* Generate the block of code handling overflow. */
4435 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
4436 ("Integer overflow when calculating the amount of "
4437 "memory to allocate"));
4438 error = build_call_expr_loc (input_location,
4439 gfor_fndecl_runtime_error, 1, msg);
4441 if (pstat != NULL_TREE && !integer_zerop (pstat))
4443 /* Set the status variable if it's present. */
4444 stmtblock_t set_status_block;
4445 tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
4447 gfc_start_block (&set_status_block);
4448 gfc_add_modify (&set_status_block,
4449 fold_build1_loc (input_location, INDIRECT_REF,
4450 status_type, pstat),
4451 build_int_cst (status_type, LIBERROR_ALLOCATION));
4453 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4454 pstat, build_int_cst (TREE_TYPE (pstat), 0));
4455 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
4456 error, gfc_finish_block (&set_status_block));
4459 gfc_start_block (&elseblock);
4461 /* Allocate memory to store the data. */
4462 pointer = gfc_conv_descriptor_data_get (se->expr);
4463 STRIP_NOPS (pointer);
4465 /* The allocate_array variants take the old pointer as first argument. */
4466 if (allocatable_array)
4467 tmp = gfc_allocate_array_with_status (&elseblock, pointer, size, pstat, expr);
4469 tmp = gfc_allocate_with_status (&elseblock, size, pstat);
4470 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4473 gfc_add_expr_to_block (&elseblock, tmp);
4475 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4476 var_overflow, integer_zero_node));
4477 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4478 error, gfc_finish_block (&elseblock));
4480 gfc_add_expr_to_block (&se->pre, tmp);
4482 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4484 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4485 && expr->ts.u.derived->attr.alloc_comp)
4487 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4488 ref->u.ar.as->rank);
4489 gfc_add_expr_to_block (&se->pre, tmp);
4496 /* Deallocate an array variable. Also used when an allocated variable goes
4501 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4507 gfc_start_block (&block);
4508 /* Get a pointer to the data. */
4509 var = gfc_conv_descriptor_data_get (descriptor);
4512 /* Parameter is the address of the data component. */
4513 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4514 gfc_add_expr_to_block (&block, tmp);
4516 /* Zero the data pointer. */
4517 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4518 var, build_int_cst (TREE_TYPE (var), 0));
4519 gfc_add_expr_to_block (&block, tmp);
4521 return gfc_finish_block (&block);
4525 /* Create an array constructor from an initialization expression.
4526 We assume the frontend already did any expansions and conversions. */
4529 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4535 unsigned HOST_WIDE_INT lo;
4537 VEC(constructor_elt,gc) *v = NULL;
4539 switch (expr->expr_type)
4542 case EXPR_STRUCTURE:
4543 /* A single scalar or derived type value. Create an array with all
4544 elements equal to that value. */
4545 gfc_init_se (&se, NULL);
4547 if (expr->expr_type == EXPR_CONSTANT)
4548 gfc_conv_constant (&se, expr);
4550 gfc_conv_structure (&se, expr, 1);
4552 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4553 gcc_assert (tmp && INTEGER_CST_P (tmp));
4554 hi = TREE_INT_CST_HIGH (tmp);
4555 lo = TREE_INT_CST_LOW (tmp);
4559 /* This will probably eat buckets of memory for large arrays. */
4560 while (hi != 0 || lo != 0)
4562 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4570 /* Create a vector of all the elements. */
4571 for (c = gfc_constructor_first (expr->value.constructor);
4572 c; c = gfc_constructor_next (c))
4576 /* Problems occur when we get something like
4577 integer :: a(lots) = (/(i, i=1, lots)/) */
4578 gfc_fatal_error ("The number of elements in the array constructor "
4579 "at %L requires an increase of the allowed %d "
4580 "upper limit. See -fmax-array-constructor "
4581 "option", &expr->where,
4582 gfc_option.flag_max_array_constructor);
4585 if (mpz_cmp_si (c->offset, 0) != 0)
4586 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4590 gfc_init_se (&se, NULL);
4591 switch (c->expr->expr_type)
4594 gfc_conv_constant (&se, c->expr);
4595 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4598 case EXPR_STRUCTURE:
4599 gfc_conv_structure (&se, c->expr, 1);
4600 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4605 /* Catch those occasional beasts that do not simplify
4606 for one reason or another, assuming that if they are
4607 standard defying the frontend will catch them. */
4608 gfc_conv_expr (&se, c->expr);
4609 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4616 return gfc_build_null_descriptor (type);
4622 /* Create a constructor from the list of elements. */
4623 tmp = build_constructor (type, v);
4624 TREE_CONSTANT (tmp) = 1;
4629 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4630 returns the size (in elements) of the array. */
4633 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4634 stmtblock_t * pblock)
4649 size = gfc_index_one_node;
4650 offset = gfc_index_zero_node;
4651 for (dim = 0; dim < as->rank; dim++)
4653 /* Evaluate non-constant array bound expressions. */
4654 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4655 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4657 gfc_init_se (&se, NULL);
4658 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4659 gfc_add_block_to_block (pblock, &se.pre);
4660 gfc_add_modify (pblock, lbound, se.expr);
4662 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4663 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4665 gfc_init_se (&se, NULL);
4666 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4667 gfc_add_block_to_block (pblock, &se.pre);
4668 gfc_add_modify (pblock, ubound, se.expr);
4670 /* The offset of this dimension. offset = offset - lbound * stride. */
4671 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4673 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4676 /* The size of this dimension, and the stride of the next. */
4677 if (dim + 1 < as->rank)
4678 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4680 stride = GFC_TYPE_ARRAY_SIZE (type);
4682 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4684 /* Calculate stride = size * (ubound + 1 - lbound). */
4685 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4686 gfc_array_index_type,
4687 gfc_index_one_node, lbound);
4688 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4689 gfc_array_index_type, ubound, tmp);
4690 tmp = fold_build2_loc (input_location, MULT_EXPR,
4691 gfc_array_index_type, size, tmp);
4693 gfc_add_modify (pblock, stride, tmp);
4695 stride = gfc_evaluate_now (tmp, pblock);
4697 /* Make sure that negative size arrays are translated
4698 to being zero size. */
4699 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4700 stride, gfc_index_zero_node);
4701 tmp = fold_build3_loc (input_location, COND_EXPR,
4702 gfc_array_index_type, tmp,
4703 stride, gfc_index_zero_node);
4704 gfc_add_modify (pblock, stride, tmp);
4709 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4711 /* Evaluate non-constant array bound expressions. */
4712 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4713 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4715 gfc_init_se (&se, NULL);
4716 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4717 gfc_add_block_to_block (pblock, &se.pre);
4718 gfc_add_modify (pblock, lbound, se.expr);
4720 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4721 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4723 gfc_init_se (&se, NULL);
4724 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4725 gfc_add_block_to_block (pblock, &se.pre);
4726 gfc_add_modify (pblock, ubound, se.expr);
4729 gfc_trans_vla_type_sizes (sym, pblock);
4736 /* Generate code to initialize/allocate an array variable. */
4739 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4740 gfc_wrapped_block * block)
4749 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4751 /* Do nothing for USEd variables. */
4752 if (sym->attr.use_assoc)
4755 type = TREE_TYPE (decl);
4756 gcc_assert (GFC_ARRAY_TYPE_P (type));
4757 onstack = TREE_CODE (type) != POINTER_TYPE;
4759 gfc_start_block (&init);
4761 /* Evaluate character string length. */
4762 if (sym->ts.type == BT_CHARACTER
4763 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4765 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4767 gfc_trans_vla_type_sizes (sym, &init);
4769 /* Emit a DECL_EXPR for this variable, which will cause the
4770 gimplifier to allocate storage, and all that good stuff. */
4771 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4772 gfc_add_expr_to_block (&init, tmp);
4777 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4781 type = TREE_TYPE (type);
4783 gcc_assert (!sym->attr.use_assoc);
4784 gcc_assert (!TREE_STATIC (decl));
4785 gcc_assert (!sym->module);
4787 if (sym->ts.type == BT_CHARACTER
4788 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4789 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4791 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4793 /* Don't actually allocate space for Cray Pointees. */
4794 if (sym->attr.cray_pointee)
4796 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4797 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4799 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4803 /* The size is the number of elements in the array, so multiply by the
4804 size of an element to get the total size. */
4805 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4806 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4807 size, fold_convert (gfc_array_index_type, tmp));
4809 /* Allocate memory to hold the data. */
4810 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4811 gfc_add_modify (&init, decl, tmp);
4813 /* Set offset of the array. */
4814 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4815 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4817 /* Automatic arrays should not have initializers. */
4818 gcc_assert (!sym->value);
4820 /* Free the temporary. */
4821 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4823 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4827 /* Generate entry and exit code for g77 calling convention arrays. */
4830 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4840 gfc_save_backend_locus (&loc);
4841 gfc_set_backend_locus (&sym->declared_at);
4843 /* Descriptor type. */
4844 parm = sym->backend_decl;
4845 type = TREE_TYPE (parm);
4846 gcc_assert (GFC_ARRAY_TYPE_P (type));
4848 gfc_start_block (&init);
4850 if (sym->ts.type == BT_CHARACTER
4851 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4852 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4854 /* Evaluate the bounds of the array. */
4855 gfc_trans_array_bounds (type, sym, &offset, &init);
4857 /* Set the offset. */
4858 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4859 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4861 /* Set the pointer itself if we aren't using the parameter directly. */
4862 if (TREE_CODE (parm) != PARM_DECL)
4864 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4865 gfc_add_modify (&init, parm, tmp);
4867 stmt = gfc_finish_block (&init);
4869 gfc_restore_backend_locus (&loc);
4871 /* Add the initialization code to the start of the function. */
4873 if (sym->attr.optional || sym->attr.not_always_present)
4875 tmp = gfc_conv_expr_present (sym);
4876 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4879 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4883 /* Modify the descriptor of an array parameter so that it has the
4884 correct lower bound. Also move the upper bound accordingly.
4885 If the array is not packed, it will be copied into a temporary.
4886 For each dimension we set the new lower and upper bounds. Then we copy the
4887 stride and calculate the offset for this dimension. We also work out
4888 what the stride of a packed array would be, and see it the two match.
4889 If the array need repacking, we set the stride to the values we just
4890 calculated, recalculate the offset and copy the array data.
4891 Code is also added to copy the data back at the end of the function.
4895 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4896 gfc_wrapped_block * block)
4903 tree stmtInit, stmtCleanup;
4910 tree stride, stride2;
4920 /* Do nothing for pointer and allocatable arrays. */
4921 if (sym->attr.pointer || sym->attr.allocatable)
4924 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4926 gfc_trans_g77_array (sym, block);
4930 gfc_save_backend_locus (&loc);
4931 gfc_set_backend_locus (&sym->declared_at);
4933 /* Descriptor type. */
4934 type = TREE_TYPE (tmpdesc);
4935 gcc_assert (GFC_ARRAY_TYPE_P (type));
4936 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4937 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4938 gfc_start_block (&init);
4940 if (sym->ts.type == BT_CHARACTER
4941 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4942 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4944 checkparm = (sym->as->type == AS_EXPLICIT
4945 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4947 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4948 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4950 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4952 /* For non-constant shape arrays we only check if the first dimension
4953 is contiguous. Repacking higher dimensions wouldn't gain us
4954 anything as we still don't know the array stride. */
4955 partial = gfc_create_var (boolean_type_node, "partial");
4956 TREE_USED (partial) = 1;
4957 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4958 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4959 gfc_index_one_node);
4960 gfc_add_modify (&init, partial, tmp);
4963 partial = NULL_TREE;
4965 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4966 here, however I think it does the right thing. */
4969 /* Set the first stride. */
4970 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4971 stride = gfc_evaluate_now (stride, &init);
4973 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4974 stride, gfc_index_zero_node);
4975 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4976 tmp, gfc_index_one_node, stride);
4977 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4978 gfc_add_modify (&init, stride, tmp);
4980 /* Allow the user to disable array repacking. */
4981 stmt_unpacked = NULL_TREE;
4985 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4986 /* A library call to repack the array if necessary. */
4987 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4988 stmt_unpacked = build_call_expr_loc (input_location,
4989 gfor_fndecl_in_pack, 1, tmp);
4991 stride = gfc_index_one_node;
4993 if (gfc_option.warn_array_temp)
4994 gfc_warning ("Creating array temporary at %L", &loc);
4997 /* This is for the case where the array data is used directly without
4998 calling the repack function. */
4999 if (no_repack || partial != NULL_TREE)
5000 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5002 stmt_packed = NULL_TREE;
5004 /* Assign the data pointer. */
5005 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5007 /* Don't repack unknown shape arrays when the first stride is 1. */
5008 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5009 partial, stmt_packed, stmt_unpacked);
5012 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5013 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5015 offset = gfc_index_zero_node;
5016 size = gfc_index_one_node;
5018 /* Evaluate the bounds of the array. */
5019 for (n = 0; n < sym->as->rank; n++)
5021 if (checkparm || !sym->as->upper[n])
5023 /* Get the bounds of the actual parameter. */
5024 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5025 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5029 dubound = NULL_TREE;
5030 dlbound = NULL_TREE;
5033 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5034 if (!INTEGER_CST_P (lbound))
5036 gfc_init_se (&se, NULL);
5037 gfc_conv_expr_type (&se, sym->as->lower[n],
5038 gfc_array_index_type);
5039 gfc_add_block_to_block (&init, &se.pre);
5040 gfc_add_modify (&init, lbound, se.expr);
5043 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5044 /* Set the desired upper bound. */
5045 if (sym->as->upper[n])
5047 /* We know what we want the upper bound to be. */
5048 if (!INTEGER_CST_P (ubound))
5050 gfc_init_se (&se, NULL);
5051 gfc_conv_expr_type (&se, sym->as->upper[n],
5052 gfc_array_index_type);
5053 gfc_add_block_to_block (&init, &se.pre);
5054 gfc_add_modify (&init, ubound, se.expr);
5057 /* Check the sizes match. */
5060 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5064 temp = fold_build2_loc (input_location, MINUS_EXPR,
5065 gfc_array_index_type, ubound, lbound);
5066 temp = fold_build2_loc (input_location, PLUS_EXPR,
5067 gfc_array_index_type,
5068 gfc_index_one_node, temp);
5069 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5070 gfc_array_index_type, dubound,
5072 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5073 gfc_array_index_type,
5074 gfc_index_one_node, stride2);
5075 tmp = fold_build2_loc (input_location, NE_EXPR,
5076 gfc_array_index_type, temp, stride2);
5077 asprintf (&msg, "Dimension %d of array '%s' has extent "
5078 "%%ld instead of %%ld", n+1, sym->name);
5080 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5081 fold_convert (long_integer_type_node, temp),
5082 fold_convert (long_integer_type_node, stride2));
5089 /* For assumed shape arrays move the upper bound by the same amount
5090 as the lower bound. */
5091 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5092 gfc_array_index_type, dubound, dlbound);
5093 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5094 gfc_array_index_type, tmp, lbound);
5095 gfc_add_modify (&init, ubound, tmp);
5097 /* The offset of this dimension. offset = offset - lbound * stride. */
5098 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5100 offset = fold_build2_loc (input_location, MINUS_EXPR,
5101 gfc_array_index_type, offset, tmp);
5103 /* The size of this dimension, and the stride of the next. */
5104 if (n + 1 < sym->as->rank)
5106 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5108 if (no_repack || partial != NULL_TREE)
5110 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5112 /* Figure out the stride if not a known constant. */
5113 if (!INTEGER_CST_P (stride))
5116 stmt_packed = NULL_TREE;
5119 /* Calculate stride = size * (ubound + 1 - lbound). */
5120 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5121 gfc_array_index_type,
5122 gfc_index_one_node, lbound);
5123 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5124 gfc_array_index_type, ubound, tmp);
5125 size = fold_build2_loc (input_location, MULT_EXPR,
5126 gfc_array_index_type, size, tmp);
5130 /* Assign the stride. */
5131 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5132 tmp = fold_build3_loc (input_location, COND_EXPR,
5133 gfc_array_index_type, partial,
5134 stmt_unpacked, stmt_packed);
5136 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5137 gfc_add_modify (&init, stride, tmp);
5142 stride = GFC_TYPE_ARRAY_SIZE (type);
5144 if (stride && !INTEGER_CST_P (stride))
5146 /* Calculate size = stride * (ubound + 1 - lbound). */
5147 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5148 gfc_array_index_type,
5149 gfc_index_one_node, lbound);
5150 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5151 gfc_array_index_type,
5153 tmp = fold_build2_loc (input_location, MULT_EXPR,
5154 gfc_array_index_type,
5155 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5156 gfc_add_modify (&init, stride, tmp);
5161 /* Set the offset. */
5162 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5163 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5165 gfc_trans_vla_type_sizes (sym, &init);
5167 stmtInit = gfc_finish_block (&init);
5169 /* Only do the entry/initialization code if the arg is present. */
5170 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5171 optional_arg = (sym->attr.optional
5172 || (sym->ns->proc_name->attr.entry_master
5173 && sym->attr.dummy));
5176 tmp = gfc_conv_expr_present (sym);
5177 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5178 build_empty_stmt (input_location));
5183 stmtCleanup = NULL_TREE;
5186 stmtblock_t cleanup;
5187 gfc_start_block (&cleanup);
5189 if (sym->attr.intent != INTENT_IN)
5191 /* Copy the data back. */
5192 tmp = build_call_expr_loc (input_location,
5193 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5194 gfc_add_expr_to_block (&cleanup, tmp);
5197 /* Free the temporary. */
5198 tmp = gfc_call_free (tmpdesc);
5199 gfc_add_expr_to_block (&cleanup, tmp);
5201 stmtCleanup = gfc_finish_block (&cleanup);
5203 /* Only do the cleanup if the array was repacked. */
5204 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5205 tmp = gfc_conv_descriptor_data_get (tmp);
5206 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5208 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5209 build_empty_stmt (input_location));
5213 tmp = gfc_conv_expr_present (sym);
5214 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5215 build_empty_stmt (input_location));
5219 /* We don't need to free any memory allocated by internal_pack as it will
5220 be freed at the end of the function by pop_context. */
5221 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5223 gfc_restore_backend_locus (&loc);
5227 /* Calculate the overall offset, including subreferences. */
5229 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5230 bool subref, gfc_expr *expr)
5240 /* If offset is NULL and this is not a subreferenced array, there is
5242 if (offset == NULL_TREE)
5245 offset = gfc_index_zero_node;
5250 tmp = gfc_conv_array_data (desc);
5251 tmp = build_fold_indirect_ref_loc (input_location,
5253 tmp = gfc_build_array_ref (tmp, offset, NULL);
5255 /* Offset the data pointer for pointer assignments from arrays with
5256 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5259 /* Go past the array reference. */
5260 for (ref = expr->ref; ref; ref = ref->next)
5261 if (ref->type == REF_ARRAY &&
5262 ref->u.ar.type != AR_ELEMENT)
5268 /* Calculate the offset for each subsequent subreference. */
5269 for (; ref; ref = ref->next)
5274 field = ref->u.c.component->backend_decl;
5275 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5276 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5278 tmp, field, NULL_TREE);
5282 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5283 gfc_init_se (&start, NULL);
5284 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5285 gfc_add_block_to_block (block, &start.pre);
5286 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5290 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5291 && ref->u.ar.type == AR_ELEMENT);
5293 /* TODO - Add bounds checking. */
5294 stride = gfc_index_one_node;
5295 index = gfc_index_zero_node;
5296 for (n = 0; n < ref->u.ar.dimen; n++)
5301 /* Update the index. */
5302 gfc_init_se (&start, NULL);
5303 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5304 itmp = gfc_evaluate_now (start.expr, block);
5305 gfc_init_se (&start, NULL);
5306 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5307 jtmp = gfc_evaluate_now (start.expr, block);
5308 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5309 gfc_array_index_type, itmp, jtmp);
5310 itmp = fold_build2_loc (input_location, MULT_EXPR,
5311 gfc_array_index_type, itmp, stride);
5312 index = fold_build2_loc (input_location, PLUS_EXPR,
5313 gfc_array_index_type, itmp, index);
5314 index = gfc_evaluate_now (index, block);
5316 /* Update the stride. */
5317 gfc_init_se (&start, NULL);
5318 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5319 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5320 gfc_array_index_type, start.expr,
5322 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5323 gfc_array_index_type,
5324 gfc_index_one_node, itmp);
5325 stride = fold_build2_loc (input_location, MULT_EXPR,
5326 gfc_array_index_type, stride, itmp);
5327 stride = gfc_evaluate_now (stride, block);
5330 /* Apply the index to obtain the array element. */
5331 tmp = gfc_build_array_ref (tmp, index, NULL);
5341 /* Set the target data pointer. */
5342 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5343 gfc_conv_descriptor_data_set (block, parm, offset);
5347 /* gfc_conv_expr_descriptor needs the string length an expression
5348 so that the size of the temporary can be obtained. This is done
5349 by adding up the string lengths of all the elements in the
5350 expression. Function with non-constant expressions have their
5351 string lengths mapped onto the actual arguments using the
5352 interface mapping machinery in trans-expr.c. */
5354 get_array_charlen (gfc_expr *expr, gfc_se *se)
5356 gfc_interface_mapping mapping;
5357 gfc_formal_arglist *formal;
5358 gfc_actual_arglist *arg;
5361 if (expr->ts.u.cl->length
5362 && gfc_is_constant_expr (expr->ts.u.cl->length))
5364 if (!expr->ts.u.cl->backend_decl)
5365 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5369 switch (expr->expr_type)
5372 get_array_charlen (expr->value.op.op1, se);
5374 /* For parentheses the expression ts.u.cl is identical. */
5375 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5378 expr->ts.u.cl->backend_decl =
5379 gfc_create_var (gfc_charlen_type_node, "sln");
5381 if (expr->value.op.op2)
5383 get_array_charlen (expr->value.op.op2, se);
5385 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5387 /* Add the string lengths and assign them to the expression
5388 string length backend declaration. */
5389 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5390 fold_build2_loc (input_location, PLUS_EXPR,
5391 gfc_charlen_type_node,
5392 expr->value.op.op1->ts.u.cl->backend_decl,
5393 expr->value.op.op2->ts.u.cl->backend_decl));
5396 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5397 expr->value.op.op1->ts.u.cl->backend_decl);
5401 if (expr->value.function.esym == NULL
5402 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5404 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5408 /* Map expressions involving the dummy arguments onto the actual
5409 argument expressions. */
5410 gfc_init_interface_mapping (&mapping);
5411 formal = expr->symtree->n.sym->formal;
5412 arg = expr->value.function.actual;
5414 /* Set se = NULL in the calls to the interface mapping, to suppress any
5416 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5421 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5424 gfc_init_se (&tse, NULL);
5426 /* Build the expression for the character length and convert it. */
5427 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5429 gfc_add_block_to_block (&se->pre, &tse.pre);
5430 gfc_add_block_to_block (&se->post, &tse.post);
5431 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5432 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5433 gfc_charlen_type_node, tse.expr,
5434 build_int_cst (gfc_charlen_type_node, 0));
5435 expr->ts.u.cl->backend_decl = tse.expr;
5436 gfc_free_interface_mapping (&mapping);
5440 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5445 /* Helper function to check dimensions. */
5447 dim_ok (gfc_ss_info *info)
5450 for (n = 0; n < info->dimen; n++)
5451 if (info->dim[n] != n)
5456 /* Convert an array for passing as an actual argument. Expressions and
5457 vector subscripts are evaluated and stored in a temporary, which is then
5458 passed. For whole arrays the descriptor is passed. For array sections
5459 a modified copy of the descriptor is passed, but using the original data.
5461 This function is also used for array pointer assignments, and there
5464 - se->want_pointer && !se->direct_byref
5465 EXPR is an actual argument. On exit, se->expr contains a
5466 pointer to the array descriptor.
5468 - !se->want_pointer && !se->direct_byref
5469 EXPR is an actual argument to an intrinsic function or the
5470 left-hand side of a pointer assignment. On exit, se->expr
5471 contains the descriptor for EXPR.
5473 - !se->want_pointer && se->direct_byref
5474 EXPR is the right-hand side of a pointer assignment and
5475 se->expr is the descriptor for the previously-evaluated
5476 left-hand side. The function creates an assignment from
5480 The se->force_tmp flag disables the non-copying descriptor optimization
5481 that is used for transpose. It may be used in cases where there is an
5482 alias between the transpose argument and another argument in the same
5486 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5498 bool subref_array_target = false;
5501 gcc_assert (ss != NULL);
5502 gcc_assert (ss != gfc_ss_terminator);
5504 /* Special case things we know we can pass easily. */
5505 switch (expr->expr_type)
5508 /* If we have a linear array section, we can pass it directly.
5509 Otherwise we need to copy it into a temporary. */
5511 gcc_assert (ss->type == GFC_SS_SECTION);
5512 gcc_assert (ss->expr == expr);
5513 info = &ss->data.info;
5515 /* Get the descriptor for the array. */
5516 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5517 desc = info->descriptor;
5519 subref_array_target = se->direct_byref && is_subref_array (expr);
5520 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5521 && !subref_array_target;
5528 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5530 /* Create a new descriptor if the array doesn't have one. */
5533 else if (info->ref->u.ar.type == AR_FULL)
5535 else if (se->direct_byref)
5538 full = gfc_full_array_ref_p (info->ref, NULL);
5540 if (full && dim_ok (info))
5542 if (se->direct_byref && !se->byref_noassign)
5544 /* Copy the descriptor for pointer assignments. */
5545 gfc_add_modify (&se->pre, se->expr, desc);
5547 /* Add any offsets from subreferences. */
5548 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5549 subref_array_target, expr);
5551 else if (se->want_pointer)
5553 /* We pass full arrays directly. This means that pointers and
5554 allocatable arrays should also work. */
5555 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5562 if (expr->ts.type == BT_CHARACTER)
5563 se->string_length = gfc_get_expr_charlen (expr);
5571 /* We don't need to copy data in some cases. */
5572 arg = gfc_get_noncopying_intrinsic_argument (expr);
5575 /* This is a call to transpose... */
5576 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5577 /* ... which has already been handled by the scalarizer, so
5578 that we just need to get its argument's descriptor. */
5579 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5583 /* A transformational function return value will be a temporary
5584 array descriptor. We still need to go through the scalarizer
5585 to create the descriptor. Elemental functions ar handled as
5586 arbitrary expressions, i.e. copy to a temporary. */
5588 if (se->direct_byref)
5590 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5592 /* For pointer assignments pass the descriptor directly. */
5596 gcc_assert (se->ss == ss);
5597 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5598 gfc_conv_expr (se, expr);
5602 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5604 if (ss->expr != expr)
5605 /* Elemental function. */
5606 gcc_assert ((expr->value.function.esym != NULL
5607 && expr->value.function.esym->attr.elemental)
5608 || (expr->value.function.isym != NULL
5609 && expr->value.function.isym->elemental));
5611 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5614 if (expr->ts.type == BT_CHARACTER
5615 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5616 get_array_charlen (expr, se);
5622 /* Transformational function. */
5623 info = &ss->data.info;
5629 /* Constant array constructors don't need a temporary. */
5630 if (ss->type == GFC_SS_CONSTRUCTOR
5631 && expr->ts.type != BT_CHARACTER
5632 && gfc_constant_array_constructor_p (expr->value.constructor))
5635 info = &ss->data.info;
5645 /* Something complicated. Copy it into a temporary. */
5651 /* If we are creating a temporary, we don't need to bother about aliases
5656 gfc_init_loopinfo (&loop);
5658 /* Associate the SS with the loop. */
5659 gfc_add_ss_to_loop (&loop, ss);
5661 /* Tell the scalarizer not to bother creating loop variables, etc. */
5663 loop.array_parameter = 1;
5665 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5666 gcc_assert (!se->direct_byref);
5668 /* Setup the scalarizing loops and bounds. */
5669 gfc_conv_ss_startstride (&loop);
5673 /* Tell the scalarizer to make a temporary. */
5674 loop.temp_ss = gfc_get_ss ();
5675 loop.temp_ss->type = GFC_SS_TEMP;
5676 loop.temp_ss->next = gfc_ss_terminator;
5678 if (expr->ts.type == BT_CHARACTER
5679 && !expr->ts.u.cl->backend_decl)
5680 get_array_charlen (expr, se);
5682 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5684 if (expr->ts.type == BT_CHARACTER)
5685 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5687 loop.temp_ss->string_length = NULL;
5689 se->string_length = loop.temp_ss->string_length;
5690 loop.temp_ss->data.temp.dimen = loop.dimen;
5691 loop.temp_ss->data.temp.codimen = loop.codimen;
5692 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5695 gfc_conv_loop_setup (&loop, & expr->where);
5699 /* Copy into a temporary and pass that. We don't need to copy the data
5700 back because expressions and vector subscripts must be INTENT_IN. */
5701 /* TODO: Optimize passing function return values. */
5705 /* Start the copying loops. */
5706 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5707 gfc_mark_ss_chain_used (ss, 1);
5708 gfc_start_scalarized_body (&loop, &block);
5710 /* Copy each data element. */
5711 gfc_init_se (&lse, NULL);
5712 gfc_copy_loopinfo_to_se (&lse, &loop);
5713 gfc_init_se (&rse, NULL);
5714 gfc_copy_loopinfo_to_se (&rse, &loop);
5716 lse.ss = loop.temp_ss;
5719 gfc_conv_scalarized_array_ref (&lse, NULL);
5720 if (expr->ts.type == BT_CHARACTER)
5722 gfc_conv_expr (&rse, expr);
5723 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5724 rse.expr = build_fold_indirect_ref_loc (input_location,
5728 gfc_conv_expr_val (&rse, expr);
5730 gfc_add_block_to_block (&block, &rse.pre);
5731 gfc_add_block_to_block (&block, &lse.pre);
5733 lse.string_length = rse.string_length;
5734 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5735 expr->expr_type == EXPR_VARIABLE, true);
5736 gfc_add_expr_to_block (&block, tmp);
5738 /* Finish the copying loops. */
5739 gfc_trans_scalarizing_loops (&loop, &block);
5741 desc = loop.temp_ss->data.info.descriptor;
5743 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5745 desc = info->descriptor;
5746 se->string_length = ss->string_length;
5750 /* We pass sections without copying to a temporary. Make a new
5751 descriptor and point it at the section we want. The loop variable
5752 limits will be the limits of the section.
5753 A function may decide to repack the array to speed up access, but
5754 we're not bothered about that here. */
5755 int dim, ndim, codim;
5763 /* Set the string_length for a character array. */
5764 if (expr->ts.type == BT_CHARACTER)
5765 se->string_length = gfc_get_expr_charlen (expr);
5767 desc = info->descriptor;
5768 if (se->direct_byref && !se->byref_noassign)
5770 /* For pointer assignments we fill in the destination. */
5772 parmtype = TREE_TYPE (parm);
5776 /* Otherwise make a new one. */
5777 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5778 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5779 loop.codimen, loop.from,
5781 GFC_ARRAY_UNKNOWN, false);
5782 parm = gfc_create_var (parmtype, "parm");
5785 offset = gfc_index_zero_node;
5787 /* The following can be somewhat confusing. We have two
5788 descriptors, a new one and the original array.
5789 {parm, parmtype, dim} refer to the new one.
5790 {desc, type, n, loop} refer to the original, which maybe
5791 a descriptorless array.
5792 The bounds of the scalarization are the bounds of the section.
5793 We don't have to worry about numeric overflows when calculating
5794 the offsets because all elements are within the array data. */
5796 /* Set the dtype. */
5797 tmp = gfc_conv_descriptor_dtype (parm);
5798 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5800 /* Set offset for assignments to pointer only to zero if it is not
5802 if (se->direct_byref
5803 && info->ref && info->ref->u.ar.type != AR_FULL)
5804 base = gfc_index_zero_node;
5805 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5806 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5810 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5811 codim = info->codimen;
5812 for (n = 0; n < ndim; n++)
5814 stride = gfc_conv_array_stride (desc, n);
5816 /* Work out the offset. */
5818 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5820 gcc_assert (info->subscript[n]
5821 && info->subscript[n]->type == GFC_SS_SCALAR);
5822 start = info->subscript[n]->data.scalar.expr;
5826 /* Evaluate and remember the start of the section. */
5827 start = info->start[n];
5828 stride = gfc_evaluate_now (stride, &loop.pre);
5831 tmp = gfc_conv_array_lbound (desc, n);
5832 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5834 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5836 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5840 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5842 /* For elemental dimensions, we only need the offset. */
5846 /* Vector subscripts need copying and are handled elsewhere. */
5848 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5850 /* look for the corresponding scalarizer dimension: dim. */
5851 for (dim = 0; dim < ndim; dim++)
5852 if (info->dim[dim] == n)
5855 /* loop exited early: the DIM being looked for has been found. */
5856 gcc_assert (dim < ndim);
5858 /* Set the new lower bound. */
5859 from = loop.from[dim];
5862 /* If we have an array section or are assigning make sure that
5863 the lower bound is 1. References to the full
5864 array should otherwise keep the original bounds. */
5866 || info->ref->u.ar.type != AR_FULL)
5867 && !integer_onep (from))
5869 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5870 gfc_array_index_type, gfc_index_one_node,
5872 to = fold_build2_loc (input_location, PLUS_EXPR,
5873 gfc_array_index_type, to, tmp);
5874 from = gfc_index_one_node;
5876 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5877 gfc_rank_cst[dim], from);
5879 /* Set the new upper bound. */
5880 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5881 gfc_rank_cst[dim], to);
5883 /* Multiply the stride by the section stride to get the
5885 stride = fold_build2_loc (input_location, MULT_EXPR,
5886 gfc_array_index_type,
5887 stride, info->stride[n]);
5889 if (se->direct_byref
5891 && info->ref->u.ar.type != AR_FULL)
5893 base = fold_build2_loc (input_location, MINUS_EXPR,
5894 TREE_TYPE (base), base, stride);
5896 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5898 tmp = gfc_conv_array_lbound (desc, n);
5899 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5900 TREE_TYPE (base), tmp, loop.from[dim]);
5901 tmp = fold_build2_loc (input_location, MULT_EXPR,
5902 TREE_TYPE (base), tmp,
5903 gfc_conv_array_stride (desc, n));
5904 base = fold_build2_loc (input_location, PLUS_EXPR,
5905 TREE_TYPE (base), tmp, base);
5908 /* Store the new stride. */
5909 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5910 gfc_rank_cst[dim], stride);
5913 for (n = ndim; n < ndim + codim; n++)
5915 /* look for the corresponding scalarizer dimension: dim. */
5916 for (dim = 0; dim < ndim + codim; dim++)
5917 if (info->dim[dim] == n)
5920 /* loop exited early: the DIM being looked for has been found. */
5921 gcc_assert (dim < ndim + codim);
5923 from = loop.from[dim];
5925 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5926 gfc_rank_cst[dim], from);
5927 if (n < ndim + codim - 1)
5928 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5929 gfc_rank_cst[dim], to);
5933 if (se->data_not_needed)
5934 gfc_conv_descriptor_data_set (&loop.pre, parm,
5935 gfc_index_zero_node);
5937 /* Point the data pointer at the 1st element in the section. */
5938 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5939 subref_array_target, expr);
5941 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5942 && !se->data_not_needed)
5944 /* Set the offset. */
5945 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5949 /* Only the callee knows what the correct offset it, so just set
5951 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5956 if (!se->direct_byref || se->byref_noassign)
5958 /* Get a pointer to the new descriptor. */
5959 if (se->want_pointer)
5960 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5965 gfc_add_block_to_block (&se->pre, &loop.pre);
5966 gfc_add_block_to_block (&se->post, &loop.post);
5968 /* Cleanup the scalarizer. */
5969 gfc_cleanup_loop (&loop);
5972 /* Helper function for gfc_conv_array_parameter if array size needs to be
5976 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5979 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5980 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5981 else if (expr->rank > 1)
5982 *size = build_call_expr_loc (input_location,
5983 gfor_fndecl_size0, 1,
5984 gfc_build_addr_expr (NULL, desc));
5987 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5988 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5990 *size = fold_build2_loc (input_location, MINUS_EXPR,
5991 gfc_array_index_type, ubound, lbound);
5992 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5993 *size, gfc_index_one_node);
5994 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5995 *size, gfc_index_zero_node);
5997 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5998 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5999 *size, fold_convert (gfc_array_index_type, elem));
6002 /* Convert an array for passing as an actual parameter. */
6003 /* TODO: Optimize passing g77 arrays. */
6006 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6007 const gfc_symbol *fsym, const char *proc_name,
6012 tree tmp = NULL_TREE;
6014 tree parent = DECL_CONTEXT (current_function_decl);
6015 bool full_array_var;
6016 bool this_array_result;
6019 bool array_constructor;
6020 bool good_allocatable;
6021 bool ultimate_ptr_comp;
6022 bool ultimate_alloc_comp;
6027 ultimate_ptr_comp = false;
6028 ultimate_alloc_comp = false;
6030 for (ref = expr->ref; ref; ref = ref->next)
6032 if (ref->next == NULL)
6035 if (ref->type == REF_COMPONENT)
6037 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6038 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6042 full_array_var = false;
6045 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6046 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6048 sym = full_array_var ? expr->symtree->n.sym : NULL;
6050 /* The symbol should have an array specification. */
6051 gcc_assert (!sym || sym->as || ref->u.ar.as);
6053 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6055 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6056 expr->ts.u.cl->backend_decl = tmp;
6057 se->string_length = tmp;
6060 /* Is this the result of the enclosing procedure? */
6061 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6062 if (this_array_result
6063 && (sym->backend_decl != current_function_decl)
6064 && (sym->backend_decl != parent))
6065 this_array_result = false;
6067 /* Passing address of the array if it is not pointer or assumed-shape. */
6068 if (full_array_var && g77 && !this_array_result)
6070 tmp = gfc_get_symbol_decl (sym);
6072 if (sym->ts.type == BT_CHARACTER)
6073 se->string_length = sym->ts.u.cl->backend_decl;
6075 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6077 gfc_conv_expr_descriptor (se, expr, ss);
6078 se->expr = gfc_conv_array_data (se->expr);
6082 if (!sym->attr.pointer
6084 && sym->as->type != AS_ASSUMED_SHAPE
6085 && !sym->attr.allocatable)
6087 /* Some variables are declared directly, others are declared as
6088 pointers and allocated on the heap. */
6089 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6092 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6094 array_parameter_size (tmp, expr, size);
6098 if (sym->attr.allocatable)
6100 if (sym->attr.dummy || sym->attr.result)
6102 gfc_conv_expr_descriptor (se, expr, ss);
6106 array_parameter_size (tmp, expr, size);
6107 se->expr = gfc_conv_array_data (tmp);
6112 /* A convenient reduction in scope. */
6113 contiguous = g77 && !this_array_result && contiguous;
6115 /* There is no need to pack and unpack the array, if it is contiguous
6116 and not a deferred- or assumed-shape array, or if it is simply
6118 no_pack = ((sym && sym->as
6119 && !sym->attr.pointer
6120 && sym->as->type != AS_DEFERRED
6121 && sym->as->type != AS_ASSUMED_SHAPE)
6123 (ref && ref->u.ar.as
6124 && ref->u.ar.as->type != AS_DEFERRED
6125 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6127 gfc_is_simply_contiguous (expr, false));
6129 no_pack = contiguous && no_pack;
6131 /* Array constructors are always contiguous and do not need packing. */
6132 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6134 /* Same is true of contiguous sections from allocatable variables. */
6135 good_allocatable = contiguous
6137 && expr->symtree->n.sym->attr.allocatable;
6139 /* Or ultimate allocatable components. */
6140 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6142 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6144 gfc_conv_expr_descriptor (se, expr, ss);
6145 if (expr->ts.type == BT_CHARACTER)
6146 se->string_length = expr->ts.u.cl->backend_decl;
6148 array_parameter_size (se->expr, expr, size);
6149 se->expr = gfc_conv_array_data (se->expr);
6153 if (this_array_result)
6155 /* Result of the enclosing function. */
6156 gfc_conv_expr_descriptor (se, expr, ss);
6158 array_parameter_size (se->expr, expr, size);
6159 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6161 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6162 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6163 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6170 /* Every other type of array. */
6171 se->want_pointer = 1;
6172 gfc_conv_expr_descriptor (se, expr, ss);
6174 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6179 /* Deallocate the allocatable components of structures that are
6181 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6182 && expr->ts.u.derived->attr.alloc_comp
6183 && expr->expr_type != EXPR_VARIABLE)
6185 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6186 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6188 /* The components shall be deallocated before their containing entity. */
6189 gfc_prepend_expr_to_block (&se->post, tmp);
6192 if (g77 || (fsym && fsym->attr.contiguous
6193 && !gfc_is_simply_contiguous (expr, false)))
6195 tree origptr = NULL_TREE;
6199 /* For contiguous arrays, save the original value of the descriptor. */
6202 origptr = gfc_create_var (pvoid_type_node, "origptr");
6203 tmp = build_fold_indirect_ref_loc (input_location, desc);
6204 tmp = gfc_conv_array_data (tmp);
6205 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6206 TREE_TYPE (origptr), origptr,
6207 fold_convert (TREE_TYPE (origptr), tmp));
6208 gfc_add_expr_to_block (&se->pre, tmp);
6211 /* Repack the array. */
6212 if (gfc_option.warn_array_temp)
6215 gfc_warning ("Creating array temporary at %L for argument '%s'",
6216 &expr->where, fsym->name);
6218 gfc_warning ("Creating array temporary at %L", &expr->where);
6221 ptr = build_call_expr_loc (input_location,
6222 gfor_fndecl_in_pack, 1, desc);
6224 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6226 tmp = gfc_conv_expr_present (sym);
6227 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6228 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6229 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6232 ptr = gfc_evaluate_now (ptr, &se->pre);
6234 /* Use the packed data for the actual argument, except for contiguous arrays,
6235 where the descriptor's data component is set. */
6240 tmp = build_fold_indirect_ref_loc (input_location, desc);
6241 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6244 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6248 if (fsym && proc_name)
6249 asprintf (&msg, "An array temporary was created for argument "
6250 "'%s' of procedure '%s'", fsym->name, proc_name);
6252 asprintf (&msg, "An array temporary was created");
6254 tmp = build_fold_indirect_ref_loc (input_location,
6256 tmp = gfc_conv_array_data (tmp);
6257 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6258 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6260 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6261 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6263 gfc_conv_expr_present (sym), tmp);
6265 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6270 gfc_start_block (&block);
6272 /* Copy the data back. */
6273 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6275 tmp = build_call_expr_loc (input_location,
6276 gfor_fndecl_in_unpack, 2, desc, ptr);
6277 gfc_add_expr_to_block (&block, tmp);
6280 /* Free the temporary. */
6281 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6282 gfc_add_expr_to_block (&block, tmp);
6284 stmt = gfc_finish_block (&block);
6286 gfc_init_block (&block);
6287 /* Only if it was repacked. This code needs to be executed before the
6288 loop cleanup code. */
6289 tmp = build_fold_indirect_ref_loc (input_location,
6291 tmp = gfc_conv_array_data (tmp);
6292 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6293 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6295 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6296 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6298 gfc_conv_expr_present (sym), tmp);
6300 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6302 gfc_add_expr_to_block (&block, tmp);
6303 gfc_add_block_to_block (&block, &se->post);
6305 gfc_init_block (&se->post);
6307 /* Reset the descriptor pointer. */
6310 tmp = build_fold_indirect_ref_loc (input_location, desc);
6311 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6314 gfc_add_block_to_block (&se->post, &block);
6319 /* Generate code to deallocate an array, if it is allocated. */
6322 gfc_trans_dealloc_allocated (tree descriptor)
6328 gfc_start_block (&block);
6330 var = gfc_conv_descriptor_data_get (descriptor);
6333 /* Call array_deallocate with an int * present in the second argument.
6334 Although it is ignored here, it's presence ensures that arrays that
6335 are already deallocated are ignored. */
6336 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6337 gfc_add_expr_to_block (&block, tmp);
6339 /* Zero the data pointer. */
6340 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6341 var, build_int_cst (TREE_TYPE (var), 0));
6342 gfc_add_expr_to_block (&block, tmp);
6344 return gfc_finish_block (&block);
6348 /* This helper function calculates the size in words of a full array. */
6351 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6356 idx = gfc_rank_cst[rank - 1];
6357 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6358 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6359 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6361 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6362 tmp, gfc_index_one_node);
6363 tmp = gfc_evaluate_now (tmp, block);
6365 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6366 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6368 return gfc_evaluate_now (tmp, block);
6372 /* Allocate dest to the same size as src, and copy src -> dest.
6373 If no_malloc is set, only the copy is done. */
6376 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6386 /* If the source is null, set the destination to null. Then,
6387 allocate memory to the destination. */
6388 gfc_init_block (&block);
6392 tmp = null_pointer_node;
6393 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6394 gfc_add_expr_to_block (&block, tmp);
6395 null_data = gfc_finish_block (&block);
6397 gfc_init_block (&block);
6398 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6401 tmp = gfc_call_malloc (&block, type, size);
6402 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6403 dest, fold_convert (type, tmp));
6404 gfc_add_expr_to_block (&block, tmp);
6407 tmp = built_in_decls[BUILT_IN_MEMCPY];
6408 tmp = build_call_expr_loc (input_location, tmp, 3,
6413 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6414 null_data = gfc_finish_block (&block);
6416 gfc_init_block (&block);
6417 nelems = get_full_array_size (&block, src, rank);
6418 tmp = fold_convert (gfc_array_index_type,
6419 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6420 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6424 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6425 tmp = gfc_call_malloc (&block, tmp, size);
6426 gfc_conv_descriptor_data_set (&block, dest, tmp);
6429 /* We know the temporary and the value will be the same length,
6430 so can use memcpy. */
6431 tmp = built_in_decls[BUILT_IN_MEMCPY];
6432 tmp = build_call_expr_loc (input_location,
6433 tmp, 3, gfc_conv_descriptor_data_get (dest),
6434 gfc_conv_descriptor_data_get (src), size);
6437 gfc_add_expr_to_block (&block, tmp);
6438 tmp = gfc_finish_block (&block);
6440 /* Null the destination if the source is null; otherwise do
6441 the allocate and copy. */
6445 null_cond = gfc_conv_descriptor_data_get (src);
6447 null_cond = convert (pvoid_type_node, null_cond);
6448 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6449 null_cond, null_pointer_node);
6450 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6454 /* Allocate dest to the same size as src, and copy data src -> dest. */
6457 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6459 return duplicate_allocatable (dest, src, type, rank, false);
6463 /* Copy data src -> dest. */
6466 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6468 return duplicate_allocatable (dest, src, type, rank, true);
6472 /* Recursively traverse an object of derived type, generating code to
6473 deallocate, nullify or copy allocatable components. This is the work horse
6474 function for the functions named in this enum. */
6476 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6477 COPY_ONLY_ALLOC_COMP};
6480 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6481 tree dest, int rank, int purpose)
6485 stmtblock_t fnblock;
6486 stmtblock_t loopbody;
6497 tree null_cond = NULL_TREE;
6499 gfc_init_block (&fnblock);
6501 decl_type = TREE_TYPE (decl);
6503 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6504 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6506 decl = build_fold_indirect_ref_loc (input_location,
6509 /* Just in case in gets dereferenced. */
6510 decl_type = TREE_TYPE (decl);
6512 /* If this an array of derived types with allocatable components
6513 build a loop and recursively call this function. */
6514 if (TREE_CODE (decl_type) == ARRAY_TYPE
6515 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6517 tmp = gfc_conv_array_data (decl);
6518 var = build_fold_indirect_ref_loc (input_location,
6521 /* Get the number of elements - 1 and set the counter. */
6522 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6524 /* Use the descriptor for an allocatable array. Since this
6525 is a full array reference, we only need the descriptor
6526 information from dimension = rank. */
6527 tmp = get_full_array_size (&fnblock, decl, rank);
6528 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6529 gfc_array_index_type, tmp,
6530 gfc_index_one_node);
6532 null_cond = gfc_conv_descriptor_data_get (decl);
6533 null_cond = fold_build2_loc (input_location, NE_EXPR,
6534 boolean_type_node, null_cond,
6535 build_int_cst (TREE_TYPE (null_cond), 0));
6539 /* Otherwise use the TYPE_DOMAIN information. */
6540 tmp = array_type_nelts (decl_type);
6541 tmp = fold_convert (gfc_array_index_type, tmp);
6544 /* Remember that this is, in fact, the no. of elements - 1. */
6545 nelems = gfc_evaluate_now (tmp, &fnblock);
6546 index = gfc_create_var (gfc_array_index_type, "S");
6548 /* Build the body of the loop. */
6549 gfc_init_block (&loopbody);
6551 vref = gfc_build_array_ref (var, index, NULL);
6553 if (purpose == COPY_ALLOC_COMP)
6555 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6557 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6558 gfc_add_expr_to_block (&fnblock, tmp);
6560 tmp = build_fold_indirect_ref_loc (input_location,
6561 gfc_conv_array_data (dest));
6562 dref = gfc_build_array_ref (tmp, index, NULL);
6563 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6565 else if (purpose == COPY_ONLY_ALLOC_COMP)
6567 tmp = build_fold_indirect_ref_loc (input_location,
6568 gfc_conv_array_data (dest));
6569 dref = gfc_build_array_ref (tmp, index, NULL);
6570 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6574 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6576 gfc_add_expr_to_block (&loopbody, tmp);
6578 /* Build the loop and return. */
6579 gfc_init_loopinfo (&loop);
6581 loop.from[0] = gfc_index_zero_node;
6582 loop.loopvar[0] = index;
6583 loop.to[0] = nelems;
6584 gfc_trans_scalarizing_loops (&loop, &loopbody);
6585 gfc_add_block_to_block (&fnblock, &loop.pre);
6587 tmp = gfc_finish_block (&fnblock);
6588 if (null_cond != NULL_TREE)
6589 tmp = build3_v (COND_EXPR, null_cond, tmp,
6590 build_empty_stmt (input_location));
6595 /* Otherwise, act on the components or recursively call self to
6596 act on a chain of components. */
6597 for (c = der_type->components; c; c = c->next)
6599 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6600 || c->ts.type == BT_CLASS)
6601 && c->ts.u.derived->attr.alloc_comp;
6602 cdecl = c->backend_decl;
6603 ctype = TREE_TYPE (cdecl);
6607 case DEALLOCATE_ALLOC_COMP:
6608 if (c->attr.allocatable && c->attr.dimension)
6610 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6611 decl, cdecl, NULL_TREE);
6612 if (cmp_has_alloc_comps && !c->attr.pointer)
6614 /* Do not deallocate the components of ultimate pointer
6616 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6617 c->as->rank, purpose);
6618 gfc_add_expr_to_block (&fnblock, tmp);
6620 tmp = gfc_trans_dealloc_allocated (comp);
6621 gfc_add_expr_to_block (&fnblock, tmp);
6623 else if (c->attr.allocatable)
6625 /* Allocatable scalar components. */
6626 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6627 decl, cdecl, NULL_TREE);
6629 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6631 gfc_add_expr_to_block (&fnblock, tmp);
6633 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6634 void_type_node, comp,
6635 build_int_cst (TREE_TYPE (comp), 0));
6636 gfc_add_expr_to_block (&fnblock, tmp);
6638 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6640 /* Allocatable scalar CLASS components. */
6641 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6642 decl, cdecl, NULL_TREE);
6644 /* Add reference to '_data' component. */
6645 tmp = CLASS_DATA (c)->backend_decl;
6646 comp = fold_build3_loc (input_location, COMPONENT_REF,
6647 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6649 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6650 CLASS_DATA (c)->ts);
6651 gfc_add_expr_to_block (&fnblock, tmp);
6653 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6654 void_type_node, comp,
6655 build_int_cst (TREE_TYPE (comp), 0));
6656 gfc_add_expr_to_block (&fnblock, tmp);
6660 case NULLIFY_ALLOC_COMP:
6661 if (c->attr.pointer)
6663 else if (c->attr.allocatable && c->attr.dimension)
6665 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6666 decl, cdecl, NULL_TREE);
6667 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6669 else if (c->attr.allocatable)
6671 /* Allocatable scalar components. */
6672 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6673 decl, cdecl, NULL_TREE);
6674 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6675 void_type_node, comp,
6676 build_int_cst (TREE_TYPE (comp), 0));
6677 gfc_add_expr_to_block (&fnblock, tmp);
6679 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6681 /* Allocatable scalar CLASS components. */
6682 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6683 decl, cdecl, NULL_TREE);
6684 /* Add reference to '_data' component. */
6685 tmp = CLASS_DATA (c)->backend_decl;
6686 comp = fold_build3_loc (input_location, COMPONENT_REF,
6687 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6688 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6689 void_type_node, comp,
6690 build_int_cst (TREE_TYPE (comp), 0));
6691 gfc_add_expr_to_block (&fnblock, tmp);
6693 else if (cmp_has_alloc_comps)
6695 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6696 decl, cdecl, NULL_TREE);
6697 rank = c->as ? c->as->rank : 0;
6698 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6700 gfc_add_expr_to_block (&fnblock, tmp);
6704 case COPY_ALLOC_COMP:
6705 if (c->attr.pointer)
6708 /* We need source and destination components. */
6709 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6711 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6713 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6715 if (c->attr.allocatable && !cmp_has_alloc_comps)
6717 rank = c->as ? c->as->rank : 0;
6718 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6719 gfc_add_expr_to_block (&fnblock, tmp);
6722 if (cmp_has_alloc_comps)
6724 rank = c->as ? c->as->rank : 0;
6725 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6726 gfc_add_modify (&fnblock, dcmp, tmp);
6727 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6729 gfc_add_expr_to_block (&fnblock, tmp);
6739 return gfc_finish_block (&fnblock);
6742 /* Recursively traverse an object of derived type, generating code to
6743 nullify allocatable components. */
6746 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6748 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6749 NULLIFY_ALLOC_COMP);
6753 /* Recursively traverse an object of derived type, generating code to
6754 deallocate allocatable components. */
6757 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6759 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6760 DEALLOCATE_ALLOC_COMP);
6764 /* Recursively traverse an object of derived type, generating code to
6765 copy it and its allocatable components. */
6768 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6770 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6774 /* Recursively traverse an object of derived type, generating code to
6775 copy only its allocatable components. */
6778 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6780 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6784 /* Returns the value of LBOUND for an expression. This could be broken out
6785 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6786 called by gfc_alloc_allocatable_for_assignment. */
6788 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6793 tree cond, cond1, cond3, cond4;
6795 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6797 tmp = gfc_rank_cst[dim];
6798 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6799 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6800 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6801 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6803 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6804 stride, gfc_index_zero_node);
6805 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6806 boolean_type_node, cond3, cond1);
6807 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6808 stride, gfc_index_zero_node);
6810 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6811 tmp, build_int_cst (gfc_array_index_type,
6814 cond = boolean_false_node;
6816 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6817 boolean_type_node, cond3, cond4);
6818 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6819 boolean_type_node, cond, cond1);
6821 return fold_build3_loc (input_location, COND_EXPR,
6822 gfc_array_index_type, cond,
6823 lbound, gfc_index_one_node);
6825 else if (expr->expr_type == EXPR_VARIABLE)
6827 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6828 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
6830 else if (expr->expr_type == EXPR_FUNCTION)
6832 /* A conversion function, so use the argument. */
6833 expr = expr->value.function.actual->expr;
6834 if (expr->expr_type != EXPR_VARIABLE)
6835 return gfc_index_one_node;
6836 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6837 return get_std_lbound (expr, desc, dim, assumed_size);
6840 return gfc_index_one_node;
6844 /* Returns true if an expression represents an lhs that can be reallocated
6848 gfc_is_reallocatable_lhs (gfc_expr *expr)
6855 /* An allocatable variable. */
6856 if (expr->symtree->n.sym->attr.allocatable
6858 && expr->ref->type == REF_ARRAY
6859 && expr->ref->u.ar.type == AR_FULL)
6862 /* All that can be left are allocatable components. */
6863 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6864 && expr->symtree->n.sym->ts.type != BT_CLASS)
6865 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6868 /* Find a component ref followed by an array reference. */
6869 for (ref = expr->ref; ref; ref = ref->next)
6871 && ref->type == REF_COMPONENT
6872 && ref->next->type == REF_ARRAY
6873 && !ref->next->next)
6879 /* Return true if valid reallocatable lhs. */
6880 if (ref->u.c.component->attr.allocatable
6881 && ref->next->u.ar.type == AR_FULL)
6888 /* Allocate the lhs of an assignment to an allocatable array, otherwise
6892 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
6896 stmtblock_t realloc_block;
6897 stmtblock_t alloc_block;
6920 gfc_array_spec * as;
6922 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
6923 Find the lhs expression in the loop chain and set expr1 and
6924 expr2 accordingly. */
6925 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
6928 /* Find the ss for the lhs. */
6930 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
6931 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
6933 if (lss == gfc_ss_terminator)
6938 /* Bail out if this is not a valid allocate on assignment. */
6939 if (!gfc_is_reallocatable_lhs (expr1)
6940 || (expr2 && !expr2->rank))
6943 /* Find the ss for the lhs. */
6945 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
6946 if (lss->expr == expr1)
6949 if (lss == gfc_ss_terminator)
6952 /* Find an ss for the rhs. For operator expressions, we see the
6953 ss's for the operands. Any one of these will do. */
6955 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
6956 if (rss->expr != expr1 && rss != loop->temp_ss)
6959 if (expr2 && rss == gfc_ss_terminator)
6962 gfc_start_block (&fblock);
6964 /* Since the lhs is allocatable, this must be a descriptor type.
6965 Get the data and array size. */
6966 desc = lss->data.info.descriptor;
6967 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
6968 array1 = gfc_conv_descriptor_data_get (desc);
6970 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
6971 deallocated if expr is an array of different shape or any of the
6972 corresponding length type parameter values of variable and expr
6973 differ." This assures F95 compatibility. */
6974 jump_label1 = gfc_build_label_decl (NULL_TREE);
6975 jump_label2 = gfc_build_label_decl (NULL_TREE);
6977 /* Allocate if data is NULL. */
6978 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6979 array1, build_int_cst (TREE_TYPE (array1), 0));
6980 tmp = build3_v (COND_EXPR, cond,
6981 build1_v (GOTO_EXPR, jump_label1),
6982 build_empty_stmt (input_location));
6983 gfc_add_expr_to_block (&fblock, tmp);
6985 /* Get arrayspec if expr is a full array. */
6986 if (expr2 && expr2->expr_type == EXPR_FUNCTION
6987 && expr2->value.function.isym
6988 && expr2->value.function.isym->conversion)
6990 /* For conversion functions, take the arg. */
6991 gfc_expr *arg = expr2->value.function.actual->expr;
6992 as = gfc_get_full_arrayspec_from_expr (arg);
6995 as = gfc_get_full_arrayspec_from_expr (expr2);
6999 /* If the lhs shape is not the same as the rhs jump to setting the
7000 bounds and doing the reallocation....... */
7001 for (n = 0; n < expr1->rank; n++)
7003 /* Check the shape. */
7004 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7005 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7006 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7007 gfc_array_index_type,
7008 loop->to[n], loop->from[n]);
7009 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7010 gfc_array_index_type,
7012 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7013 gfc_array_index_type,
7015 cond = fold_build2_loc (input_location, NE_EXPR,
7017 tmp, gfc_index_zero_node);
7018 tmp = build3_v (COND_EXPR, cond,
7019 build1_v (GOTO_EXPR, jump_label1),
7020 build_empty_stmt (input_location));
7021 gfc_add_expr_to_block (&fblock, tmp);
7024 /* ....else jump past the (re)alloc code. */
7025 tmp = build1_v (GOTO_EXPR, jump_label2);
7026 gfc_add_expr_to_block (&fblock, tmp);
7028 /* Add the label to start automatic (re)allocation. */
7029 tmp = build1_v (LABEL_EXPR, jump_label1);
7030 gfc_add_expr_to_block (&fblock, tmp);
7032 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7034 /* Get the rhs size. Fix both sizes. */
7036 desc2 = rss->data.info.descriptor;
7039 size2 = gfc_index_one_node;
7040 for (n = 0; n < expr2->rank; n++)
7042 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7043 gfc_array_index_type,
7044 loop->to[n], loop->from[n]);
7045 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7046 gfc_array_index_type,
7047 tmp, gfc_index_one_node);
7048 size2 = fold_build2_loc (input_location, MULT_EXPR,
7049 gfc_array_index_type,
7053 size1 = gfc_evaluate_now (size1, &fblock);
7054 size2 = gfc_evaluate_now (size2, &fblock);
7056 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7058 neq_size = gfc_evaluate_now (cond, &fblock);
7061 /* Now modify the lhs descriptor and the associated scalarizer
7062 variables. F2003 7.4.1.3: "If variable is or becomes an
7063 unallocated allocatable variable, then it is allocated with each
7064 deferred type parameter equal to the corresponding type parameters
7065 of expr , with the shape of expr , and with each lower bound equal
7066 to the corresponding element of LBOUND(expr)."
7067 Reuse size1 to keep a dimension-by-dimension track of the
7068 stride of the new array. */
7069 size1 = gfc_index_one_node;
7070 offset = gfc_index_zero_node;
7072 for (n = 0; n < expr2->rank; n++)
7074 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7075 gfc_array_index_type,
7076 loop->to[n], loop->from[n]);
7077 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7078 gfc_array_index_type,
7079 tmp, gfc_index_one_node);
7081 lbound = gfc_index_one_node;
7086 lbd = get_std_lbound (expr2, desc2, n,
7087 as->type == AS_ASSUMED_SIZE);
7088 ubound = fold_build2_loc (input_location,
7090 gfc_array_index_type,
7092 ubound = fold_build2_loc (input_location,
7094 gfc_array_index_type,
7099 gfc_conv_descriptor_lbound_set (&fblock, desc,
7102 gfc_conv_descriptor_ubound_set (&fblock, desc,
7105 gfc_conv_descriptor_stride_set (&fblock, desc,
7108 lbound = gfc_conv_descriptor_lbound_get (desc,
7110 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7111 gfc_array_index_type,
7113 offset = fold_build2_loc (input_location, MINUS_EXPR,
7114 gfc_array_index_type,
7116 size1 = fold_build2_loc (input_location, MULT_EXPR,
7117 gfc_array_index_type,
7121 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7122 the array offset is saved and the info.offset is used for a
7123 running offset. Use the saved_offset instead. */
7124 tmp = gfc_conv_descriptor_offset (desc);
7125 gfc_add_modify (&fblock, tmp, offset);
7126 if (lss->data.info.saved_offset
7127 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7128 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7130 /* Now set the deltas for the lhs. */
7131 for (n = 0; n < expr1->rank; n++)
7133 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7134 dim = lss->data.info.dim[n];
7135 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7136 gfc_array_index_type, tmp,
7138 if (lss->data.info.delta[dim]
7139 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7140 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7143 /* Get the new lhs size in bytes. */
7144 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7146 tmp = expr2->ts.u.cl->backend_decl;
7147 gcc_assert (expr1->ts.u.cl->backend_decl);
7148 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7149 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7151 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7153 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7154 tmp = fold_build2_loc (input_location, MULT_EXPR,
7155 gfc_array_index_type, tmp,
7156 expr1->ts.u.cl->backend_decl);
7159 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7160 tmp = fold_convert (gfc_array_index_type, tmp);
7161 size2 = fold_build2_loc (input_location, MULT_EXPR,
7162 gfc_array_index_type,
7164 size2 = fold_convert (size_type_node, size2);
7165 size2 = gfc_evaluate_now (size2, &fblock);
7167 /* Realloc expression. Note that the scalarizer uses desc.data
7168 in the array reference - (*desc.data)[<element>]. */
7169 gfc_init_block (&realloc_block);
7170 tmp = build_call_expr_loc (input_location,
7171 built_in_decls[BUILT_IN_REALLOC], 2,
7172 fold_convert (pvoid_type_node, array1),
7174 gfc_conv_descriptor_data_set (&realloc_block,
7176 realloc_expr = gfc_finish_block (&realloc_block);
7178 /* Only reallocate if sizes are different. */
7179 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7180 build_empty_stmt (input_location));
7184 /* Malloc expression. */
7185 gfc_init_block (&alloc_block);
7186 tmp = build_call_expr_loc (input_location,
7187 built_in_decls[BUILT_IN_MALLOC], 1,
7189 gfc_conv_descriptor_data_set (&alloc_block,
7191 tmp = gfc_conv_descriptor_dtype (desc);
7192 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7193 alloc_expr = gfc_finish_block (&alloc_block);
7195 /* Malloc if not allocated; realloc otherwise. */
7196 tmp = build_int_cst (TREE_TYPE (array1), 0);
7197 cond = fold_build2_loc (input_location, EQ_EXPR,
7200 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7201 gfc_add_expr_to_block (&fblock, tmp);
7203 /* Make sure that the scalarizer data pointer is updated. */
7204 if (lss->data.info.data
7205 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7207 tmp = gfc_conv_descriptor_data_get (desc);
7208 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7211 /* Add the exit label. */
7212 tmp = build1_v (LABEL_EXPR, jump_label2);
7213 gfc_add_expr_to_block (&fblock, tmp);
7215 return gfc_finish_block (&fblock);
7219 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7220 Do likewise, recursively if necessary, with the allocatable components of
7224 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7230 stmtblock_t cleanup;
7233 bool sym_has_alloc_comp;
7235 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7236 || sym->ts.type == BT_CLASS)
7237 && sym->ts.u.derived->attr.alloc_comp;
7239 /* Make sure the frontend gets these right. */
7240 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7241 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7242 "allocatable attribute or derived type without allocatable "
7245 gfc_save_backend_locus (&loc);
7246 gfc_set_backend_locus (&sym->declared_at);
7247 gfc_init_block (&init);
7249 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7250 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7252 if (sym->ts.type == BT_CHARACTER
7253 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7255 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7256 gfc_trans_vla_type_sizes (sym, &init);
7259 /* Dummy, use associated and result variables don't need anything special. */
7260 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7262 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7263 gfc_restore_backend_locus (&loc);
7267 descriptor = sym->backend_decl;
7269 /* Although static, derived types with default initializers and
7270 allocatable components must not be nulled wholesale; instead they
7271 are treated component by component. */
7272 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7274 /* SAVEd variables are not freed on exit. */
7275 gfc_trans_static_array_pointer (sym);
7277 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7278 gfc_restore_backend_locus (&loc);
7282 /* Get the descriptor type. */
7283 type = TREE_TYPE (sym->backend_decl);
7285 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7288 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7290 if (sym->value == NULL
7291 || !gfc_has_default_initializer (sym->ts.u.derived))
7293 rank = sym->as ? sym->as->rank : 0;
7294 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7296 gfc_add_expr_to_block (&init, tmp);
7299 gfc_init_default_dt (sym, &init, false);
7302 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7304 /* If the backend_decl is not a descriptor, we must have a pointer
7306 descriptor = build_fold_indirect_ref_loc (input_location,
7308 type = TREE_TYPE (descriptor);
7311 /* NULLIFY the data pointer. */
7312 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7313 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7315 gfc_restore_backend_locus (&loc);
7316 gfc_init_block (&cleanup);
7318 /* Allocatable arrays need to be freed when they go out of scope.
7319 The allocatable components of pointers must not be touched. */
7320 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7321 && !sym->attr.pointer && !sym->attr.save)
7324 rank = sym->as ? sym->as->rank : 0;
7325 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7326 gfc_add_expr_to_block (&cleanup, tmp);
7329 if (sym->attr.allocatable && sym->attr.dimension
7330 && !sym->attr.save && !sym->attr.result)
7332 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7333 gfc_add_expr_to_block (&cleanup, tmp);
7336 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7337 gfc_finish_block (&cleanup));
7340 /************ Expression Walking Functions ******************/
7342 /* Walk a variable reference.
7344 Possible extension - multiple component subscripts.
7345 x(:,:) = foo%a(:)%b(:)
7347 forall (i=..., j=...)
7348 x(i,j) = foo%a(j)%b(i)
7350 This adds a fair amount of complexity because you need to deal with more
7351 than one ref. Maybe handle in a similar manner to vector subscripts.
7352 Maybe not worth the effort. */
7356 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7363 for (ref = expr->ref; ref; ref = ref->next)
7364 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7367 for (; ref; ref = ref->next)
7369 if (ref->type == REF_SUBSTRING)
7371 newss = gfc_get_ss ();
7372 newss->type = GFC_SS_SCALAR;
7373 newss->expr = ref->u.ss.start;
7377 newss = gfc_get_ss ();
7378 newss->type = GFC_SS_SCALAR;
7379 newss->expr = ref->u.ss.end;
7384 /* We're only interested in array sections from now on. */
7385 if (ref->type != REF_ARRAY)
7390 if (ar->as->rank == 0)
7392 /* Scalar coarray. */
7399 for (n = 0; n < ar->dimen + ar->codimen; n++)
7401 newss = gfc_get_ss ();
7402 newss->type = GFC_SS_SCALAR;
7403 newss->expr = ar->start[n];
7410 newss = gfc_get_ss ();
7411 newss->type = GFC_SS_SECTION;
7414 newss->data.info.dimen = ar->as->rank;
7415 newss->data.info.codimen = 0;
7416 newss->data.info.ref = ref;
7418 /* Make sure array is the same as array(:,:), this way
7419 we don't need to special case all the time. */
7420 ar->dimen = ar->as->rank;
7422 for (n = 0; n < ar->dimen; n++)
7424 newss->data.info.dim[n] = n;
7425 ar->dimen_type[n] = DIMEN_RANGE;
7427 gcc_assert (ar->start[n] == NULL);
7428 gcc_assert (ar->end[n] == NULL);
7429 gcc_assert (ar->stride[n] == NULL);
7431 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7433 newss->data.info.dim[n] = n;
7434 ar->dimen_type[n] = DIMEN_RANGE;
7436 gcc_assert (ar->start[n] == NULL);
7437 gcc_assert (ar->end[n] == NULL);
7443 newss = gfc_get_ss ();
7444 newss->type = GFC_SS_SECTION;
7447 newss->data.info.dimen = 0;
7448 newss->data.info.codimen = 0;
7449 newss->data.info.ref = ref;
7451 /* We add SS chains for all the subscripts in the section. */
7452 for (n = 0; n < ar->dimen + ar->codimen; n++)
7456 switch (ar->dimen_type[n])
7458 case DIMEN_THIS_IMAGE:
7461 /* Add SS for elemental (scalar) subscripts. */
7462 gcc_assert (ar->start[n]);
7463 indexss = gfc_get_ss ();
7464 indexss->type = GFC_SS_SCALAR;
7465 indexss->expr = ar->start[n];
7466 indexss->next = gfc_ss_terminator;
7467 indexss->loop_chain = gfc_ss_terminator;
7468 newss->data.info.subscript[n] = indexss;
7472 /* We don't add anything for sections, just remember this
7473 dimension for later. */
7474 newss->data.info.dim[newss->data.info.dimen
7475 + newss->data.info.codimen] = n;
7477 newss->data.info.dimen++;
7481 /* Create a GFC_SS_VECTOR index in which we can store
7482 the vector's descriptor. */
7483 indexss = gfc_get_ss ();
7484 indexss->type = GFC_SS_VECTOR;
7485 indexss->expr = ar->start[n];
7486 indexss->next = gfc_ss_terminator;
7487 indexss->loop_chain = gfc_ss_terminator;
7488 newss->data.info.subscript[n] = indexss;
7489 newss->data.info.dim[newss->data.info.dimen
7490 + newss->data.info.codimen] = n;
7492 newss->data.info.dimen++;
7496 /* We should know what sort of section it is by now. */
7500 /* We should have at least one non-elemental dimension. */
7501 gcc_assert (newss->data.info.dimen > 0);
7506 /* We should know what sort of section it is by now. */
7515 /* Walk an expression operator. If only one operand of a binary expression is
7516 scalar, we must also add the scalar term to the SS chain. */
7519 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7525 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7526 if (expr->value.op.op2 == NULL)
7529 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7531 /* All operands are scalar. Pass back and let the caller deal with it. */
7535 /* All operands require scalarization. */
7536 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7539 /* One of the operands needs scalarization, the other is scalar.
7540 Create a gfc_ss for the scalar expression. */
7541 newss = gfc_get_ss ();
7542 newss->type = GFC_SS_SCALAR;
7545 /* First operand is scalar. We build the chain in reverse order, so
7546 add the scalar SS after the second operand. */
7548 while (head && head->next != ss)
7550 /* Check we haven't somehow broken the chain. */
7554 newss->expr = expr->value.op.op1;
7556 else /* head2 == head */
7558 gcc_assert (head2 == head);
7559 /* Second operand is scalar. */
7560 newss->next = head2;
7562 newss->expr = expr->value.op.op2;
7569 /* Reverse a SS chain. */
7572 gfc_reverse_ss (gfc_ss * ss)
7577 gcc_assert (ss != NULL);
7579 head = gfc_ss_terminator;
7580 while (ss != gfc_ss_terminator)
7583 /* Check we didn't somehow break the chain. */
7584 gcc_assert (next != NULL);
7594 /* Walk the arguments of an elemental function. */
7597 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7605 head = gfc_ss_terminator;
7608 for (; arg; arg = arg->next)
7613 newss = gfc_walk_subexpr (head, arg->expr);
7616 /* Scalar argument. */
7617 newss = gfc_get_ss ();
7619 newss->expr = arg->expr;
7629 while (tail->next != gfc_ss_terminator)
7636 /* If all the arguments are scalar we don't need the argument SS. */
7637 gfc_free_ss_chain (head);
7642 /* Add it onto the existing chain. */
7648 /* Walk a function call. Scalar functions are passed back, and taken out of
7649 scalarization loops. For elemental functions we walk their arguments.
7650 The result of functions returning arrays is stored in a temporary outside
7651 the loop, so that the function is only called once. Hence we do not need
7652 to walk their arguments. */
7655 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7658 gfc_intrinsic_sym *isym;
7660 gfc_component *comp = NULL;
7663 isym = expr->value.function.isym;
7665 /* Handle intrinsic functions separately. */
7667 return gfc_walk_intrinsic_function (ss, expr, isym);
7669 sym = expr->value.function.esym;
7671 sym = expr->symtree->n.sym;
7673 /* A function that returns arrays. */
7674 gfc_is_proc_ptr_comp (expr, &comp);
7675 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7676 || (comp && comp->attr.dimension))
7678 newss = gfc_get_ss ();
7679 newss->type = GFC_SS_FUNCTION;
7682 newss->data.info.dimen = expr->rank;
7683 for (n = 0; n < newss->data.info.dimen; n++)
7684 newss->data.info.dim[n] = n;
7688 /* Walk the parameters of an elemental function. For now we always pass
7690 if (sym->attr.elemental)
7691 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7694 /* Scalar functions are OK as these are evaluated outside the scalarization
7695 loop. Pass back and let the caller deal with it. */
7700 /* An array temporary is constructed for array constructors. */
7703 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7708 newss = gfc_get_ss ();
7709 newss->type = GFC_SS_CONSTRUCTOR;
7712 newss->data.info.dimen = expr->rank;
7713 for (n = 0; n < expr->rank; n++)
7714 newss->data.info.dim[n] = n;
7720 /* Walk an expression. Add walked expressions to the head of the SS chain.
7721 A wholly scalar expression will not be added. */
7724 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7728 switch (expr->expr_type)
7731 head = gfc_walk_variable_expr (ss, expr);
7735 head = gfc_walk_op_expr (ss, expr);
7739 head = gfc_walk_function_expr (ss, expr);
7744 case EXPR_STRUCTURE:
7745 /* Pass back and let the caller deal with it. */
7749 head = gfc_walk_array_constructor (ss, expr);
7752 case EXPR_SUBSTRING:
7753 /* Pass back and let the caller deal with it. */
7757 internal_error ("bad expression type during walk (%d)",
7764 /* Entry point for expression walking.
7765 A return value equal to the passed chain means this is
7766 a scalar expression. It is up to the caller to take whatever action is
7767 necessary to translate these. */
7770 gfc_walk_expr (gfc_expr * expr)
7774 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7775 return gfc_reverse_ss (res);