1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subscripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var;
98 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
102 gfc_array_dataptr_type (tree desc)
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
124 Don't forget to #undef these! */
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
131 #define STRIDE_SUBFIELD 0
132 #define LBOUND_SUBFIELD 1
133 #define UBOUND_SUBFIELD 2
135 /* This provides READ-ONLY access to the data field. The field itself
136 doesn't have the proper type. */
139 gfc_conv_descriptor_data_get (tree desc)
143 type = TREE_TYPE (desc);
144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
146 field = TYPE_FIELDS (type);
147 gcc_assert (DATA_FIELD == 0);
149 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
151 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
169 type = TREE_TYPE (desc);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172 field = TYPE_FIELDS (type);
173 gcc_assert (DATA_FIELD == 0);
175 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
177 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
181 /* This provides address access to the data field. This should only be
182 used by array allocation, passing this on to the runtime. */
185 gfc_conv_descriptor_data_addr (tree desc)
189 type = TREE_TYPE (desc);
190 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
192 field = TYPE_FIELDS (type);
193 gcc_assert (DATA_FIELD == 0);
195 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
197 return gfc_build_addr_expr (NULL_TREE, t);
201 gfc_conv_descriptor_offset (tree desc)
206 type = TREE_TYPE (desc);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
210 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
213 desc, field, NULL_TREE);
217 gfc_conv_descriptor_offset_get (tree desc)
219 return gfc_conv_descriptor_offset (desc);
223 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
226 tree t = gfc_conv_descriptor_offset (desc);
227 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
232 gfc_conv_descriptor_dtype (tree desc)
237 type = TREE_TYPE (desc);
238 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
240 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
241 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
243 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
244 desc, field, NULL_TREE);
248 gfc_conv_descriptor_dimension (tree desc, tree dim)
254 type = TREE_TYPE (desc);
255 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
257 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
258 gcc_assert (field != NULL_TREE
259 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
260 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
262 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
263 desc, field, NULL_TREE);
264 tmp = gfc_build_array_ref (tmp, dim, NULL);
269 gfc_conv_descriptor_stride (tree desc, tree dim)
274 tmp = gfc_conv_descriptor_dimension (desc, dim);
275 field = TYPE_FIELDS (TREE_TYPE (tmp));
276 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
277 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
279 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
280 tmp, field, NULL_TREE);
285 gfc_conv_descriptor_stride_get (tree desc, tree dim)
287 tree type = TREE_TYPE (desc);
288 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
289 if (integer_zerop (dim)
290 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
291 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
292 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
293 return gfc_index_one_node;
295 return gfc_conv_descriptor_stride (desc, dim);
299 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
300 tree dim, tree value)
302 tree t = gfc_conv_descriptor_stride (desc, dim);
303 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
307 gfc_conv_descriptor_lbound (tree desc, tree dim)
312 tmp = gfc_conv_descriptor_dimension (desc, dim);
313 field = TYPE_FIELDS (TREE_TYPE (tmp));
314 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
315 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
317 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
318 tmp, field, NULL_TREE);
323 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
325 return gfc_conv_descriptor_lbound (desc, dim);
329 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
330 tree dim, tree value)
332 tree t = gfc_conv_descriptor_lbound (desc, dim);
333 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
337 gfc_conv_descriptor_ubound (tree desc, tree dim)
342 tmp = gfc_conv_descriptor_dimension (desc, dim);
343 field = TYPE_FIELDS (TREE_TYPE (tmp));
344 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
345 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
347 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
348 tmp, field, NULL_TREE);
353 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
355 return gfc_conv_descriptor_ubound (desc, dim);
359 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
360 tree dim, tree value)
362 tree t = gfc_conv_descriptor_ubound (desc, dim);
363 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
366 /* Build a null array descriptor constructor. */
369 gfc_build_null_descriptor (tree type)
374 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
375 gcc_assert (DATA_FIELD == 0);
376 field = TYPE_FIELDS (type);
378 /* Set a NULL data pointer. */
379 tmp = build_constructor_single (type, field, null_pointer_node);
380 TREE_CONSTANT (tmp) = 1;
381 /* All other fields are ignored. */
387 /* Modify a descriptor such that the lbound of a given dimension is the value
388 specified. This also updates ubound and offset accordingly. */
391 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
392 int dim, tree new_lbound)
394 tree offs, ubound, lbound, stride;
395 tree diff, offs_diff;
397 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
399 offs = gfc_conv_descriptor_offset_get (desc);
400 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
401 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
402 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
404 /* Get difference (new - old) by which to shift stuff. */
405 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
408 /* Shift ubound and offset accordingly. This has to be done before
409 updating the lbound, as they depend on the lbound expression! */
410 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
412 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
413 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
415 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
417 gfc_conv_descriptor_offset_set (block, desc, offs);
419 /* Finally set lbound to value we want. */
420 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
424 /* Cleanup those #defines. */
429 #undef DIMENSION_FIELD
430 #undef STRIDE_SUBFIELD
431 #undef LBOUND_SUBFIELD
432 #undef UBOUND_SUBFIELD
435 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
436 flags & 1 = Main loop body.
437 flags & 2 = temp copy loop. */
440 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
442 for (; ss != gfc_ss_terminator; ss = ss->next)
443 ss->useflags = flags;
446 static void gfc_free_ss (gfc_ss *);
449 /* Free a gfc_ss chain. */
452 gfc_free_ss_chain (gfc_ss * ss)
456 while (ss != gfc_ss_terminator)
458 gcc_assert (ss != NULL);
469 gfc_free_ss (gfc_ss * ss)
476 for (n = 0; n < ss->data.info.dimen; n++)
478 if (ss->data.info.subscript[ss->data.info.dim[n]])
479 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
491 /* Free all the SS associated with a loop. */
494 gfc_cleanup_loop (gfc_loopinfo * loop)
500 while (ss != gfc_ss_terminator)
502 gcc_assert (ss != NULL);
503 next = ss->loop_chain;
510 /* Associate a SS chain with a loop. */
513 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
517 if (head == gfc_ss_terminator)
521 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
523 if (ss->next == gfc_ss_terminator)
524 ss->loop_chain = loop->ss;
526 ss->loop_chain = ss->next;
528 gcc_assert (ss == gfc_ss_terminator);
533 /* Generate an initializer for a static pointer or allocatable array. */
536 gfc_trans_static_array_pointer (gfc_symbol * sym)
540 gcc_assert (TREE_STATIC (sym->backend_decl));
541 /* Just zero the data member. */
542 type = TREE_TYPE (sym->backend_decl);
543 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
547 /* If the bounds of SE's loop have not yet been set, see if they can be
548 determined from array spec AS, which is the array spec of a called
549 function. MAPPING maps the callee's dummy arguments to the values
550 that the caller is passing. Add any initialization and finalization
554 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
555 gfc_se * se, gfc_array_spec * as)
563 if (as && as->type == AS_EXPLICIT)
564 for (n = 0; n < se->loop->dimen; n++)
566 dim = se->ss->data.info.dim[n];
567 gcc_assert (dim < as->rank);
568 gcc_assert (se->loop->dimen == as->rank);
569 if (se->loop->to[n] == NULL_TREE)
571 /* Evaluate the lower bound. */
572 gfc_init_se (&tmpse, NULL);
573 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
574 gfc_add_block_to_block (&se->pre, &tmpse.pre);
575 gfc_add_block_to_block (&se->post, &tmpse.post);
576 lower = fold_convert (gfc_array_index_type, tmpse.expr);
578 /* ...and the upper bound. */
579 gfc_init_se (&tmpse, NULL);
580 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
581 gfc_add_block_to_block (&se->pre, &tmpse.pre);
582 gfc_add_block_to_block (&se->post, &tmpse.post);
583 upper = fold_convert (gfc_array_index_type, tmpse.expr);
585 /* Set the upper bound of the loop to UPPER - LOWER. */
586 tmp = fold_build2_loc (input_location, MINUS_EXPR,
587 gfc_array_index_type, upper, lower);
588 tmp = gfc_evaluate_now (tmp, &se->pre);
589 se->loop->to[n] = tmp;
595 /* Generate code to allocate an array temporary, or create a variable to
596 hold the data. If size is NULL, zero the descriptor so that the
597 callee will allocate the array. If DEALLOC is true, also generate code to
598 free the array afterwards.
600 If INITIAL is not NULL, it is packed using internal_pack and the result used
601 as data instead of allocating a fresh, unitialized area of memory.
603 Initialization code is added to PRE and finalization code to POST.
604 DYNAMIC is true if the caller may want to extend the array later
605 using realloc. This prevents us from putting the array on the stack. */
608 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
609 gfc_ss_info * info, tree size, tree nelem,
610 tree initial, bool dynamic, bool dealloc)
616 desc = info->descriptor;
617 info->offset = gfc_index_zero_node;
618 if (size == NULL_TREE || integer_zerop (size))
620 /* A callee allocated array. */
621 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
626 /* Allocate the temporary. */
627 onstack = !dynamic && initial == NULL_TREE
628 && gfc_can_put_var_on_stack (size);
632 /* Make a temporary variable to hold the data. */
633 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
634 nelem, gfc_index_one_node);
635 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
637 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
639 tmp = gfc_create_var (tmp, "A");
640 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
641 gfc_conv_descriptor_data_set (pre, desc, tmp);
645 /* Allocate memory to hold the data or call internal_pack. */
646 if (initial == NULL_TREE)
648 tmp = gfc_call_malloc (pre, NULL, size);
649 tmp = gfc_evaluate_now (tmp, pre);
656 stmtblock_t do_copying;
658 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
659 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
660 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
661 tmp = gfc_get_element_type (tmp);
662 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
663 packed = gfc_create_var (build_pointer_type (tmp), "data");
665 tmp = build_call_expr_loc (input_location,
666 gfor_fndecl_in_pack, 1, initial);
667 tmp = fold_convert (TREE_TYPE (packed), tmp);
668 gfc_add_modify (pre, packed, tmp);
670 tmp = build_fold_indirect_ref_loc (input_location,
672 source_data = gfc_conv_descriptor_data_get (tmp);
674 /* internal_pack may return source->data without any allocation
675 or copying if it is already packed. If that's the case, we
676 need to allocate and copy manually. */
678 gfc_start_block (&do_copying);
679 tmp = gfc_call_malloc (&do_copying, NULL, size);
680 tmp = fold_convert (TREE_TYPE (packed), tmp);
681 gfc_add_modify (&do_copying, packed, tmp);
682 tmp = gfc_build_memcpy_call (packed, source_data, size);
683 gfc_add_expr_to_block (&do_copying, tmp);
685 was_packed = fold_build2_loc (input_location, EQ_EXPR,
686 boolean_type_node, packed,
688 tmp = gfc_finish_block (&do_copying);
689 tmp = build3_v (COND_EXPR, was_packed, tmp,
690 build_empty_stmt (input_location));
691 gfc_add_expr_to_block (pre, tmp);
693 tmp = fold_convert (pvoid_type_node, packed);
696 gfc_conv_descriptor_data_set (pre, desc, tmp);
699 info->data = gfc_conv_descriptor_data_get (desc);
701 /* The offset is zero because we create temporaries with a zero
703 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
705 if (dealloc && !onstack)
707 /* Free the temporary. */
708 tmp = gfc_conv_descriptor_data_get (desc);
709 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
710 gfc_add_expr_to_block (post, tmp);
715 /* Get the array reference dimension corresponding to the given loop dimension.
716 It is different from the true array dimension given by the dim array in
717 the case of a partial array reference
718 It is different from the loop dimension in the case of a transposed array.
722 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
724 int n, array_dim, array_ref_dim;
727 array_dim = info->dim[loop_dim];
729 for (n = 0; n < info->dimen; n++)
730 if (n != loop_dim && info->dim[n] < array_dim)
733 return array_ref_dim;
737 /* Generate code to create and initialize the descriptor for a temporary
738 array. This is used for both temporaries needed by the scalarizer, and
739 functions returning arrays. Adjusts the loop variables to be
740 zero-based, and calculates the loop bounds for callee allocated arrays.
741 Allocate the array unless it's callee allocated (we have a callee
742 allocated array if 'callee_alloc' is true, or if loop->to[n] is
743 NULL_TREE for any n). Also fills in the descriptor, data and offset
744 fields of info if known. Returns the size of the array, or NULL for a
745 callee allocated array.
747 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
748 gfc_trans_allocate_array_storage.
752 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
753 gfc_loopinfo * loop, gfc_ss_info * info,
754 tree eltype, tree initial, bool dynamic,
755 bool dealloc, bool callee_alloc, locus * where)
757 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
767 memset (from, 0, sizeof (from));
768 memset (to, 0, sizeof (to));
770 gcc_assert (info->dimen > 0);
771 gcc_assert (loop->dimen == info->dimen);
773 if (gfc_option.warn_array_temp && where)
774 gfc_warning ("Creating array temporary at %L", where);
776 /* Set the lower bound to zero. */
777 for (n = 0; n < loop->dimen; n++)
781 /* Callee allocated arrays may not have a known bound yet. */
783 loop->to[n] = gfc_evaluate_now (
784 fold_build2_loc (input_location, MINUS_EXPR,
785 gfc_array_index_type,
786 loop->to[n], loop->from[n]),
788 loop->from[n] = gfc_index_zero_node;
790 /* We are constructing the temporary's descriptor based on the loop
791 dimensions. As the dimensions may be accessed in arbitrary order
792 (think of transpose) the size taken from the n'th loop may not map
793 to the n'th dimension of the array. We need to reconstruct loop infos
794 in the right order before using it to set the descriptor
796 tmp_dim = get_array_ref_dim (info, n);
797 from[tmp_dim] = loop->from[n];
798 to[tmp_dim] = loop->to[n];
800 info->delta[dim] = gfc_index_zero_node;
801 info->start[dim] = gfc_index_zero_node;
802 info->end[dim] = gfc_index_zero_node;
803 info->stride[dim] = gfc_index_one_node;
806 /* Initialize the descriptor. */
808 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
809 GFC_ARRAY_UNKNOWN, true);
810 desc = gfc_create_var (type, "atmp");
811 GFC_DECL_PACKED_ARRAY (desc) = 1;
813 info->descriptor = desc;
814 size = gfc_index_one_node;
816 /* Fill in the array dtype. */
817 tmp = gfc_conv_descriptor_dtype (desc);
818 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
821 Fill in the bounds and stride. This is a packed array, so:
824 for (n = 0; n < rank; n++)
827 delta = ubound[n] + 1 - lbound[n];
830 size = size * sizeof(element);
835 /* If there is at least one null loop->to[n], it is a callee allocated
837 for (n = 0; n < loop->dimen; n++)
838 if (loop->to[n] == NULL_TREE)
844 for (n = 0; n < loop->dimen; n++)
848 if (size == NULL_TREE)
850 /* For a callee allocated array express the loop bounds in terms
851 of the descriptor fields. */
852 tmp = fold_build2_loc (input_location,
853 MINUS_EXPR, gfc_array_index_type,
854 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
855 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
860 /* Store the stride and bound components in the descriptor. */
861 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
863 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
864 gfc_index_zero_node);
866 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
869 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
870 to[n], gfc_index_one_node);
872 /* Check whether the size for this dimension is negative. */
873 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
874 gfc_index_zero_node);
875 cond = gfc_evaluate_now (cond, pre);
880 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
881 boolean_type_node, or_expr, cond);
883 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
885 size = gfc_evaluate_now (size, pre);
888 /* Get the size of the array. */
890 if (size && !callee_alloc)
892 /* If or_expr is true, then the extent in at least one
893 dimension is zero and the size is set to zero. */
894 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
895 or_expr, gfc_index_zero_node, size);
898 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
900 fold_convert (gfc_array_index_type,
901 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
909 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
912 if (info->dimen > loop->temp_dim)
913 loop->temp_dim = info->dimen;
919 /* Return the number of iterations in a loop that starts at START,
920 ends at END, and has step STEP. */
923 gfc_get_iteration_count (tree start, tree end, tree step)
928 type = TREE_TYPE (step);
929 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
930 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
931 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
932 build_int_cst (type, 1));
933 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
934 build_int_cst (type, 0));
935 return fold_convert (gfc_array_index_type, tmp);
939 /* Extend the data in array DESC by EXTRA elements. */
942 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
949 if (integer_zerop (extra))
952 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
954 /* Add EXTRA to the upper bound. */
955 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
957 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
959 /* Get the value of the current data pointer. */
960 arg0 = gfc_conv_descriptor_data_get (desc);
962 /* Calculate the new array size. */
963 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
964 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
965 ubound, gfc_index_one_node);
966 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
967 fold_convert (size_type_node, tmp),
968 fold_convert (size_type_node, size));
970 /* Call the realloc() function. */
971 tmp = gfc_call_realloc (pblock, arg0, arg1);
972 gfc_conv_descriptor_data_set (pblock, desc, tmp);
976 /* Return true if the bounds of iterator I can only be determined
980 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
982 return (i->start->expr_type != EXPR_CONSTANT
983 || i->end->expr_type != EXPR_CONSTANT
984 || i->step->expr_type != EXPR_CONSTANT);
988 /* Split the size of constructor element EXPR into the sum of two terms,
989 one of which can be determined at compile time and one of which must
990 be calculated at run time. Set *SIZE to the former and return true
991 if the latter might be nonzero. */
994 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
996 if (expr->expr_type == EXPR_ARRAY)
997 return gfc_get_array_constructor_size (size, expr->value.constructor);
998 else if (expr->rank > 0)
1000 /* Calculate everything at run time. */
1001 mpz_set_ui (*size, 0);
1006 /* A single element. */
1007 mpz_set_ui (*size, 1);
1013 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1014 of array constructor C. */
1017 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1025 mpz_set_ui (*size, 0);
1030 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1033 if (i && gfc_iterator_has_dynamic_bounds (i))
1037 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1040 /* Multiply the static part of the element size by the
1041 number of iterations. */
1042 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1043 mpz_fdiv_q (val, val, i->step->value.integer);
1044 mpz_add_ui (val, val, 1);
1045 if (mpz_sgn (val) > 0)
1046 mpz_mul (len, len, val);
1048 mpz_set_ui (len, 0);
1050 mpz_add (*size, *size, len);
1059 /* Make sure offset is a variable. */
1062 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1065 /* We should have already created the offset variable. We cannot
1066 create it here because we may be in an inner scope. */
1067 gcc_assert (*offsetvar != NULL_TREE);
1068 gfc_add_modify (pblock, *offsetvar, *poffset);
1069 *poffset = *offsetvar;
1070 TREE_USED (*offsetvar) = 1;
1074 /* Variables needed for bounds-checking. */
1075 static bool first_len;
1076 static tree first_len_val;
1077 static bool typespec_chararray_ctor;
1080 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1081 tree offset, gfc_se * se, gfc_expr * expr)
1085 gfc_conv_expr (se, expr);
1087 /* Store the value. */
1088 tmp = build_fold_indirect_ref_loc (input_location,
1089 gfc_conv_descriptor_data_get (desc));
1090 tmp = gfc_build_array_ref (tmp, offset, NULL);
1092 if (expr->ts.type == BT_CHARACTER)
1094 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1097 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1098 esize = fold_convert (gfc_charlen_type_node, esize);
1099 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1100 gfc_charlen_type_node, esize,
1101 build_int_cst (gfc_charlen_type_node,
1102 gfc_character_kinds[i].bit_size / 8));
1104 gfc_conv_string_parameter (se);
1105 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1107 /* The temporary is an array of pointers. */
1108 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1109 gfc_add_modify (&se->pre, tmp, se->expr);
1113 /* The temporary is an array of string values. */
1114 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1115 /* We know the temporary and the value will be the same length,
1116 so can use memcpy. */
1117 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1118 se->string_length, se->expr, expr->ts.kind);
1120 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1124 gfc_add_modify (&se->pre, first_len_val,
1130 /* Verify that all constructor elements are of the same
1132 tree cond = fold_build2_loc (input_location, NE_EXPR,
1133 boolean_type_node, first_len_val,
1135 gfc_trans_runtime_check
1136 (true, false, cond, &se->pre, &expr->where,
1137 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1138 fold_convert (long_integer_type_node, first_len_val),
1139 fold_convert (long_integer_type_node, se->string_length));
1145 /* TODO: Should the frontend already have done this conversion? */
1146 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1147 gfc_add_modify (&se->pre, tmp, se->expr);
1150 gfc_add_block_to_block (pblock, &se->pre);
1151 gfc_add_block_to_block (pblock, &se->post);
1155 /* Add the contents of an array to the constructor. DYNAMIC is as for
1156 gfc_trans_array_constructor_value. */
1159 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1160 tree type ATTRIBUTE_UNUSED,
1161 tree desc, gfc_expr * expr,
1162 tree * poffset, tree * offsetvar,
1173 /* We need this to be a variable so we can increment it. */
1174 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1176 gfc_init_se (&se, NULL);
1178 /* Walk the array expression. */
1179 ss = gfc_walk_expr (expr);
1180 gcc_assert (ss != gfc_ss_terminator);
1182 /* Initialize the scalarizer. */
1183 gfc_init_loopinfo (&loop);
1184 gfc_add_ss_to_loop (&loop, ss);
1186 /* Initialize the loop. */
1187 gfc_conv_ss_startstride (&loop);
1188 gfc_conv_loop_setup (&loop, &expr->where);
1190 /* Make sure the constructed array has room for the new data. */
1193 /* Set SIZE to the total number of elements in the subarray. */
1194 size = gfc_index_one_node;
1195 for (n = 0; n < loop.dimen; n++)
1197 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1198 gfc_index_one_node);
1199 size = fold_build2_loc (input_location, MULT_EXPR,
1200 gfc_array_index_type, size, tmp);
1203 /* Grow the constructed array by SIZE elements. */
1204 gfc_grow_array (&loop.pre, desc, size);
1207 /* Make the loop body. */
1208 gfc_mark_ss_chain_used (ss, 1);
1209 gfc_start_scalarized_body (&loop, &body);
1210 gfc_copy_loopinfo_to_se (&se, &loop);
1213 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1214 gcc_assert (se.ss == gfc_ss_terminator);
1216 /* Increment the offset. */
1217 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1218 *poffset, gfc_index_one_node);
1219 gfc_add_modify (&body, *poffset, tmp);
1221 /* Finish the loop. */
1222 gfc_trans_scalarizing_loops (&loop, &body);
1223 gfc_add_block_to_block (&loop.pre, &loop.post);
1224 tmp = gfc_finish_block (&loop.pre);
1225 gfc_add_expr_to_block (pblock, tmp);
1227 gfc_cleanup_loop (&loop);
1231 /* Assign the values to the elements of an array constructor. DYNAMIC
1232 is true if descriptor DESC only contains enough data for the static
1233 size calculated by gfc_get_array_constructor_size. When true, memory
1234 for the dynamic parts must be allocated using realloc. */
1237 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1238 tree desc, gfc_constructor_base base,
1239 tree * poffset, tree * offsetvar,
1248 tree shadow_loopvar = NULL_TREE;
1249 gfc_saved_var saved_loopvar;
1252 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1254 /* If this is an iterator or an array, the offset must be a variable. */
1255 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1256 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1258 /* Shadowing the iterator avoids changing its value and saves us from
1259 keeping track of it. Further, it makes sure that there's always a
1260 backend-decl for the symbol, even if there wasn't one before,
1261 e.g. in the case of an iterator that appears in a specification
1262 expression in an interface mapping. */
1265 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1266 tree type = gfc_typenode_for_spec (&sym->ts);
1268 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1269 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1272 gfc_start_block (&body);
1274 if (c->expr->expr_type == EXPR_ARRAY)
1276 /* Array constructors can be nested. */
1277 gfc_trans_array_constructor_value (&body, type, desc,
1278 c->expr->value.constructor,
1279 poffset, offsetvar, dynamic);
1281 else if (c->expr->rank > 0)
1283 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1284 poffset, offsetvar, dynamic);
1288 /* This code really upsets the gimplifier so don't bother for now. */
1295 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1297 p = gfc_constructor_next (p);
1302 /* Scalar values. */
1303 gfc_init_se (&se, NULL);
1304 gfc_trans_array_ctor_element (&body, desc, *poffset,
1307 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1308 gfc_array_index_type,
1309 *poffset, gfc_index_one_node);
1313 /* Collect multiple scalar constants into a constructor. */
1314 VEC(constructor_elt,gc) *v = NULL;
1318 HOST_WIDE_INT idx = 0;
1321 /* Count the number of consecutive scalar constants. */
1322 while (p && !(p->iterator
1323 || p->expr->expr_type != EXPR_CONSTANT))
1325 gfc_init_se (&se, NULL);
1326 gfc_conv_constant (&se, p->expr);
1328 if (c->expr->ts.type != BT_CHARACTER)
1329 se.expr = fold_convert (type, se.expr);
1330 /* For constant character array constructors we build
1331 an array of pointers. */
1332 else if (POINTER_TYPE_P (type))
1333 se.expr = gfc_build_addr_expr
1334 (gfc_get_pchar_type (p->expr->ts.kind),
1337 CONSTRUCTOR_APPEND_ELT (v,
1338 build_int_cst (gfc_array_index_type,
1342 p = gfc_constructor_next (p);
1345 bound = build_int_cst (NULL_TREE, n - 1);
1346 /* Create an array type to hold them. */
1347 tmptype = build_range_type (gfc_array_index_type,
1348 gfc_index_zero_node, bound);
1349 tmptype = build_array_type (type, tmptype);
1351 init = build_constructor (tmptype, v);
1352 TREE_CONSTANT (init) = 1;
1353 TREE_STATIC (init) = 1;
1354 /* Create a static variable to hold the data. */
1355 tmp = gfc_create_var (tmptype, "data");
1356 TREE_STATIC (tmp) = 1;
1357 TREE_CONSTANT (tmp) = 1;
1358 TREE_READONLY (tmp) = 1;
1359 DECL_INITIAL (tmp) = init;
1362 /* Use BUILTIN_MEMCPY to assign the values. */
1363 tmp = gfc_conv_descriptor_data_get (desc);
1364 tmp = build_fold_indirect_ref_loc (input_location,
1366 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1367 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1368 init = gfc_build_addr_expr (NULL_TREE, init);
1370 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1371 bound = build_int_cst (NULL_TREE, n * size);
1372 tmp = build_call_expr_loc (input_location,
1373 built_in_decls[BUILT_IN_MEMCPY], 3,
1375 gfc_add_expr_to_block (&body, tmp);
1377 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1378 gfc_array_index_type, *poffset,
1379 build_int_cst (gfc_array_index_type, n));
1381 if (!INTEGER_CST_P (*poffset))
1383 gfc_add_modify (&body, *offsetvar, *poffset);
1384 *poffset = *offsetvar;
1388 /* The frontend should already have done any expansions
1392 /* Pass the code as is. */
1393 tmp = gfc_finish_block (&body);
1394 gfc_add_expr_to_block (pblock, tmp);
1398 /* Build the implied do-loop. */
1399 stmtblock_t implied_do_block;
1407 loopbody = gfc_finish_block (&body);
1409 /* Create a new block that holds the implied-do loop. A temporary
1410 loop-variable is used. */
1411 gfc_start_block(&implied_do_block);
1413 /* Initialize the loop. */
1414 gfc_init_se (&se, NULL);
1415 gfc_conv_expr_val (&se, c->iterator->start);
1416 gfc_add_block_to_block (&implied_do_block, &se.pre);
1417 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1419 gfc_init_se (&se, NULL);
1420 gfc_conv_expr_val (&se, c->iterator->end);
1421 gfc_add_block_to_block (&implied_do_block, &se.pre);
1422 end = gfc_evaluate_now (se.expr, &implied_do_block);
1424 gfc_init_se (&se, NULL);
1425 gfc_conv_expr_val (&se, c->iterator->step);
1426 gfc_add_block_to_block (&implied_do_block, &se.pre);
1427 step = gfc_evaluate_now (se.expr, &implied_do_block);
1429 /* If this array expands dynamically, and the number of iterations
1430 is not constant, we won't have allocated space for the static
1431 part of C->EXPR's size. Do that now. */
1432 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1434 /* Get the number of iterations. */
1435 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1437 /* Get the static part of C->EXPR's size. */
1438 gfc_get_array_constructor_element_size (&size, c->expr);
1439 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1441 /* Grow the array by TMP * TMP2 elements. */
1442 tmp = fold_build2_loc (input_location, MULT_EXPR,
1443 gfc_array_index_type, tmp, tmp2);
1444 gfc_grow_array (&implied_do_block, desc, tmp);
1447 /* Generate the loop body. */
1448 exit_label = gfc_build_label_decl (NULL_TREE);
1449 gfc_start_block (&body);
1451 /* Generate the exit condition. Depending on the sign of
1452 the step variable we have to generate the correct
1454 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1455 step, build_int_cst (TREE_TYPE (step), 0));
1456 cond = fold_build3_loc (input_location, COND_EXPR,
1457 boolean_type_node, tmp,
1458 fold_build2_loc (input_location, GT_EXPR,
1459 boolean_type_node, shadow_loopvar, end),
1460 fold_build2_loc (input_location, LT_EXPR,
1461 boolean_type_node, shadow_loopvar, end));
1462 tmp = build1_v (GOTO_EXPR, exit_label);
1463 TREE_USED (exit_label) = 1;
1464 tmp = build3_v (COND_EXPR, cond, tmp,
1465 build_empty_stmt (input_location));
1466 gfc_add_expr_to_block (&body, tmp);
1468 /* The main loop body. */
1469 gfc_add_expr_to_block (&body, loopbody);
1471 /* Increase loop variable by step. */
1472 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1473 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1475 gfc_add_modify (&body, shadow_loopvar, tmp);
1477 /* Finish the loop. */
1478 tmp = gfc_finish_block (&body);
1479 tmp = build1_v (LOOP_EXPR, tmp);
1480 gfc_add_expr_to_block (&implied_do_block, tmp);
1482 /* Add the exit label. */
1483 tmp = build1_v (LABEL_EXPR, exit_label);
1484 gfc_add_expr_to_block (&implied_do_block, tmp);
1486 /* Finishe the implied-do loop. */
1487 tmp = gfc_finish_block(&implied_do_block);
1488 gfc_add_expr_to_block(pblock, tmp);
1490 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1497 /* Figure out the string length of a variable reference expression.
1498 Used by get_array_ctor_strlen. */
1501 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1507 /* Don't bother if we already know the length is a constant. */
1508 if (*len && INTEGER_CST_P (*len))
1511 ts = &expr->symtree->n.sym->ts;
1512 for (ref = expr->ref; ref; ref = ref->next)
1517 /* Array references don't change the string length. */
1521 /* Use the length of the component. */
1522 ts = &ref->u.c.component->ts;
1526 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1527 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1529 mpz_init_set_ui (char_len, 1);
1530 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1531 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1532 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1533 *len = convert (gfc_charlen_type_node, *len);
1534 mpz_clear (char_len);
1538 /* TODO: Substrings are tricky because we can't evaluate the
1539 expression more than once. For now we just give up, and hope
1540 we can figure it out elsewhere. */
1545 *len = ts->u.cl->backend_decl;
1549 /* A catch-all to obtain the string length for anything that is not a
1550 constant, array or variable. */
1552 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1557 /* Don't bother if we already know the length is a constant. */
1558 if (*len && INTEGER_CST_P (*len))
1561 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1562 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1565 gfc_conv_const_charlen (e->ts.u.cl);
1566 *len = e->ts.u.cl->backend_decl;
1570 /* Otherwise, be brutal even if inefficient. */
1571 ss = gfc_walk_expr (e);
1572 gfc_init_se (&se, NULL);
1574 /* No function call, in case of side effects. */
1575 se.no_function_call = 1;
1576 if (ss == gfc_ss_terminator)
1577 gfc_conv_expr (&se, e);
1579 gfc_conv_expr_descriptor (&se, e, ss);
1581 /* Fix the value. */
1582 *len = gfc_evaluate_now (se.string_length, &se.pre);
1584 gfc_add_block_to_block (block, &se.pre);
1585 gfc_add_block_to_block (block, &se.post);
1587 e->ts.u.cl->backend_decl = *len;
1592 /* Figure out the string length of a character array constructor.
1593 If len is NULL, don't calculate the length; this happens for recursive calls
1594 when a sub-array-constructor is an element but not at the first position,
1595 so when we're not interested in the length.
1596 Returns TRUE if all elements are character constants. */
1599 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1606 if (gfc_constructor_first (base) == NULL)
1609 *len = build_int_cstu (gfc_charlen_type_node, 0);
1613 /* Loop over all constructor elements to find out is_const, but in len we
1614 want to store the length of the first, not the last, element. We can
1615 of course exit the loop as soon as is_const is found to be false. */
1616 for (c = gfc_constructor_first (base);
1617 c && is_const; c = gfc_constructor_next (c))
1619 switch (c->expr->expr_type)
1622 if (len && !(*len && INTEGER_CST_P (*len)))
1623 *len = build_int_cstu (gfc_charlen_type_node,
1624 c->expr->value.character.length);
1628 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1635 get_array_ctor_var_strlen (c->expr, len);
1641 get_array_ctor_all_strlen (block, c->expr, len);
1645 /* After the first iteration, we don't want the length modified. */
1652 /* Check whether the array constructor C consists entirely of constant
1653 elements, and if so returns the number of those elements, otherwise
1654 return zero. Note, an empty or NULL array constructor returns zero. */
1656 unsigned HOST_WIDE_INT
1657 gfc_constant_array_constructor_p (gfc_constructor_base base)
1659 unsigned HOST_WIDE_INT nelem = 0;
1661 gfc_constructor *c = gfc_constructor_first (base);
1665 || c->expr->rank > 0
1666 || c->expr->expr_type != EXPR_CONSTANT)
1668 c = gfc_constructor_next (c);
1675 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1676 and the tree type of it's elements, TYPE, return a static constant
1677 variable that is compile-time initialized. */
1680 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1682 tree tmptype, init, tmp;
1683 HOST_WIDE_INT nelem;
1688 VEC(constructor_elt,gc) *v = NULL;
1690 /* First traverse the constructor list, converting the constants
1691 to tree to build an initializer. */
1693 c = gfc_constructor_first (expr->value.constructor);
1696 gfc_init_se (&se, NULL);
1697 gfc_conv_constant (&se, c->expr);
1698 if (c->expr->ts.type != BT_CHARACTER)
1699 se.expr = fold_convert (type, se.expr);
1700 else if (POINTER_TYPE_P (type))
1701 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1703 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1705 c = gfc_constructor_next (c);
1709 /* Next determine the tree type for the array. We use the gfortran
1710 front-end's gfc_get_nodesc_array_type in order to create a suitable
1711 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1713 memset (&as, 0, sizeof (gfc_array_spec));
1715 as.rank = expr->rank;
1716 as.type = AS_EXPLICIT;
1719 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1720 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1724 for (i = 0; i < expr->rank; i++)
1726 int tmp = (int) mpz_get_si (expr->shape[i]);
1727 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1728 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1732 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1734 init = build_constructor (tmptype, v);
1736 TREE_CONSTANT (init) = 1;
1737 TREE_STATIC (init) = 1;
1739 tmp = gfc_create_var (tmptype, "A");
1740 TREE_STATIC (tmp) = 1;
1741 TREE_CONSTANT (tmp) = 1;
1742 TREE_READONLY (tmp) = 1;
1743 DECL_INITIAL (tmp) = init;
1749 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1750 This mostly initializes the scalarizer state info structure with the
1751 appropriate values to directly use the array created by the function
1752 gfc_build_constant_array_constructor. */
1755 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1756 gfc_ss * ss, tree type)
1762 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1764 info = &ss->data.info;
1766 info->descriptor = tmp;
1767 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1768 info->offset = gfc_index_zero_node;
1770 for (i = 0; i < info->dimen; i++)
1772 info->delta[i] = gfc_index_zero_node;
1773 info->start[i] = gfc_index_zero_node;
1774 info->end[i] = gfc_index_zero_node;
1775 info->stride[i] = gfc_index_one_node;
1779 if (info->dimen > loop->temp_dim)
1780 loop->temp_dim = info->dimen;
1783 /* Helper routine of gfc_trans_array_constructor to determine if the
1784 bounds of the loop specified by LOOP are constant and simple enough
1785 to use with gfc_trans_constant_array_constructor. Returns the
1786 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1789 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1791 tree size = gfc_index_one_node;
1795 for (i = 0; i < loop->dimen; i++)
1797 /* If the bounds aren't constant, return NULL_TREE. */
1798 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1800 if (!integer_zerop (loop->from[i]))
1802 /* Only allow nonzero "from" in one-dimensional arrays. */
1803 if (loop->dimen != 1)
1805 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1806 gfc_array_index_type,
1807 loop->to[i], loop->from[i]);
1811 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1812 tmp, gfc_index_one_node);
1813 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1821 /* Array constructors are handled by constructing a temporary, then using that
1822 within the scalarization loop. This is not optimal, but seems by far the
1826 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1828 gfc_constructor_base c;
1834 bool old_first_len, old_typespec_chararray_ctor;
1835 tree old_first_len_val;
1837 /* Save the old values for nested checking. */
1838 old_first_len = first_len;
1839 old_first_len_val = first_len_val;
1840 old_typespec_chararray_ctor = typespec_chararray_ctor;
1842 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1843 typespec was given for the array constructor. */
1844 typespec_chararray_ctor = (ss->expr->ts.u.cl
1845 && ss->expr->ts.u.cl->length_from_typespec);
1847 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1848 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1850 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1854 ss->data.info.dimen = loop->dimen;
1856 c = ss->expr->value.constructor;
1857 if (ss->expr->ts.type == BT_CHARACTER)
1861 /* get_array_ctor_strlen walks the elements of the constructor, if a
1862 typespec was given, we already know the string length and want the one
1864 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1865 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1869 const_string = false;
1870 gfc_init_se (&length_se, NULL);
1871 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1872 gfc_charlen_type_node);
1873 ss->string_length = length_se.expr;
1874 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1875 gfc_add_block_to_block (&loop->post, &length_se.post);
1878 const_string = get_array_ctor_strlen (&loop->pre, c,
1879 &ss->string_length);
1881 /* Complex character array constructors should have been taken care of
1882 and not end up here. */
1883 gcc_assert (ss->string_length);
1885 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1887 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1889 type = build_pointer_type (type);
1892 type = gfc_typenode_for_spec (&ss->expr->ts);
1894 /* See if the constructor determines the loop bounds. */
1897 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1899 /* We have a multidimensional parameter. */
1901 for (n = 0; n < ss->expr->rank; n++)
1903 loop->from[n] = gfc_index_zero_node;
1904 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1905 gfc_index_integer_kind);
1906 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1907 gfc_array_index_type,
1908 loop->to[n], gfc_index_one_node);
1912 if (loop->to[0] == NULL_TREE)
1916 /* We should have a 1-dimensional, zero-based loop. */
1917 gcc_assert (loop->dimen == 1);
1918 gcc_assert (integer_zerop (loop->from[0]));
1920 /* Split the constructor size into a static part and a dynamic part.
1921 Allocate the static size up-front and record whether the dynamic
1922 size might be nonzero. */
1924 dynamic = gfc_get_array_constructor_size (&size, c);
1925 mpz_sub_ui (size, size, 1);
1926 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1930 /* Special case constant array constructors. */
1933 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1936 tree size = constant_array_constructor_loop_size (loop);
1937 if (size && compare_tree_int (size, nelem) == 0)
1939 gfc_trans_constant_array_constructor (loop, ss, type);
1945 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1946 type, NULL_TREE, dynamic, true, false, where);
1948 desc = ss->data.info.descriptor;
1949 offset = gfc_index_zero_node;
1950 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1951 TREE_NO_WARNING (offsetvar) = 1;
1952 TREE_USED (offsetvar) = 0;
1953 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1954 &offset, &offsetvar, dynamic);
1956 /* If the array grows dynamically, the upper bound of the loop variable
1957 is determined by the array's final upper bound. */
1959 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1961 if (TREE_USED (offsetvar))
1962 pushdecl (offsetvar);
1964 gcc_assert (INTEGER_CST_P (offset));
1966 /* Disable bound checking for now because it's probably broken. */
1967 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1974 /* Restore old values of globals. */
1975 first_len = old_first_len;
1976 first_len_val = old_first_len_val;
1977 typespec_chararray_ctor = old_typespec_chararray_ctor;
1981 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1982 called after evaluating all of INFO's vector dimensions. Go through
1983 each such vector dimension and see if we can now fill in any missing
1987 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1996 for (n = 0; n < loop->dimen; n++)
1999 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2000 && loop->to[n] == NULL)
2002 /* Loop variable N indexes vector dimension DIM, and we don't
2003 yet know the upper bound of loop variable N. Set it to the
2004 difference between the vector's upper and lower bounds. */
2005 gcc_assert (loop->from[n] == gfc_index_zero_node);
2006 gcc_assert (info->subscript[dim]
2007 && info->subscript[dim]->type == GFC_SS_VECTOR);
2009 gfc_init_se (&se, NULL);
2010 desc = info->subscript[dim]->data.info.descriptor;
2011 zero = gfc_rank_cst[0];
2012 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2013 gfc_array_index_type,
2014 gfc_conv_descriptor_ubound_get (desc, zero),
2015 gfc_conv_descriptor_lbound_get (desc, zero));
2016 tmp = gfc_evaluate_now (tmp, &loop->pre);
2023 /* Add the pre and post chains for all the scalar expressions in a SS chain
2024 to loop. This is called after the loop parameters have been calculated,
2025 but before the actual scalarizing loops. */
2028 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2034 /* TODO: This can generate bad code if there are ordering dependencies,
2035 e.g., a callee allocated function and an unknown size constructor. */
2036 gcc_assert (ss != NULL);
2038 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2045 /* Scalar expression. Evaluate this now. This includes elemental
2046 dimension indices, but not array section bounds. */
2047 gfc_init_se (&se, NULL);
2048 gfc_conv_expr (&se, ss->expr);
2049 gfc_add_block_to_block (&loop->pre, &se.pre);
2051 if (ss->expr->ts.type != BT_CHARACTER)
2053 /* Move the evaluation of scalar expressions outside the
2054 scalarization loop, except for WHERE assignments. */
2056 se.expr = convert(gfc_array_index_type, se.expr);
2058 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2059 gfc_add_block_to_block (&loop->pre, &se.post);
2062 gfc_add_block_to_block (&loop->post, &se.post);
2064 ss->data.scalar.expr = se.expr;
2065 ss->string_length = se.string_length;
2068 case GFC_SS_REFERENCE:
2069 /* Scalar argument to elemental procedure. Evaluate this
2071 gfc_init_se (&se, NULL);
2072 gfc_conv_expr (&se, ss->expr);
2073 gfc_add_block_to_block (&loop->pre, &se.pre);
2074 gfc_add_block_to_block (&loop->post, &se.post);
2076 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2077 ss->string_length = se.string_length;
2080 case GFC_SS_SECTION:
2081 /* Add the expressions for scalar and vector subscripts. */
2082 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2083 if (ss->data.info.subscript[n])
2084 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2087 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2091 /* Get the vector's descriptor and store it in SS. */
2092 gfc_init_se (&se, NULL);
2093 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2094 gfc_add_block_to_block (&loop->pre, &se.pre);
2095 gfc_add_block_to_block (&loop->post, &se.post);
2096 ss->data.info.descriptor = se.expr;
2099 case GFC_SS_INTRINSIC:
2100 gfc_add_intrinsic_ss_code (loop, ss);
2103 case GFC_SS_FUNCTION:
2104 /* Array function return value. We call the function and save its
2105 result in a temporary for use inside the loop. */
2106 gfc_init_se (&se, NULL);
2109 gfc_conv_expr (&se, ss->expr);
2110 gfc_add_block_to_block (&loop->pre, &se.pre);
2111 gfc_add_block_to_block (&loop->post, &se.post);
2112 ss->string_length = se.string_length;
2115 case GFC_SS_CONSTRUCTOR:
2116 if (ss->expr->ts.type == BT_CHARACTER
2117 && ss->string_length == NULL
2118 && ss->expr->ts.u.cl
2119 && ss->expr->ts.u.cl->length)
2121 gfc_init_se (&se, NULL);
2122 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2123 gfc_charlen_type_node);
2124 ss->string_length = se.expr;
2125 gfc_add_block_to_block (&loop->pre, &se.pre);
2126 gfc_add_block_to_block (&loop->post, &se.post);
2128 gfc_trans_array_constructor (loop, ss, where);
2132 case GFC_SS_COMPONENT:
2133 /* Do nothing. These are handled elsewhere. */
2143 /* Translate expressions for the descriptor and data pointer of a SS. */
2147 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2152 /* Get the descriptor for the array to be scalarized. */
2153 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2154 gfc_init_se (&se, NULL);
2155 se.descriptor_only = 1;
2156 gfc_conv_expr_lhs (&se, ss->expr);
2157 gfc_add_block_to_block (block, &se.pre);
2158 ss->data.info.descriptor = se.expr;
2159 ss->string_length = se.string_length;
2163 /* Also the data pointer. */
2164 tmp = gfc_conv_array_data (se.expr);
2165 /* If this is a variable or address of a variable we use it directly.
2166 Otherwise we must evaluate it now to avoid breaking dependency
2167 analysis by pulling the expressions for elemental array indices
2170 || (TREE_CODE (tmp) == ADDR_EXPR
2171 && DECL_P (TREE_OPERAND (tmp, 0)))))
2172 tmp = gfc_evaluate_now (tmp, block);
2173 ss->data.info.data = tmp;
2175 tmp = gfc_conv_array_offset (se.expr);
2176 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2181 /* Initialize a gfc_loopinfo structure. */
2184 gfc_init_loopinfo (gfc_loopinfo * loop)
2188 memset (loop, 0, sizeof (gfc_loopinfo));
2189 gfc_init_block (&loop->pre);
2190 gfc_init_block (&loop->post);
2192 /* Initially scalarize in order and default to no loop reversal. */
2193 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2196 loop->reverse[n] = GFC_CANNOT_REVERSE;
2199 loop->ss = gfc_ss_terminator;
2203 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2207 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2213 /* Return an expression for the data pointer of an array. */
2216 gfc_conv_array_data (tree descriptor)
2220 type = TREE_TYPE (descriptor);
2221 if (GFC_ARRAY_TYPE_P (type))
2223 if (TREE_CODE (type) == POINTER_TYPE)
2227 /* Descriptorless arrays. */
2228 return gfc_build_addr_expr (NULL_TREE, descriptor);
2232 return gfc_conv_descriptor_data_get (descriptor);
2236 /* Return an expression for the base offset of an array. */
2239 gfc_conv_array_offset (tree descriptor)
2243 type = TREE_TYPE (descriptor);
2244 if (GFC_ARRAY_TYPE_P (type))
2245 return GFC_TYPE_ARRAY_OFFSET (type);
2247 return gfc_conv_descriptor_offset_get (descriptor);
2251 /* Get an expression for the array stride. */
2254 gfc_conv_array_stride (tree descriptor, int dim)
2259 type = TREE_TYPE (descriptor);
2261 /* For descriptorless arrays use the array size. */
2262 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2263 if (tmp != NULL_TREE)
2266 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2271 /* Like gfc_conv_array_stride, but for the lower bound. */
2274 gfc_conv_array_lbound (tree descriptor, int dim)
2279 type = TREE_TYPE (descriptor);
2281 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2282 if (tmp != NULL_TREE)
2285 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2290 /* Like gfc_conv_array_stride, but for the upper bound. */
2293 gfc_conv_array_ubound (tree descriptor, int dim)
2298 type = TREE_TYPE (descriptor);
2300 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2301 if (tmp != NULL_TREE)
2304 /* This should only ever happen when passing an assumed shape array
2305 as an actual parameter. The value will never be used. */
2306 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2307 return gfc_index_zero_node;
2309 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2314 /* Generate code to perform an array index bound check. */
2317 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2318 locus * where, bool check_upper)
2321 tree tmp_lo, tmp_up;
2323 const char * name = NULL;
2325 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2328 index = gfc_evaluate_now (index, &se->pre);
2330 /* We find a name for the error message. */
2332 name = se->ss->expr->symtree->name;
2334 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2335 && se->loop->ss->expr->symtree)
2336 name = se->loop->ss->expr->symtree->name;
2338 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2339 && se->loop->ss->loop_chain->expr
2340 && se->loop->ss->loop_chain->expr->symtree)
2341 name = se->loop->ss->loop_chain->expr->symtree->name;
2343 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2345 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2346 && se->loop->ss->expr->value.function.name)
2347 name = se->loop->ss->expr->value.function.name;
2349 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2350 || se->loop->ss->type == GFC_SS_SCALAR)
2351 name = "unnamed constant";
2354 if (TREE_CODE (descriptor) == VAR_DECL)
2355 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2357 /* If upper bound is present, include both bounds in the error message. */
2360 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2361 tmp_up = gfc_conv_array_ubound (descriptor, n);
2364 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2365 "outside of expected range (%%ld:%%ld)", n+1, name);
2367 asprintf (&msg, "Index '%%ld' of dimension %d "
2368 "outside of expected range (%%ld:%%ld)", n+1);
2370 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2372 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2373 fold_convert (long_integer_type_node, index),
2374 fold_convert (long_integer_type_node, tmp_lo),
2375 fold_convert (long_integer_type_node, tmp_up));
2376 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2378 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2379 fold_convert (long_integer_type_node, index),
2380 fold_convert (long_integer_type_node, tmp_lo),
2381 fold_convert (long_integer_type_node, tmp_up));
2386 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2389 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2390 "below lower bound of %%ld", n+1, name);
2392 asprintf (&msg, "Index '%%ld' of dimension %d "
2393 "below lower bound of %%ld", n+1);
2395 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2397 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2398 fold_convert (long_integer_type_node, index),
2399 fold_convert (long_integer_type_node, tmp_lo));
2407 /* Return the offset for an index. Performs bound checking for elemental
2408 dimensions. Single element references are processed separately.
2409 DIM is the array dimension, I is the loop dimension. */
2412 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2413 gfc_array_ref * ar, tree stride)
2419 /* Get the index into the array for this dimension. */
2422 gcc_assert (ar->type != AR_ELEMENT);
2423 switch (ar->dimen_type[dim])
2426 /* Elemental dimension. */
2427 gcc_assert (info->subscript[dim]
2428 && info->subscript[dim]->type == GFC_SS_SCALAR);
2429 /* We've already translated this value outside the loop. */
2430 index = info->subscript[dim]->data.scalar.expr;
2432 index = gfc_trans_array_bound_check (se, info->descriptor,
2433 index, dim, &ar->where,
2434 ar->as->type != AS_ASSUMED_SIZE
2435 || dim < ar->dimen - 1);
2439 gcc_assert (info && se->loop);
2440 gcc_assert (info->subscript[dim]
2441 && info->subscript[dim]->type == GFC_SS_VECTOR);
2442 desc = info->subscript[dim]->data.info.descriptor;
2444 /* Get a zero-based index into the vector. */
2445 index = fold_build2_loc (input_location, MINUS_EXPR,
2446 gfc_array_index_type,
2447 se->loop->loopvar[i], se->loop->from[i]);
2449 /* Multiply the index by the stride. */
2450 index = fold_build2_loc (input_location, MULT_EXPR,
2451 gfc_array_index_type,
2452 index, gfc_conv_array_stride (desc, 0));
2454 /* Read the vector to get an index into info->descriptor. */
2455 data = build_fold_indirect_ref_loc (input_location,
2456 gfc_conv_array_data (desc));
2457 index = gfc_build_array_ref (data, index, NULL);
2458 index = gfc_evaluate_now (index, &se->pre);
2459 index = fold_convert (gfc_array_index_type, index);
2461 /* Do any bounds checking on the final info->descriptor index. */
2462 index = gfc_trans_array_bound_check (se, info->descriptor,
2463 index, dim, &ar->where,
2464 ar->as->type != AS_ASSUMED_SIZE
2465 || dim < ar->dimen - 1);
2469 /* Scalarized dimension. */
2470 gcc_assert (info && se->loop);
2472 /* Multiply the loop variable by the stride and delta. */
2473 index = se->loop->loopvar[i];
2474 if (!integer_onep (info->stride[dim]))
2475 index = fold_build2_loc (input_location, MULT_EXPR,
2476 gfc_array_index_type, index,
2478 if (!integer_zerop (info->delta[dim]))
2479 index = fold_build2_loc (input_location, PLUS_EXPR,
2480 gfc_array_index_type, index,
2490 /* Temporary array or derived type component. */
2491 gcc_assert (se->loop);
2492 index = se->loop->loopvar[se->loop->order[i]];
2493 if (!integer_zerop (info->delta[dim]))
2494 index = fold_build2_loc (input_location, PLUS_EXPR,
2495 gfc_array_index_type, index, info->delta[dim]);
2498 /* Multiply by the stride. */
2499 if (!integer_onep (stride))
2500 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2507 /* Build a scalarized reference to an array. */
2510 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2513 tree decl = NULL_TREE;
2518 info = &se->ss->data.info;
2520 n = se->loop->order[0];
2524 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2526 /* Add the offset for this dimension to the stored offset for all other
2528 if (!integer_zerop (info->offset))
2529 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2530 index, info->offset);
2532 if (se->ss->expr && is_subref_array (se->ss->expr))
2533 decl = se->ss->expr->symtree->n.sym->backend_decl;
2535 tmp = build_fold_indirect_ref_loc (input_location,
2537 se->expr = gfc_build_array_ref (tmp, index, decl);
2541 /* Translate access of temporary array. */
2544 gfc_conv_tmp_array_ref (gfc_se * se)
2546 se->string_length = se->ss->string_length;
2547 gfc_conv_scalarized_array_ref (se, NULL);
2551 /* Build an array reference. se->expr already holds the array descriptor.
2552 This should be either a variable, indirect variable reference or component
2553 reference. For arrays which do not have a descriptor, se->expr will be
2555 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2558 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2571 /* Handle scalarized references separately. */
2572 if (ar->type != AR_ELEMENT)
2574 gfc_conv_scalarized_array_ref (se, ar);
2575 gfc_advance_se_ss_chain (se);
2579 index = gfc_index_zero_node;
2581 /* Calculate the offsets from all the dimensions. */
2582 for (n = 0; n < ar->dimen; n++)
2584 /* Calculate the index for this dimension. */
2585 gfc_init_se (&indexse, se);
2586 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2587 gfc_add_block_to_block (&se->pre, &indexse.pre);
2589 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2591 /* Check array bounds. */
2595 /* Evaluate the indexse.expr only once. */
2596 indexse.expr = save_expr (indexse.expr);
2599 tmp = gfc_conv_array_lbound (se->expr, n);
2600 if (sym->attr.temporary)
2602 gfc_init_se (&tmpse, se);
2603 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2604 gfc_array_index_type);
2605 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2609 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2611 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2612 "below lower bound of %%ld", n+1, sym->name);
2613 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2614 fold_convert (long_integer_type_node,
2616 fold_convert (long_integer_type_node, tmp));
2619 /* Upper bound, but not for the last dimension of assumed-size
2621 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2623 tmp = gfc_conv_array_ubound (se->expr, n);
2624 if (sym->attr.temporary)
2626 gfc_init_se (&tmpse, se);
2627 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2628 gfc_array_index_type);
2629 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2633 cond = fold_build2_loc (input_location, GT_EXPR,
2634 boolean_type_node, indexse.expr, tmp);
2635 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2636 "above upper bound of %%ld", n+1, sym->name);
2637 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2638 fold_convert (long_integer_type_node,
2640 fold_convert (long_integer_type_node, tmp));
2645 /* Multiply the index by the stride. */
2646 stride = gfc_conv_array_stride (se->expr, n);
2647 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2648 indexse.expr, stride);
2650 /* And add it to the total. */
2651 index = fold_build2_loc (input_location, PLUS_EXPR,
2652 gfc_array_index_type, index, tmp);
2655 tmp = gfc_conv_array_offset (se->expr);
2656 if (!integer_zerop (tmp))
2657 index = fold_build2_loc (input_location, PLUS_EXPR,
2658 gfc_array_index_type, index, tmp);
2660 /* Access the calculated element. */
2661 tmp = gfc_conv_array_data (se->expr);
2662 tmp = build_fold_indirect_ref (tmp);
2663 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2667 /* Generate the code to be executed immediately before entering a
2668 scalarization loop. */
2671 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2672 stmtblock_t * pblock)
2681 /* This code will be executed before entering the scalarization loop
2682 for this dimension. */
2683 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2685 if ((ss->useflags & flag) == 0)
2688 if (ss->type != GFC_SS_SECTION
2689 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2690 && ss->type != GFC_SS_COMPONENT)
2693 info = &ss->data.info;
2695 if (dim >= info->dimen)
2698 if (dim == info->dimen - 1)
2700 /* For the outermost loop calculate the offset due to any
2701 elemental dimensions. It will have been initialized with the
2702 base offset of the array. */
2705 for (i = 0; i < info->ref->u.ar.dimen; i++)
2707 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2710 gfc_init_se (&se, NULL);
2712 se.expr = info->descriptor;
2713 stride = gfc_conv_array_stride (info->descriptor, i);
2714 index = gfc_conv_array_index_offset (&se, info, i, -1,
2717 gfc_add_block_to_block (pblock, &se.pre);
2719 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2720 gfc_array_index_type,
2721 info->offset, index);
2722 info->offset = gfc_evaluate_now (info->offset, pblock);
2727 /* For the time being, the innermost loop is unconditionally on
2728 the first dimension of the scalarization loop. */
2729 gcc_assert (i == 0);
2730 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2732 /* Calculate the stride of the innermost loop. Hopefully this will
2733 allow the backend optimizers to do their stuff more effectively.
2735 info->stride0 = gfc_evaluate_now (stride, pblock);
2739 /* Add the offset for the previous loop dimension. */
2744 ar = &info->ref->u.ar;
2745 i = loop->order[dim + 1];
2753 gfc_init_se (&se, NULL);
2755 se.expr = info->descriptor;
2756 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2757 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2759 gfc_add_block_to_block (pblock, &se.pre);
2760 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2761 gfc_array_index_type, info->offset,
2763 info->offset = gfc_evaluate_now (info->offset, pblock);
2766 /* Remember this offset for the second loop. */
2767 if (dim == loop->temp_dim - 1)
2768 info->saved_offset = info->offset;
2773 /* Start a scalarized expression. Creates a scope and declares loop
2777 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2783 gcc_assert (!loop->array_parameter);
2785 for (dim = loop->dimen - 1; dim >= 0; dim--)
2787 n = loop->order[dim];
2789 gfc_start_block (&loop->code[n]);
2791 /* Create the loop variable. */
2792 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2794 if (dim < loop->temp_dim)
2798 /* Calculate values that will be constant within this loop. */
2799 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2801 gfc_start_block (pbody);
2805 /* Generates the actual loop code for a scalarization loop. */
2808 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2809 stmtblock_t * pbody)
2820 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2821 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2822 && n == loop->dimen - 1)
2824 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2825 init = make_tree_vec (1);
2826 cond = make_tree_vec (1);
2827 incr = make_tree_vec (1);
2829 /* Cycle statement is implemented with a goto. Exit statement must not
2830 be present for this loop. */
2831 exit_label = gfc_build_label_decl (NULL_TREE);
2832 TREE_USED (exit_label) = 1;
2834 /* Label for cycle statements (if needed). */
2835 tmp = build1_v (LABEL_EXPR, exit_label);
2836 gfc_add_expr_to_block (pbody, tmp);
2838 stmt = make_node (OMP_FOR);
2840 TREE_TYPE (stmt) = void_type_node;
2841 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2843 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2844 OMP_CLAUSE_SCHEDULE);
2845 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2846 = OMP_CLAUSE_SCHEDULE_STATIC;
2847 if (ompws_flags & OMPWS_NOWAIT)
2848 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2849 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2851 /* Initialize the loopvar. */
2852 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2854 OMP_FOR_INIT (stmt) = init;
2855 /* The exit condition. */
2856 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2858 loop->loopvar[n], loop->to[n]);
2859 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2860 OMP_FOR_COND (stmt) = cond;
2861 /* Increment the loopvar. */
2862 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2863 loop->loopvar[n], gfc_index_one_node);
2864 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2865 void_type_node, loop->loopvar[n], tmp);
2866 OMP_FOR_INCR (stmt) = incr;
2868 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2869 gfc_add_expr_to_block (&loop->code[n], stmt);
2873 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2874 && (loop->temp_ss == NULL);
2876 loopbody = gfc_finish_block (pbody);
2880 tmp = loop->from[n];
2881 loop->from[n] = loop->to[n];
2885 /* Initialize the loopvar. */
2886 if (loop->loopvar[n] != loop->from[n])
2887 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2889 exit_label = gfc_build_label_decl (NULL_TREE);
2891 /* Generate the loop body. */
2892 gfc_init_block (&block);
2894 /* The exit condition. */
2895 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2896 boolean_type_node, loop->loopvar[n], loop->to[n]);
2897 tmp = build1_v (GOTO_EXPR, exit_label);
2898 TREE_USED (exit_label) = 1;
2899 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2900 gfc_add_expr_to_block (&block, tmp);
2902 /* The main body. */
2903 gfc_add_expr_to_block (&block, loopbody);
2905 /* Increment the loopvar. */
2906 tmp = fold_build2_loc (input_location,
2907 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2908 gfc_array_index_type, loop->loopvar[n],
2909 gfc_index_one_node);
2911 gfc_add_modify (&block, loop->loopvar[n], tmp);
2913 /* Build the loop. */
2914 tmp = gfc_finish_block (&block);
2915 tmp = build1_v (LOOP_EXPR, tmp);
2916 gfc_add_expr_to_block (&loop->code[n], tmp);
2918 /* Add the exit label. */
2919 tmp = build1_v (LABEL_EXPR, exit_label);
2920 gfc_add_expr_to_block (&loop->code[n], tmp);
2926 /* Finishes and generates the loops for a scalarized expression. */
2929 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2934 stmtblock_t *pblock;
2938 /* Generate the loops. */
2939 for (dim = 0; dim < loop->dimen; dim++)
2941 n = loop->order[dim];
2942 gfc_trans_scalarized_loop_end (loop, n, pblock);
2943 loop->loopvar[n] = NULL_TREE;
2944 pblock = &loop->code[n];
2947 tmp = gfc_finish_block (pblock);
2948 gfc_add_expr_to_block (&loop->pre, tmp);
2950 /* Clear all the used flags. */
2951 for (ss = loop->ss; ss; ss = ss->loop_chain)
2956 /* Finish the main body of a scalarized expression, and start the secondary
2960 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2964 stmtblock_t *pblock;
2968 /* We finish as many loops as are used by the temporary. */
2969 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2971 n = loop->order[dim];
2972 gfc_trans_scalarized_loop_end (loop, n, pblock);
2973 loop->loopvar[n] = NULL_TREE;
2974 pblock = &loop->code[n];
2977 /* We don't want to finish the outermost loop entirely. */
2978 n = loop->order[loop->temp_dim - 1];
2979 gfc_trans_scalarized_loop_end (loop, n, pblock);
2981 /* Restore the initial offsets. */
2982 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2984 if ((ss->useflags & 2) == 0)
2987 if (ss->type != GFC_SS_SECTION
2988 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2989 && ss->type != GFC_SS_COMPONENT)
2992 ss->data.info.offset = ss->data.info.saved_offset;
2995 /* Restart all the inner loops we just finished. */
2996 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2998 n = loop->order[dim];
3000 gfc_start_block (&loop->code[n]);
3002 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3004 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3007 /* Start a block for the secondary copying code. */
3008 gfc_start_block (body);
3012 /* Calculate the lower bound of an array section. */
3015 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3024 gcc_assert (ss->type == GFC_SS_SECTION);
3026 info = &ss->data.info;
3028 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3030 /* We use a zero-based index to access the vector. */
3031 info->start[dim] = gfc_index_zero_node;
3032 info->stride[dim] = gfc_index_one_node;
3033 info->end[dim] = NULL;
3037 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3038 desc = info->descriptor;
3039 start = info->ref->u.ar.start[dim];
3040 end = info->ref->u.ar.end[dim];
3041 stride = info->ref->u.ar.stride[dim];
3043 /* Calculate the start of the range. For vector subscripts this will
3044 be the range of the vector. */
3047 /* Specified section start. */
3048 gfc_init_se (&se, NULL);
3049 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3050 gfc_add_block_to_block (&loop->pre, &se.pre);
3051 info->start[dim] = se.expr;
3055 /* No lower bound specified so use the bound of the array. */
3056 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3058 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3060 /* Similarly calculate the end. Although this is not used in the
3061 scalarizer, it is needed when checking bounds and where the end
3062 is an expression with side-effects. */
3065 /* Specified section start. */
3066 gfc_init_se (&se, NULL);
3067 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3068 gfc_add_block_to_block (&loop->pre, &se.pre);
3069 info->end[dim] = se.expr;
3073 /* No upper bound specified so use the bound of the array. */
3074 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3076 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3078 /* Calculate the stride. */
3080 info->stride[dim] = gfc_index_one_node;
3083 gfc_init_se (&se, NULL);
3084 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3085 gfc_add_block_to_block (&loop->pre, &se.pre);
3086 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3091 /* Calculates the range start and stride for a SS chain. Also gets the
3092 descriptor and data pointer. The range of vector subscripts is the size
3093 of the vector. Array bounds are also checked. */
3096 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3104 /* Determine the rank of the loop. */
3106 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3110 case GFC_SS_SECTION:
3111 case GFC_SS_CONSTRUCTOR:
3112 case GFC_SS_FUNCTION:
3113 case GFC_SS_COMPONENT:
3114 loop->dimen = ss->data.info.dimen;
3117 /* As usual, lbound and ubound are exceptions!. */
3118 case GFC_SS_INTRINSIC:
3119 switch (ss->expr->value.function.isym->id)
3121 case GFC_ISYM_LBOUND:
3122 case GFC_ISYM_UBOUND:
3123 loop->dimen = ss->data.info.dimen;
3134 /* We should have determined the rank of the expression by now. If
3135 not, that's bad news. */
3136 gcc_assert (loop->dimen != 0);
3138 /* Loop over all the SS in the chain. */
3139 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3141 if (ss->expr && ss->expr->shape && !ss->shape)
3142 ss->shape = ss->expr->shape;
3146 case GFC_SS_SECTION:
3147 /* Get the descriptor for the array. */
3148 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3150 for (n = 0; n < ss->data.info.dimen; n++)
3151 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
3154 case GFC_SS_INTRINSIC:
3155 switch (ss->expr->value.function.isym->id)
3157 /* Fall through to supply start and stride. */
3158 case GFC_ISYM_LBOUND:
3159 case GFC_ISYM_UBOUND:
3165 case GFC_SS_CONSTRUCTOR:
3166 case GFC_SS_FUNCTION:
3167 for (n = 0; n < ss->data.info.dimen; n++)
3169 ss->data.info.start[n] = gfc_index_zero_node;
3170 ss->data.info.end[n] = gfc_index_zero_node;
3171 ss->data.info.stride[n] = gfc_index_one_node;
3180 /* The rest is just runtime bound checking. */
3181 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3184 tree lbound, ubound;
3186 tree size[GFC_MAX_DIMENSIONS];
3187 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3192 gfc_start_block (&block);
3194 for (n = 0; n < loop->dimen; n++)
3195 size[n] = NULL_TREE;
3197 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3201 if (ss->type != GFC_SS_SECTION)
3204 gfc_start_block (&inner);
3206 /* TODO: range checking for mapped dimensions. */
3207 info = &ss->data.info;
3209 /* This code only checks ranges. Elemental and vector
3210 dimensions are checked later. */
3211 for (n = 0; n < loop->dimen; n++)
3216 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3219 if (dim == info->ref->u.ar.dimen - 1
3220 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3221 check_upper = false;
3225 /* Zero stride is not allowed. */
3226 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3227 info->stride[dim], gfc_index_zero_node);
3228 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3229 "of array '%s'", dim + 1, ss->expr->symtree->name);
3230 gfc_trans_runtime_check (true, false, tmp, &inner,
3231 &ss->expr->where, msg);
3234 desc = ss->data.info.descriptor;
3236 /* This is the run-time equivalent of resolve.c's
3237 check_dimension(). The logical is more readable there
3238 than it is here, with all the trees. */
3239 lbound = gfc_conv_array_lbound (desc, dim);
3240 end = info->end[dim];
3242 ubound = gfc_conv_array_ubound (desc, dim);
3246 /* non_zerosized is true when the selected range is not
3248 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3249 boolean_type_node, info->stride[dim],
3250 gfc_index_zero_node);
3251 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3252 info->start[dim], end);
3253 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3254 boolean_type_node, stride_pos, tmp);
3256 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3258 info->stride[dim], gfc_index_zero_node);
3259 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3260 info->start[dim], end);
3261 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3264 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3266 stride_pos, stride_neg);
3268 /* Check the start of the range against the lower and upper
3269 bounds of the array, if the range is not empty.
3270 If upper bound is present, include both bounds in the
3274 tmp = fold_build2_loc (input_location, LT_EXPR,
3276 info->start[dim], lbound);
3277 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3279 non_zerosized, tmp);
3280 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3282 info->start[dim], ubound);
3283 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3285 non_zerosized, tmp2);
3286 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3287 "outside of expected range (%%ld:%%ld)",
3288 dim + 1, ss->expr->symtree->name);
3289 gfc_trans_runtime_check (true, false, tmp, &inner,
3290 &ss->expr->where, msg,
3291 fold_convert (long_integer_type_node, info->start[dim]),
3292 fold_convert (long_integer_type_node, lbound),
3293 fold_convert (long_integer_type_node, ubound));
3294 gfc_trans_runtime_check (true, false, tmp2, &inner,
3295 &ss->expr->where, msg,
3296 fold_convert (long_integer_type_node, info->start[dim]),
3297 fold_convert (long_integer_type_node, lbound),
3298 fold_convert (long_integer_type_node, ubound));
3303 tmp = fold_build2_loc (input_location, LT_EXPR,
3305 info->start[dim], lbound);
3306 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3307 boolean_type_node, non_zerosized, tmp);
3308 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3309 "below lower bound of %%ld",
3310 dim + 1, ss->expr->symtree->name);
3311 gfc_trans_runtime_check (true, false, tmp, &inner,
3312 &ss->expr->where, msg,
3313 fold_convert (long_integer_type_node, info->start[dim]),
3314 fold_convert (long_integer_type_node, lbound));
3318 /* Compute the last element of the range, which is not
3319 necessarily "end" (think 0:5:3, which doesn't contain 5)
3320 and check it against both lower and upper bounds. */
3322 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3323 gfc_array_index_type, end,
3325 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3326 gfc_array_index_type, tmp,
3328 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3329 gfc_array_index_type, end, tmp);
3330 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3331 boolean_type_node, tmp, lbound);
3332 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3333 boolean_type_node, non_zerosized, tmp2);
3336 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3337 boolean_type_node, tmp, ubound);
3338 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3339 boolean_type_node, non_zerosized, tmp3);
3340 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3341 "outside of expected range (%%ld:%%ld)",
3342 dim + 1, ss->expr->symtree->name);
3343 gfc_trans_runtime_check (true, false, tmp2, &inner,
3344 &ss->expr->where, msg,
3345 fold_convert (long_integer_type_node, tmp),
3346 fold_convert (long_integer_type_node, ubound),
3347 fold_convert (long_integer_type_node, lbound));
3348 gfc_trans_runtime_check (true, false, tmp3, &inner,
3349 &ss->expr->where, msg,
3350 fold_convert (long_integer_type_node, tmp),
3351 fold_convert (long_integer_type_node, ubound),
3352 fold_convert (long_integer_type_node, lbound));
3357 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3358 "below lower bound of %%ld",
3359 dim + 1, ss->expr->symtree->name);
3360 gfc_trans_runtime_check (true, false, tmp2, &inner,
3361 &ss->expr->where, msg,
3362 fold_convert (long_integer_type_node, tmp),
3363 fold_convert (long_integer_type_node, lbound));
3367 /* Check the section sizes match. */
3368 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3369 gfc_array_index_type, end,
3371 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3372 gfc_array_index_type, tmp,
3374 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3375 gfc_array_index_type,
3376 gfc_index_one_node, tmp);
3377 tmp = fold_build2_loc (input_location, MAX_EXPR,
3378 gfc_array_index_type, tmp,
3379 build_int_cst (gfc_array_index_type, 0));
3380 /* We remember the size of the first section, and check all the
3381 others against this. */
3384 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3385 boolean_type_node, tmp, size[n]);
3386 asprintf (&msg, "Array bound mismatch for dimension %d "
3387 "of array '%s' (%%ld/%%ld)",
3388 dim + 1, ss->expr->symtree->name);
3390 gfc_trans_runtime_check (true, false, tmp3, &inner,
3391 &ss->expr->where, msg,
3392 fold_convert (long_integer_type_node, tmp),
3393 fold_convert (long_integer_type_node, size[n]));
3398 size[n] = gfc_evaluate_now (tmp, &inner);
3401 tmp = gfc_finish_block (&inner);
3403 /* For optional arguments, only check bounds if the argument is
3405 if (ss->expr->symtree->n.sym->attr.optional
3406 || ss->expr->symtree->n.sym->attr.not_always_present)
3407 tmp = build3_v (COND_EXPR,
3408 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3409 tmp, build_empty_stmt (input_location));
3411 gfc_add_expr_to_block (&block, tmp);
3415 tmp = gfc_finish_block (&block);
3416 gfc_add_expr_to_block (&loop->pre, tmp);
3421 /* Return true if the two SS could be aliased, i.e. both point to the same data
3423 /* TODO: resolve aliases based on frontend expressions. */
3426 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3433 lsym = lss->expr->symtree->n.sym;
3434 rsym = rss->expr->symtree->n.sym;
3435 if (gfc_symbols_could_alias (lsym, rsym))
3438 if (rsym->ts.type != BT_DERIVED
3439 && lsym->ts.type != BT_DERIVED)
3442 /* For derived types we must check all the component types. We can ignore
3443 array references as these will have the same base type as the previous
3445 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3447 if (lref->type != REF_COMPONENT)
3450 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3453 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3456 if (rref->type != REF_COMPONENT)
3459 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3464 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3466 if (rref->type != REF_COMPONENT)
3469 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3477 /* Resolve array data dependencies. Creates a temporary if required. */
3478 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3482 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3491 loop->temp_ss = NULL;
3493 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3495 if (ss->type != GFC_SS_SECTION)
3498 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3500 if (gfc_could_be_alias (dest, ss)
3501 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3509 lref = dest->expr->ref;
3510 rref = ss->expr->ref;
3512 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3517 for (i = 0; i < dest->data.info.dimen; i++)
3518 for (j = 0; j < ss->data.info.dimen; j++)
3520 && dest->data.info.dim[i] == ss->data.info.dim[j])
3522 /* If we don't access array elements in the same order,
3523 there is a dependency. */
3528 /* TODO : loop shifting. */
3531 /* Mark the dimensions for LOOP SHIFTING */
3532 for (n = 0; n < loop->dimen; n++)
3534 int dim = dest->data.info.dim[n];
3536 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3538 else if (! gfc_is_same_range (&lref->u.ar,
3539 &rref->u.ar, dim, 0))
3543 /* Put all the dimensions with dependencies in the
3546 for (n = 0; n < loop->dimen; n++)
3548 gcc_assert (loop->order[n] == n);
3550 loop->order[dim++] = n;
3552 for (n = 0; n < loop->dimen; n++)
3555 loop->order[dim++] = n;
3558 gcc_assert (dim == loop->dimen);
3569 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3570 if (GFC_ARRAY_TYPE_P (base_type)
3571 || GFC_DESCRIPTOR_TYPE_P (base_type))
3572 base_type = gfc_get_element_type (base_type);
3573 loop->temp_ss = gfc_get_ss ();
3574 loop->temp_ss->type = GFC_SS_TEMP;
3575 loop->temp_ss->data.temp.type = base_type;
3576 loop->temp_ss->string_length = dest->string_length;
3577 loop->temp_ss->data.temp.dimen = loop->dimen;
3578 loop->temp_ss->next = gfc_ss_terminator;
3579 gfc_add_ss_to_loop (loop, loop->temp_ss);
3582 loop->temp_ss = NULL;
3586 /* Initialize the scalarization loop. Creates the loop variables. Determines
3587 the range of the loop variables. Creates a temporary if required.
3588 Calculates how to transform from loop variables to array indices for each
3589 expression. Also generates code for scalar expressions which have been
3590 moved outside the loop. */
3593 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3595 int n, dim, spec_dim;
3597 gfc_ss_info *specinfo;
3600 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3601 bool dynamic[GFC_MAX_DIMENSIONS];
3606 for (n = 0; n < loop->dimen; n++)
3610 /* We use one SS term, and use that to determine the bounds of the
3611 loop for this dimension. We try to pick the simplest term. */
3612 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3614 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3617 info = &ss->data.info;
3620 if (loopspec[n] != NULL)
3622 specinfo = &loopspec[n]->data.info;
3623 spec_dim = specinfo->dim[n];
3627 /* Silence unitialized warnings. */
3634 gcc_assert (ss->shape[dim]);
3635 /* The frontend has worked out the size for us. */
3637 || !loopspec[n]->shape
3638 || !integer_zerop (specinfo->start[spec_dim]))
3639 /* Prefer zero-based descriptors if possible. */
3644 if (ss->type == GFC_SS_CONSTRUCTOR)
3646 gfc_constructor_base base;
3647 /* An unknown size constructor will always be rank one.
3648 Higher rank constructors will either have known shape,
3649 or still be wrapped in a call to reshape. */
3650 gcc_assert (loop->dimen == 1);
3652 /* Always prefer to use the constructor bounds if the size
3653 can be determined at compile time. Prefer not to otherwise,
3654 since the general case involves realloc, and it's better to
3655 avoid that overhead if possible. */
3656 base = ss->expr->value.constructor;
3657 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3658 if (!dynamic[n] || !loopspec[n])
3663 /* TODO: Pick the best bound if we have a choice between a
3664 function and something else. */
3665 if (ss->type == GFC_SS_FUNCTION)
3671 if (ss->type != GFC_SS_SECTION)
3676 /* Criteria for choosing a loop specifier (most important first):
3677 doesn't need realloc
3683 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3685 else if (integer_onep (info->stride[dim])
3686 && !integer_onep (specinfo->stride[spec_dim]))
3688 else if (INTEGER_CST_P (info->stride[dim])
3689 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3691 else if (INTEGER_CST_P (info->start[dim])
3692 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3694 /* We don't work out the upper bound.
3695 else if (INTEGER_CST_P (info->finish[n])
3696 && ! INTEGER_CST_P (specinfo->finish[n]))
3697 loopspec[n] = ss; */
3700 /* We should have found the scalarization loop specifier. If not,
3702 gcc_assert (loopspec[n]);
3704 info = &loopspec[n]->data.info;
3707 /* Set the extents of this range. */
3708 cshape = loopspec[n]->shape;
3709 if (cshape && INTEGER_CST_P (info->start[dim])
3710 && INTEGER_CST_P (info->stride[dim]))
3712 loop->from[n] = info->start[dim];
3713 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3714 mpz_sub_ui (i, i, 1);
3715 /* To = from + (size - 1) * stride. */
3716 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3717 if (!integer_onep (info->stride[dim]))
3718 tmp = fold_build2_loc (input_location, MULT_EXPR,
3719 gfc_array_index_type, tmp,
3721 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3722 gfc_array_index_type,
3723 loop->from[n], tmp);
3727 loop->from[n] = info->start[dim];
3728 switch (loopspec[n]->type)
3730 case GFC_SS_CONSTRUCTOR:
3731 /* The upper bound is calculated when we expand the
3733 gcc_assert (loop->to[n] == NULL_TREE);
3736 case GFC_SS_SECTION:
3737 /* Use the end expression if it exists and is not constant,
3738 so that it is only evaluated once. */
3739 loop->to[n] = info->end[dim];
3742 case GFC_SS_FUNCTION:
3743 /* The loop bound will be set when we generate the call. */
3744 gcc_assert (loop->to[n] == NULL_TREE);
3752 /* Transform everything so we have a simple incrementing variable. */
3753 if (integer_onep (info->stride[dim]))
3754 info->delta[dim] = gfc_index_zero_node;
3757 /* Set the delta for this section. */
3758 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3759 /* Number of iterations is (end - start + step) / step.
3760 with start = 0, this simplifies to
3762 for (i = 0; i<=last; i++){...}; */
3763 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3764 gfc_array_index_type, loop->to[n],
3766 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3767 gfc_array_index_type, tmp, info->stride[dim]);
3768 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3769 tmp, build_int_cst (gfc_array_index_type, -1));
3770 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3771 /* Make the loop variable start at 0. */
3772 loop->from[n] = gfc_index_zero_node;
3776 /* Add all the scalar code that can be taken out of the loops.
3777 This may include calculating the loop bounds, so do it before
3778 allocating the temporary. */
3779 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3781 /* If we want a temporary then create it. */
3782 if (loop->temp_ss != NULL)
3784 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3786 /* Make absolutely sure that this is a complete type. */
3787 if (loop->temp_ss->string_length)
3788 loop->temp_ss->data.temp.type
3789 = gfc_get_character_type_len_for_eltype
3790 (TREE_TYPE (loop->temp_ss->data.temp.type),
3791 loop->temp_ss->string_length);
3793 tmp = loop->temp_ss->data.temp.type;
3794 n = loop->temp_ss->data.temp.dimen;
3795 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3796 loop->temp_ss->type = GFC_SS_SECTION;
3797 loop->temp_ss->data.info.dimen = n;
3799 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3800 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3801 loop->temp_ss->data.info.dim[n] = n;
3803 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3804 &loop->temp_ss->data.info, tmp, NULL_TREE,
3805 false, true, false, where);
3808 for (n = 0; n < loop->temp_dim; n++)
3809 loopspec[loop->order[n]] = NULL;
3813 /* For array parameters we don't have loop variables, so don't calculate the
3815 if (loop->array_parameter)
3818 /* Calculate the translation from loop variables to array indices. */
3819 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3821 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3822 && ss->type != GFC_SS_CONSTRUCTOR)
3826 info = &ss->data.info;
3828 for (n = 0; n < info->dimen; n++)
3830 /* If we are specifying the range the delta is already set. */
3831 if (loopspec[n] != ss)
3833 dim = ss->data.info.dim[n];
3835 /* Calculate the offset relative to the loop variable.
3836 First multiply by the stride. */
3837 tmp = loop->from[n];
3838 if (!integer_onep (info->stride[dim]))
3839 tmp = fold_build2_loc (input_location, MULT_EXPR,
3840 gfc_array_index_type,
3841 tmp, info->stride[dim]);
3843 /* Then subtract this from our starting value. */
3844 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3845 gfc_array_index_type,
3846 info->start[dim], tmp);
3848 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
3855 /* Calculate the size of a given array dimension from the bounds. This
3856 is simply (ubound - lbound + 1) if this expression is positive
3857 or 0 if it is negative (pick either one if it is zero). Optionally
3858 (if or_expr is present) OR the (expression != 0) condition to it. */
3861 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
3866 /* Calculate (ubound - lbound + 1). */
3867 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3869 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
3870 gfc_index_one_node);
3872 /* Check whether the size for this dimension is negative. */
3873 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
3874 gfc_index_zero_node);
3875 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
3876 gfc_index_zero_node, res);
3878 /* Build OR expression. */
3880 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3881 boolean_type_node, *or_expr, cond);
3887 /* For an array descriptor, get the total number of elements. This is just
3888 the product of the extents along all dimensions. */
3891 gfc_conv_descriptor_size (tree desc, int rank)
3896 res = gfc_index_one_node;
3898 for (dim = 0; dim < rank; ++dim)
3904 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
3905 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
3907 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
3908 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3916 /* Fills in an array descriptor, and returns the size of the array. The size
3917 will be a simple_val, ie a variable or a constant. Also calculates the
3918 offset of the base. Returns the size of the array.
3922 for (n = 0; n < rank; n++)
3924 a.lbound[n] = specified_lower_bound;
3925 offset = offset + a.lbond[n] * stride;
3927 a.ubound[n] = specified_upper_bound;
3928 a.stride[n] = stride;
3929 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3930 stride = stride * size;
3937 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
3938 gfc_expr ** lower, gfc_expr ** upper,
3939 stmtblock_t * pblock)
3950 stmtblock_t thenblock;
3951 stmtblock_t elseblock;
3956 type = TREE_TYPE (descriptor);
3958 stride = gfc_index_one_node;
3959 offset = gfc_index_zero_node;
3961 /* Set the dtype. */
3962 tmp = gfc_conv_descriptor_dtype (descriptor);
3963 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3965 or_expr = boolean_false_node;
3967 for (n = 0; n < rank; n++)
3972 /* We have 3 possibilities for determining the size of the array:
3973 lower == NULL => lbound = 1, ubound = upper[n]
3974 upper[n] = NULL => lbound = 1, ubound = lower[n]
3975 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3978 /* Set lower bound. */
3979 gfc_init_se (&se, NULL);
3981 se.expr = gfc_index_one_node;
3984 gcc_assert (lower[n]);
3987 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3988 gfc_add_block_to_block (pblock, &se.pre);
3992 se.expr = gfc_index_one_node;
3996 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3998 conv_lbound = se.expr;
4000 /* Work out the offset for this component. */
4001 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4003 offset = fold_build2_loc (input_location, MINUS_EXPR,
4004 gfc_array_index_type, offset, tmp);
4006 /* Set upper bound. */
4007 gfc_init_se (&se, NULL);
4008 gcc_assert (ubound);
4009 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4010 gfc_add_block_to_block (pblock, &se.pre);
4012 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4013 gfc_rank_cst[n], se.expr);
4014 conv_ubound = se.expr;
4016 /* Store the stride. */
4017 gfc_conv_descriptor_stride_set (pblock, descriptor,
4018 gfc_rank_cst[n], stride);
4020 /* Calculate size and check whether extent is negative. */
4021 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4023 /* Multiply the stride by the number of elements in this dimension. */
4024 stride = fold_build2_loc (input_location, MULT_EXPR,
4025 gfc_array_index_type, stride, size);
4026 stride = gfc_evaluate_now (stride, pblock);
4029 for (n = rank; n < rank + corank; n++)
4033 /* Set lower bound. */
4034 gfc_init_se (&se, NULL);
4035 if (lower == NULL || lower[n] == NULL)
4037 gcc_assert (n == rank + corank - 1);
4038 se.expr = gfc_index_one_node;
4042 if (ubound || n == rank + corank - 1)
4044 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4045 gfc_add_block_to_block (pblock, &se.pre);
4049 se.expr = gfc_index_one_node;
4053 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4056 if (n < rank + corank - 1)
4058 gfc_init_se (&se, NULL);
4059 gcc_assert (ubound);
4060 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4061 gfc_add_block_to_block (pblock, &se.pre);
4062 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4063 gfc_rank_cst[n], se.expr);
4067 /* The stride is the number of elements in the array, so multiply by the
4068 size of an element to get the total size. */
4069 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4070 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4071 stride, fold_convert (gfc_array_index_type, tmp));
4073 if (poffset != NULL)
4075 offset = gfc_evaluate_now (offset, pblock);
4079 if (integer_zerop (or_expr))
4081 if (integer_onep (or_expr))
4082 return gfc_index_zero_node;
4084 var = gfc_create_var (TREE_TYPE (size), "size");
4085 gfc_start_block (&thenblock);
4086 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
4087 thencase = gfc_finish_block (&thenblock);
4089 gfc_start_block (&elseblock);
4090 gfc_add_modify (&elseblock, var, size);
4091 elsecase = gfc_finish_block (&elseblock);
4093 tmp = gfc_evaluate_now (or_expr, pblock);
4094 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4095 gfc_add_expr_to_block (pblock, tmp);
4101 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4102 the work for an ALLOCATE statement. */
4106 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4114 gfc_ref *ref, *prev_ref = NULL;
4115 bool allocatable_array, coarray;
4119 /* Find the last reference in the chain. */
4120 while (ref && ref->next != NULL)
4122 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4123 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4128 if (ref == NULL || ref->type != REF_ARRAY)
4133 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4134 coarray = expr->symtree->n.sym->attr.codimension;
4138 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4139 coarray = prev_ref->u.c.component->attr.codimension;
4142 /* Return if this is a scalar coarray. */
4143 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4144 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4146 gcc_assert (coarray);
4150 /* Figure out the size of the array. */
4151 switch (ref->u.ar.type)
4157 upper = ref->u.ar.start;
4163 lower = ref->u.ar.start;
4164 upper = ref->u.ar.end;
4168 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4170 lower = ref->u.ar.as->lower;
4171 upper = ref->u.ar.as->upper;
4179 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4180 ref->u.ar.as->corank, &offset, lower, upper,
4183 /* Allocate memory to store the data. */
4184 pointer = gfc_conv_descriptor_data_get (se->expr);
4185 STRIP_NOPS (pointer);
4187 /* The allocate_array variants take the old pointer as first argument. */
4188 if (allocatable_array)
4189 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4191 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4192 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4194 gfc_add_expr_to_block (&se->pre, tmp);
4196 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4198 if (expr->ts.type == BT_DERIVED
4199 && expr->ts.u.derived->attr.alloc_comp)
4201 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4202 ref->u.ar.as->rank);
4203 gfc_add_expr_to_block (&se->pre, tmp);
4210 /* Deallocate an array variable. Also used when an allocated variable goes
4215 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4221 gfc_start_block (&block);
4222 /* Get a pointer to the data. */
4223 var = gfc_conv_descriptor_data_get (descriptor);
4226 /* Parameter is the address of the data component. */
4227 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4228 gfc_add_expr_to_block (&block, tmp);
4230 /* Zero the data pointer. */
4231 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4232 var, build_int_cst (TREE_TYPE (var), 0));
4233 gfc_add_expr_to_block (&block, tmp);
4235 return gfc_finish_block (&block);
4239 /* Create an array constructor from an initialization expression.
4240 We assume the frontend already did any expansions and conversions. */
4243 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4249 unsigned HOST_WIDE_INT lo;
4251 VEC(constructor_elt,gc) *v = NULL;
4253 switch (expr->expr_type)
4256 case EXPR_STRUCTURE:
4257 /* A single scalar or derived type value. Create an array with all
4258 elements equal to that value. */
4259 gfc_init_se (&se, NULL);
4261 if (expr->expr_type == EXPR_CONSTANT)
4262 gfc_conv_constant (&se, expr);
4264 gfc_conv_structure (&se, expr, 1);
4266 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4267 gcc_assert (tmp && INTEGER_CST_P (tmp));
4268 hi = TREE_INT_CST_HIGH (tmp);
4269 lo = TREE_INT_CST_LOW (tmp);
4273 /* This will probably eat buckets of memory for large arrays. */
4274 while (hi != 0 || lo != 0)
4276 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4284 /* Create a vector of all the elements. */
4285 for (c = gfc_constructor_first (expr->value.constructor);
4286 c; c = gfc_constructor_next (c))
4290 /* Problems occur when we get something like
4291 integer :: a(lots) = (/(i, i=1, lots)/) */
4292 gfc_fatal_error ("The number of elements in the array constructor "
4293 "at %L requires an increase of the allowed %d "
4294 "upper limit. See -fmax-array-constructor "
4295 "option", &expr->where,
4296 gfc_option.flag_max_array_constructor);
4299 if (mpz_cmp_si (c->offset, 0) != 0)
4300 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4304 gfc_init_se (&se, NULL);
4305 switch (c->expr->expr_type)
4308 gfc_conv_constant (&se, c->expr);
4309 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4312 case EXPR_STRUCTURE:
4313 gfc_conv_structure (&se, c->expr, 1);
4314 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4319 /* Catch those occasional beasts that do not simplify
4320 for one reason or another, assuming that if they are
4321 standard defying the frontend will catch them. */
4322 gfc_conv_expr (&se, c->expr);
4323 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4330 return gfc_build_null_descriptor (type);
4336 /* Create a constructor from the list of elements. */
4337 tmp = build_constructor (type, v);
4338 TREE_CONSTANT (tmp) = 1;
4343 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4344 returns the size (in elements) of the array. */
4347 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4348 stmtblock_t * pblock)
4363 size = gfc_index_one_node;
4364 offset = gfc_index_zero_node;
4365 for (dim = 0; dim < as->rank; dim++)
4367 /* Evaluate non-constant array bound expressions. */
4368 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4369 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4371 gfc_init_se (&se, NULL);
4372 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4373 gfc_add_block_to_block (pblock, &se.pre);
4374 gfc_add_modify (pblock, lbound, se.expr);
4376 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4377 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4379 gfc_init_se (&se, NULL);
4380 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4381 gfc_add_block_to_block (pblock, &se.pre);
4382 gfc_add_modify (pblock, ubound, se.expr);
4384 /* The offset of this dimension. offset = offset - lbound * stride. */
4385 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4387 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4390 /* The size of this dimension, and the stride of the next. */
4391 if (dim + 1 < as->rank)
4392 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4394 stride = GFC_TYPE_ARRAY_SIZE (type);
4396 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4398 /* Calculate stride = size * (ubound + 1 - lbound). */
4399 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4400 gfc_array_index_type,
4401 gfc_index_one_node, lbound);
4402 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4403 gfc_array_index_type, ubound, tmp);
4404 tmp = fold_build2_loc (input_location, MULT_EXPR,
4405 gfc_array_index_type, size, tmp);
4407 gfc_add_modify (pblock, stride, tmp);
4409 stride = gfc_evaluate_now (tmp, pblock);
4411 /* Make sure that negative size arrays are translated
4412 to being zero size. */
4413 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4414 stride, gfc_index_zero_node);
4415 tmp = fold_build3_loc (input_location, COND_EXPR,
4416 gfc_array_index_type, tmp,
4417 stride, gfc_index_zero_node);
4418 gfc_add_modify (pblock, stride, tmp);
4424 gfc_trans_vla_type_sizes (sym, pblock);
4431 /* Generate code to initialize/allocate an array variable. */
4434 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4435 gfc_wrapped_block * block)
4444 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4446 /* Do nothing for USEd variables. */
4447 if (sym->attr.use_assoc)
4450 type = TREE_TYPE (decl);
4451 gcc_assert (GFC_ARRAY_TYPE_P (type));
4452 onstack = TREE_CODE (type) != POINTER_TYPE;
4454 gfc_start_block (&init);
4456 /* Evaluate character string length. */
4457 if (sym->ts.type == BT_CHARACTER
4458 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4460 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4462 gfc_trans_vla_type_sizes (sym, &init);
4464 /* Emit a DECL_EXPR for this variable, which will cause the
4465 gimplifier to allocate storage, and all that good stuff. */
4466 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4467 gfc_add_expr_to_block (&init, tmp);
4472 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4476 type = TREE_TYPE (type);
4478 gcc_assert (!sym->attr.use_assoc);
4479 gcc_assert (!TREE_STATIC (decl));
4480 gcc_assert (!sym->module);
4482 if (sym->ts.type == BT_CHARACTER
4483 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4484 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4486 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4488 /* Don't actually allocate space for Cray Pointees. */
4489 if (sym->attr.cray_pointee)
4491 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4492 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4494 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4498 /* The size is the number of elements in the array, so multiply by the
4499 size of an element to get the total size. */
4500 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4501 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4502 size, fold_convert (gfc_array_index_type, tmp));
4504 /* Allocate memory to hold the data. */
4505 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4506 gfc_add_modify (&init, decl, tmp);
4508 /* Set offset of the array. */
4509 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4510 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4512 /* Automatic arrays should not have initializers. */
4513 gcc_assert (!sym->value);
4515 /* Free the temporary. */
4516 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4518 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4522 /* Generate entry and exit code for g77 calling convention arrays. */
4525 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4535 gfc_get_backend_locus (&loc);
4536 gfc_set_backend_locus (&sym->declared_at);
4538 /* Descriptor type. */
4539 parm = sym->backend_decl;
4540 type = TREE_TYPE (parm);
4541 gcc_assert (GFC_ARRAY_TYPE_P (type));
4543 gfc_start_block (&init);
4545 if (sym->ts.type == BT_CHARACTER
4546 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4547 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4549 /* Evaluate the bounds of the array. */
4550 gfc_trans_array_bounds (type, sym, &offset, &init);
4552 /* Set the offset. */
4553 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4554 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4556 /* Set the pointer itself if we aren't using the parameter directly. */
4557 if (TREE_CODE (parm) != PARM_DECL)
4559 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4560 gfc_add_modify (&init, parm, tmp);
4562 stmt = gfc_finish_block (&init);
4564 gfc_set_backend_locus (&loc);
4566 /* Add the initialization code to the start of the function. */
4568 if (sym->attr.optional || sym->attr.not_always_present)
4570 tmp = gfc_conv_expr_present (sym);
4571 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4574 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4578 /* Modify the descriptor of an array parameter so that it has the
4579 correct lower bound. Also move the upper bound accordingly.
4580 If the array is not packed, it will be copied into a temporary.
4581 For each dimension we set the new lower and upper bounds. Then we copy the
4582 stride and calculate the offset for this dimension. We also work out
4583 what the stride of a packed array would be, and see it the two match.
4584 If the array need repacking, we set the stride to the values we just
4585 calculated, recalculate the offset and copy the array data.
4586 Code is also added to copy the data back at the end of the function.
4590 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4591 gfc_wrapped_block * block)
4598 tree stmtInit, stmtCleanup;
4605 tree stride, stride2;
4615 /* Do nothing for pointer and allocatable arrays. */
4616 if (sym->attr.pointer || sym->attr.allocatable)
4619 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4621 gfc_trans_g77_array (sym, block);
4625 gfc_get_backend_locus (&loc);
4626 gfc_set_backend_locus (&sym->declared_at);
4628 /* Descriptor type. */
4629 type = TREE_TYPE (tmpdesc);
4630 gcc_assert (GFC_ARRAY_TYPE_P (type));
4631 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4632 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4633 gfc_start_block (&init);
4635 if (sym->ts.type == BT_CHARACTER
4636 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4637 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4639 checkparm = (sym->as->type == AS_EXPLICIT
4640 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4642 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4643 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4645 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4647 /* For non-constant shape arrays we only check if the first dimension
4648 is contiguous. Repacking higher dimensions wouldn't gain us
4649 anything as we still don't know the array stride. */
4650 partial = gfc_create_var (boolean_type_node, "partial");
4651 TREE_USED (partial) = 1;
4652 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4653 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4654 gfc_index_one_node);
4655 gfc_add_modify (&init, partial, tmp);
4658 partial = NULL_TREE;
4660 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4661 here, however I think it does the right thing. */
4664 /* Set the first stride. */
4665 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4666 stride = gfc_evaluate_now (stride, &init);
4668 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4669 stride, gfc_index_zero_node);
4670 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4671 tmp, gfc_index_one_node, stride);
4672 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4673 gfc_add_modify (&init, stride, tmp);
4675 /* Allow the user to disable array repacking. */
4676 stmt_unpacked = NULL_TREE;
4680 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4681 /* A library call to repack the array if necessary. */
4682 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4683 stmt_unpacked = build_call_expr_loc (input_location,
4684 gfor_fndecl_in_pack, 1, tmp);
4686 stride = gfc_index_one_node;
4688 if (gfc_option.warn_array_temp)
4689 gfc_warning ("Creating array temporary at %L", &loc);
4692 /* This is for the case where the array data is used directly without
4693 calling the repack function. */
4694 if (no_repack || partial != NULL_TREE)
4695 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4697 stmt_packed = NULL_TREE;
4699 /* Assign the data pointer. */
4700 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4702 /* Don't repack unknown shape arrays when the first stride is 1. */
4703 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
4704 partial, stmt_packed, stmt_unpacked);
4707 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4708 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
4710 offset = gfc_index_zero_node;
4711 size = gfc_index_one_node;
4713 /* Evaluate the bounds of the array. */
4714 for (n = 0; n < sym->as->rank; n++)
4716 if (checkparm || !sym->as->upper[n])
4718 /* Get the bounds of the actual parameter. */
4719 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4720 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4724 dubound = NULL_TREE;
4725 dlbound = NULL_TREE;
4728 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4729 if (!INTEGER_CST_P (lbound))
4731 gfc_init_se (&se, NULL);
4732 gfc_conv_expr_type (&se, sym->as->lower[n],
4733 gfc_array_index_type);
4734 gfc_add_block_to_block (&init, &se.pre);
4735 gfc_add_modify (&init, lbound, se.expr);
4738 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4739 /* Set the desired upper bound. */
4740 if (sym->as->upper[n])
4742 /* We know what we want the upper bound to be. */
4743 if (!INTEGER_CST_P (ubound))
4745 gfc_init_se (&se, NULL);
4746 gfc_conv_expr_type (&se, sym->as->upper[n],
4747 gfc_array_index_type);
4748 gfc_add_block_to_block (&init, &se.pre);
4749 gfc_add_modify (&init, ubound, se.expr);
4752 /* Check the sizes match. */
4755 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4759 temp = fold_build2_loc (input_location, MINUS_EXPR,
4760 gfc_array_index_type, ubound, lbound);
4761 temp = fold_build2_loc (input_location, PLUS_EXPR,
4762 gfc_array_index_type,
4763 gfc_index_one_node, temp);
4764 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
4765 gfc_array_index_type, dubound,
4767 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
4768 gfc_array_index_type,
4769 gfc_index_one_node, stride2);
4770 tmp = fold_build2_loc (input_location, NE_EXPR,
4771 gfc_array_index_type, temp, stride2);
4772 asprintf (&msg, "Dimension %d of array '%s' has extent "
4773 "%%ld instead of %%ld", n+1, sym->name);
4775 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
4776 fold_convert (long_integer_type_node, temp),
4777 fold_convert (long_integer_type_node, stride2));
4784 /* For assumed shape arrays move the upper bound by the same amount
4785 as the lower bound. */
4786 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4787 gfc_array_index_type, dubound, dlbound);
4788 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4789 gfc_array_index_type, tmp, lbound);
4790 gfc_add_modify (&init, ubound, tmp);
4792 /* The offset of this dimension. offset = offset - lbound * stride. */
4793 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4795 offset = fold_build2_loc (input_location, MINUS_EXPR,
4796 gfc_array_index_type, offset, tmp);
4798 /* The size of this dimension, and the stride of the next. */
4799 if (n + 1 < sym->as->rank)
4801 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4803 if (no_repack || partial != NULL_TREE)
4805 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4807 /* Figure out the stride if not a known constant. */
4808 if (!INTEGER_CST_P (stride))
4811 stmt_packed = NULL_TREE;
4814 /* Calculate stride = size * (ubound + 1 - lbound). */
4815 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4816 gfc_array_index_type,
4817 gfc_index_one_node, lbound);
4818 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4819 gfc_array_index_type, ubound, tmp);
4820 size = fold_build2_loc (input_location, MULT_EXPR,
4821 gfc_array_index_type, size, tmp);
4825 /* Assign the stride. */
4826 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4827 tmp = fold_build3_loc (input_location, COND_EXPR,
4828 gfc_array_index_type, partial,
4829 stmt_unpacked, stmt_packed);
4831 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4832 gfc_add_modify (&init, stride, tmp);
4837 stride = GFC_TYPE_ARRAY_SIZE (type);
4839 if (stride && !INTEGER_CST_P (stride))
4841 /* Calculate size = stride * (ubound + 1 - lbound). */
4842 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4843 gfc_array_index_type,
4844 gfc_index_one_node, lbound);
4845 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4846 gfc_array_index_type,
4848 tmp = fold_build2_loc (input_location, MULT_EXPR,
4849 gfc_array_index_type,
4850 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4851 gfc_add_modify (&init, stride, tmp);
4856 /* Set the offset. */
4857 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4858 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4860 gfc_trans_vla_type_sizes (sym, &init);
4862 stmtInit = gfc_finish_block (&init);
4864 /* Only do the entry/initialization code if the arg is present. */
4865 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4866 optional_arg = (sym->attr.optional
4867 || (sym->ns->proc_name->attr.entry_master
4868 && sym->attr.dummy));
4871 tmp = gfc_conv_expr_present (sym);
4872 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
4873 build_empty_stmt (input_location));
4878 stmtCleanup = NULL_TREE;
4881 stmtblock_t cleanup;
4882 gfc_start_block (&cleanup);
4884 if (sym->attr.intent != INTENT_IN)
4886 /* Copy the data back. */
4887 tmp = build_call_expr_loc (input_location,
4888 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4889 gfc_add_expr_to_block (&cleanup, tmp);
4892 /* Free the temporary. */
4893 tmp = gfc_call_free (tmpdesc);
4894 gfc_add_expr_to_block (&cleanup, tmp);
4896 stmtCleanup = gfc_finish_block (&cleanup);
4898 /* Only do the cleanup if the array was repacked. */
4899 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
4900 tmp = gfc_conv_descriptor_data_get (tmp);
4901 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4903 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4904 build_empty_stmt (input_location));
4908 tmp = gfc_conv_expr_present (sym);
4909 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4910 build_empty_stmt (input_location));
4914 /* We don't need to free any memory allocated by internal_pack as it will
4915 be freed at the end of the function by pop_context. */
4916 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
4920 /* Calculate the overall offset, including subreferences. */
4922 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4923 bool subref, gfc_expr *expr)
4933 /* If offset is NULL and this is not a subreferenced array, there is
4935 if (offset == NULL_TREE)
4938 offset = gfc_index_zero_node;
4943 tmp = gfc_conv_array_data (desc);
4944 tmp = build_fold_indirect_ref_loc (input_location,
4946 tmp = gfc_build_array_ref (tmp, offset, NULL);
4948 /* Offset the data pointer for pointer assignments from arrays with
4949 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4952 /* Go past the array reference. */
4953 for (ref = expr->ref; ref; ref = ref->next)
4954 if (ref->type == REF_ARRAY &&
4955 ref->u.ar.type != AR_ELEMENT)
4961 /* Calculate the offset for each subsequent subreference. */
4962 for (; ref; ref = ref->next)
4967 field = ref->u.c.component->backend_decl;
4968 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4969 tmp = fold_build3_loc (input_location, COMPONENT_REF,
4971 tmp, field, NULL_TREE);
4975 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4976 gfc_init_se (&start, NULL);
4977 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4978 gfc_add_block_to_block (block, &start.pre);
4979 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4983 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4984 && ref->u.ar.type == AR_ELEMENT);
4986 /* TODO - Add bounds checking. */
4987 stride = gfc_index_one_node;
4988 index = gfc_index_zero_node;
4989 for (n = 0; n < ref->u.ar.dimen; n++)
4994 /* Update the index. */
4995 gfc_init_se (&start, NULL);
4996 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4997 itmp = gfc_evaluate_now (start.expr, block);
4998 gfc_init_se (&start, NULL);
4999 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5000 jtmp = gfc_evaluate_now (start.expr, block);
5001 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5002 gfc_array_index_type, itmp, jtmp);
5003 itmp = fold_build2_loc (input_location, MULT_EXPR,
5004 gfc_array_index_type, itmp, stride);
5005 index = fold_build2_loc (input_location, PLUS_EXPR,
5006 gfc_array_index_type, itmp, index);
5007 index = gfc_evaluate_now (index, block);
5009 /* Update the stride. */
5010 gfc_init_se (&start, NULL);
5011 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5012 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5013 gfc_array_index_type, start.expr,
5015 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5016 gfc_array_index_type,
5017 gfc_index_one_node, itmp);
5018 stride = fold_build2_loc (input_location, MULT_EXPR,
5019 gfc_array_index_type, stride, itmp);
5020 stride = gfc_evaluate_now (stride, block);
5023 /* Apply the index to obtain the array element. */
5024 tmp = gfc_build_array_ref (tmp, index, NULL);
5034 /* Set the target data pointer. */
5035 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5036 gfc_conv_descriptor_data_set (block, parm, offset);
5040 /* gfc_conv_expr_descriptor needs the string length an expression
5041 so that the size of the temporary can be obtained. This is done
5042 by adding up the string lengths of all the elements in the
5043 expression. Function with non-constant expressions have their
5044 string lengths mapped onto the actual arguments using the
5045 interface mapping machinery in trans-expr.c. */
5047 get_array_charlen (gfc_expr *expr, gfc_se *se)
5049 gfc_interface_mapping mapping;
5050 gfc_formal_arglist *formal;
5051 gfc_actual_arglist *arg;
5054 if (expr->ts.u.cl->length
5055 && gfc_is_constant_expr (expr->ts.u.cl->length))
5057 if (!expr->ts.u.cl->backend_decl)
5058 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5062 switch (expr->expr_type)
5065 get_array_charlen (expr->value.op.op1, se);
5067 /* For parentheses the expression ts.u.cl is identical. */
5068 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5071 expr->ts.u.cl->backend_decl =
5072 gfc_create_var (gfc_charlen_type_node, "sln");
5074 if (expr->value.op.op2)
5076 get_array_charlen (expr->value.op.op2, se);
5078 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5080 /* Add the string lengths and assign them to the expression
5081 string length backend declaration. */
5082 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5083 fold_build2_loc (input_location, PLUS_EXPR,
5084 gfc_charlen_type_node,
5085 expr->value.op.op1->ts.u.cl->backend_decl,
5086 expr->value.op.op2->ts.u.cl->backend_decl));
5089 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5090 expr->value.op.op1->ts.u.cl->backend_decl);
5094 if (expr->value.function.esym == NULL
5095 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5097 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5101 /* Map expressions involving the dummy arguments onto the actual
5102 argument expressions. */
5103 gfc_init_interface_mapping (&mapping);
5104 formal = expr->symtree->n.sym->formal;
5105 arg = expr->value.function.actual;
5107 /* Set se = NULL in the calls to the interface mapping, to suppress any
5109 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5114 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5117 gfc_init_se (&tse, NULL);
5119 /* Build the expression for the character length and convert it. */
5120 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5122 gfc_add_block_to_block (&se->pre, &tse.pre);
5123 gfc_add_block_to_block (&se->post, &tse.post);
5124 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5125 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5126 gfc_charlen_type_node, tse.expr,
5127 build_int_cst (gfc_charlen_type_node, 0));
5128 expr->ts.u.cl->backend_decl = tse.expr;
5129 gfc_free_interface_mapping (&mapping);
5133 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5139 /* Convert an array for passing as an actual argument. Expressions and
5140 vector subscripts are evaluated and stored in a temporary, which is then
5141 passed. For whole arrays the descriptor is passed. For array sections
5142 a modified copy of the descriptor is passed, but using the original data.
5144 This function is also used for array pointer assignments, and there
5147 - se->want_pointer && !se->direct_byref
5148 EXPR is an actual argument. On exit, se->expr contains a
5149 pointer to the array descriptor.
5151 - !se->want_pointer && !se->direct_byref
5152 EXPR is an actual argument to an intrinsic function or the
5153 left-hand side of a pointer assignment. On exit, se->expr
5154 contains the descriptor for EXPR.
5156 - !se->want_pointer && se->direct_byref
5157 EXPR is the right-hand side of a pointer assignment and
5158 se->expr is the descriptor for the previously-evaluated
5159 left-hand side. The function creates an assignment from
5163 The se->force_tmp flag disables the non-copying descriptor optimization
5164 that is used for transpose. It may be used in cases where there is an
5165 alias between the transpose argument and another argument in the same
5169 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5181 bool subref_array_target = false;
5184 gcc_assert (ss != NULL);
5185 gcc_assert (ss != gfc_ss_terminator);
5187 /* Special case things we know we can pass easily. */
5188 switch (expr->expr_type)
5191 /* If we have a linear array section, we can pass it directly.
5192 Otherwise we need to copy it into a temporary. */
5194 gcc_assert (ss->type == GFC_SS_SECTION);
5195 gcc_assert (ss->expr == expr);
5196 info = &ss->data.info;
5198 /* Get the descriptor for the array. */
5199 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5200 desc = info->descriptor;
5202 subref_array_target = se->direct_byref && is_subref_array (expr);
5203 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5204 && !subref_array_target;
5211 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5213 /* Create a new descriptor if the array doesn't have one. */
5216 else if (info->ref->u.ar.type == AR_FULL)
5218 else if (se->direct_byref)
5221 full = gfc_full_array_ref_p (info->ref, NULL);
5224 for (n = 0; n < info->dimen; n++)
5225 if (info->dim[n] != n)
5233 if (se->direct_byref && !se->byref_noassign)
5235 /* Copy the descriptor for pointer assignments. */
5236 gfc_add_modify (&se->pre, se->expr, desc);
5238 /* Add any offsets from subreferences. */
5239 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5240 subref_array_target, expr);
5242 else if (se->want_pointer)
5244 /* We pass full arrays directly. This means that pointers and
5245 allocatable arrays should also work. */
5246 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5253 if (expr->ts.type == BT_CHARACTER)
5254 se->string_length = gfc_get_expr_charlen (expr);
5262 /* We don't need to copy data in some cases. */
5263 arg = gfc_get_noncopying_intrinsic_argument (expr);
5266 /* This is a call to transpose... */
5267 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5268 /* ... which has already been handled by the scalarizer, so
5269 that we just need to get its argument's descriptor. */
5270 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5274 /* A transformational function return value will be a temporary
5275 array descriptor. We still need to go through the scalarizer
5276 to create the descriptor. Elemental functions ar handled as
5277 arbitrary expressions, i.e. copy to a temporary. */
5279 if (se->direct_byref)
5281 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5283 /* For pointer assignments pass the descriptor directly. */
5287 gcc_assert (se->ss == ss);
5288 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5289 gfc_conv_expr (se, expr);
5293 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5295 if (ss->expr != expr)
5296 /* Elemental function. */
5297 gcc_assert ((expr->value.function.esym != NULL
5298 && expr->value.function.esym->attr.elemental)
5299 || (expr->value.function.isym != NULL
5300 && expr->value.function.isym->elemental));
5302 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5305 if (expr->ts.type == BT_CHARACTER
5306 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5307 get_array_charlen (expr, se);
5313 /* Transformational function. */
5314 info = &ss->data.info;
5320 /* Constant array constructors don't need a temporary. */
5321 if (ss->type == GFC_SS_CONSTRUCTOR
5322 && expr->ts.type != BT_CHARACTER
5323 && gfc_constant_array_constructor_p (expr->value.constructor))
5326 info = &ss->data.info;
5336 /* Something complicated. Copy it into a temporary. */
5342 /* If we are creating a temporary, we don't need to bother about aliases
5347 gfc_init_loopinfo (&loop);
5349 /* Associate the SS with the loop. */
5350 gfc_add_ss_to_loop (&loop, ss);
5352 /* Tell the scalarizer not to bother creating loop variables, etc. */
5354 loop.array_parameter = 1;
5356 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5357 gcc_assert (!se->direct_byref);
5359 /* Setup the scalarizing loops and bounds. */
5360 gfc_conv_ss_startstride (&loop);
5364 /* Tell the scalarizer to make a temporary. */
5365 loop.temp_ss = gfc_get_ss ();
5366 loop.temp_ss->type = GFC_SS_TEMP;
5367 loop.temp_ss->next = gfc_ss_terminator;
5369 if (expr->ts.type == BT_CHARACTER
5370 && !expr->ts.u.cl->backend_decl)
5371 get_array_charlen (expr, se);
5373 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5375 if (expr->ts.type == BT_CHARACTER)
5376 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5378 loop.temp_ss->string_length = NULL;
5380 se->string_length = loop.temp_ss->string_length;
5381 loop.temp_ss->data.temp.dimen = loop.dimen;
5382 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5385 gfc_conv_loop_setup (&loop, & expr->where);
5389 /* Copy into a temporary and pass that. We don't need to copy the data
5390 back because expressions and vector subscripts must be INTENT_IN. */
5391 /* TODO: Optimize passing function return values. */
5395 /* Start the copying loops. */
5396 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5397 gfc_mark_ss_chain_used (ss, 1);
5398 gfc_start_scalarized_body (&loop, &block);
5400 /* Copy each data element. */
5401 gfc_init_se (&lse, NULL);
5402 gfc_copy_loopinfo_to_se (&lse, &loop);
5403 gfc_init_se (&rse, NULL);
5404 gfc_copy_loopinfo_to_se (&rse, &loop);
5406 lse.ss = loop.temp_ss;
5409 gfc_conv_scalarized_array_ref (&lse, NULL);
5410 if (expr->ts.type == BT_CHARACTER)
5412 gfc_conv_expr (&rse, expr);
5413 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5414 rse.expr = build_fold_indirect_ref_loc (input_location,
5418 gfc_conv_expr_val (&rse, expr);
5420 gfc_add_block_to_block (&block, &rse.pre);
5421 gfc_add_block_to_block (&block, &lse.pre);
5423 lse.string_length = rse.string_length;
5424 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5425 expr->expr_type == EXPR_VARIABLE, true);
5426 gfc_add_expr_to_block (&block, tmp);
5428 /* Finish the copying loops. */
5429 gfc_trans_scalarizing_loops (&loop, &block);
5431 desc = loop.temp_ss->data.info.descriptor;
5433 else if (expr->expr_type == EXPR_FUNCTION)
5435 desc = info->descriptor;
5436 se->string_length = ss->string_length;
5440 /* We pass sections without copying to a temporary. Make a new
5441 descriptor and point it at the section we want. The loop variable
5442 limits will be the limits of the section.
5443 A function may decide to repack the array to speed up access, but
5444 we're not bothered about that here. */
5453 /* Set the string_length for a character array. */
5454 if (expr->ts.type == BT_CHARACTER)
5455 se->string_length = gfc_get_expr_charlen (expr);
5457 desc = info->descriptor;
5458 if (se->direct_byref && !se->byref_noassign)
5460 /* For pointer assignments we fill in the destination. */
5462 parmtype = TREE_TYPE (parm);
5466 /* Otherwise make a new one. */
5467 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5468 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5469 loop.from, loop.to, 0,
5470 GFC_ARRAY_UNKNOWN, false);
5471 parm = gfc_create_var (parmtype, "parm");
5474 offset = gfc_index_zero_node;
5476 /* The following can be somewhat confusing. We have two
5477 descriptors, a new one and the original array.
5478 {parm, parmtype, dim} refer to the new one.
5479 {desc, type, n, loop} refer to the original, which maybe
5480 a descriptorless array.
5481 The bounds of the scalarization are the bounds of the section.
5482 We don't have to worry about numeric overflows when calculating
5483 the offsets because all elements are within the array data. */
5485 /* Set the dtype. */
5486 tmp = gfc_conv_descriptor_dtype (parm);
5487 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5489 /* Set offset for assignments to pointer only to zero if it is not
5491 if (se->direct_byref
5492 && info->ref && info->ref->u.ar.type != AR_FULL)
5493 base = gfc_index_zero_node;
5494 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5495 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5499 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5500 for (n = 0; n < ndim; n++)
5502 stride = gfc_conv_array_stride (desc, n);
5504 /* Work out the offset. */
5506 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5508 gcc_assert (info->subscript[n]
5509 && info->subscript[n]->type == GFC_SS_SCALAR);
5510 start = info->subscript[n]->data.scalar.expr;
5514 /* Evaluate and remember the start of the section. */
5515 start = info->start[n];
5516 stride = gfc_evaluate_now (stride, &loop.pre);
5519 tmp = gfc_conv_array_lbound (desc, n);
5520 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5522 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5524 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5528 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5530 /* For elemental dimensions, we only need the offset. */
5534 /* Vector subscripts need copying and are handled elsewhere. */
5536 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5538 /* look for the corresponding scalarizer dimension: dim. */
5539 for (dim = 0; dim < ndim; dim++)
5540 if (info->dim[dim] == n)
5543 /* loop exited early: the DIM being looked for has been found. */
5544 gcc_assert (dim < ndim);
5546 /* Set the new lower bound. */
5547 from = loop.from[dim];
5550 /* If we have an array section or are assigning make sure that
5551 the lower bound is 1. References to the full
5552 array should otherwise keep the original bounds. */
5554 || info->ref->u.ar.type != AR_FULL)
5555 && !integer_onep (from))
5557 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5558 gfc_array_index_type, gfc_index_one_node,
5560 to = fold_build2_loc (input_location, PLUS_EXPR,
5561 gfc_array_index_type, to, tmp);
5562 from = gfc_index_one_node;
5564 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5565 gfc_rank_cst[dim], from);
5567 /* Set the new upper bound. */
5568 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5569 gfc_rank_cst[dim], to);
5571 /* Multiply the stride by the section stride to get the
5573 stride = fold_build2_loc (input_location, MULT_EXPR,
5574 gfc_array_index_type,
5575 stride, info->stride[n]);
5577 if (se->direct_byref
5579 && info->ref->u.ar.type != AR_FULL)
5581 base = fold_build2_loc (input_location, MINUS_EXPR,
5582 TREE_TYPE (base), base, stride);
5584 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5586 tmp = gfc_conv_array_lbound (desc, n);
5587 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5588 TREE_TYPE (base), tmp, loop.from[dim]);
5589 tmp = fold_build2_loc (input_location, MULT_EXPR,
5590 TREE_TYPE (base), tmp,
5591 gfc_conv_array_stride (desc, n));
5592 base = fold_build2_loc (input_location, PLUS_EXPR,
5593 TREE_TYPE (base), tmp, base);
5596 /* Store the new stride. */
5597 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5598 gfc_rank_cst[dim], stride);
5601 if (se->data_not_needed)
5602 gfc_conv_descriptor_data_set (&loop.pre, parm,
5603 gfc_index_zero_node);
5605 /* Point the data pointer at the 1st element in the section. */
5606 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5607 subref_array_target, expr);
5609 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5610 && !se->data_not_needed)
5612 /* Set the offset. */
5613 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5617 /* Only the callee knows what the correct offset it, so just set
5619 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5624 if (!se->direct_byref || se->byref_noassign)
5626 /* Get a pointer to the new descriptor. */
5627 if (se->want_pointer)
5628 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5633 gfc_add_block_to_block (&se->pre, &loop.pre);
5634 gfc_add_block_to_block (&se->post, &loop.post);
5636 /* Cleanup the scalarizer. */
5637 gfc_cleanup_loop (&loop);
5640 /* Helper function for gfc_conv_array_parameter if array size needs to be
5644 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5647 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5648 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5649 else if (expr->rank > 1)
5650 *size = build_call_expr_loc (input_location,
5651 gfor_fndecl_size0, 1,
5652 gfc_build_addr_expr (NULL, desc));
5655 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5656 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5658 *size = fold_build2_loc (input_location, MINUS_EXPR,
5659 gfc_array_index_type, ubound, lbound);
5660 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5661 *size, gfc_index_one_node);
5662 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5663 *size, gfc_index_zero_node);
5665 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5666 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5667 *size, fold_convert (gfc_array_index_type, elem));
5670 /* Convert an array for passing as an actual parameter. */
5671 /* TODO: Optimize passing g77 arrays. */
5674 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5675 const gfc_symbol *fsym, const char *proc_name,
5680 tree tmp = NULL_TREE;
5682 tree parent = DECL_CONTEXT (current_function_decl);
5683 bool full_array_var;
5684 bool this_array_result;
5687 bool array_constructor;
5688 bool good_allocatable;
5689 bool ultimate_ptr_comp;
5690 bool ultimate_alloc_comp;
5695 ultimate_ptr_comp = false;
5696 ultimate_alloc_comp = false;
5698 for (ref = expr->ref; ref; ref = ref->next)
5700 if (ref->next == NULL)
5703 if (ref->type == REF_COMPONENT)
5705 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5706 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5710 full_array_var = false;
5713 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5714 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5716 sym = full_array_var ? expr->symtree->n.sym : NULL;
5718 /* The symbol should have an array specification. */
5719 gcc_assert (!sym || sym->as || ref->u.ar.as);
5721 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5723 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5724 expr->ts.u.cl->backend_decl = tmp;
5725 se->string_length = tmp;
5728 /* Is this the result of the enclosing procedure? */
5729 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5730 if (this_array_result
5731 && (sym->backend_decl != current_function_decl)
5732 && (sym->backend_decl != parent))
5733 this_array_result = false;
5735 /* Passing address of the array if it is not pointer or assumed-shape. */
5736 if (full_array_var && g77 && !this_array_result)
5738 tmp = gfc_get_symbol_decl (sym);
5740 if (sym->ts.type == BT_CHARACTER)
5741 se->string_length = sym->ts.u.cl->backend_decl;
5743 if (sym->ts.type == BT_DERIVED)
5745 gfc_conv_expr_descriptor (se, expr, ss);
5746 se->expr = gfc_conv_array_data (se->expr);
5750 if (!sym->attr.pointer
5752 && sym->as->type != AS_ASSUMED_SHAPE
5753 && !sym->attr.allocatable)
5755 /* Some variables are declared directly, others are declared as
5756 pointers and allocated on the heap. */
5757 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5760 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5762 array_parameter_size (tmp, expr, size);
5766 if (sym->attr.allocatable)
5768 if (sym->attr.dummy || sym->attr.result)
5770 gfc_conv_expr_descriptor (se, expr, ss);
5774 array_parameter_size (tmp, expr, size);
5775 se->expr = gfc_conv_array_data (tmp);
5780 /* A convenient reduction in scope. */
5781 contiguous = g77 && !this_array_result && contiguous;
5783 /* There is no need to pack and unpack the array, if it is contiguous
5784 and not a deferred- or assumed-shape array, or if it is simply
5786 no_pack = ((sym && sym->as
5787 && !sym->attr.pointer
5788 && sym->as->type != AS_DEFERRED
5789 && sym->as->type != AS_ASSUMED_SHAPE)
5791 (ref && ref->u.ar.as
5792 && ref->u.ar.as->type != AS_DEFERRED
5793 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
5795 gfc_is_simply_contiguous (expr, false));
5797 no_pack = contiguous && no_pack;
5799 /* Array constructors are always contiguous and do not need packing. */
5800 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5802 /* Same is true of contiguous sections from allocatable variables. */
5803 good_allocatable = contiguous
5805 && expr->symtree->n.sym->attr.allocatable;
5807 /* Or ultimate allocatable components. */
5808 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5810 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5812 gfc_conv_expr_descriptor (se, expr, ss);
5813 if (expr->ts.type == BT_CHARACTER)
5814 se->string_length = expr->ts.u.cl->backend_decl;
5816 array_parameter_size (se->expr, expr, size);
5817 se->expr = gfc_conv_array_data (se->expr);
5821 if (this_array_result)
5823 /* Result of the enclosing function. */
5824 gfc_conv_expr_descriptor (se, expr, ss);
5826 array_parameter_size (se->expr, expr, size);
5827 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5829 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5830 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5831 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5838 /* Every other type of array. */
5839 se->want_pointer = 1;
5840 gfc_conv_expr_descriptor (se, expr, ss);
5842 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5847 /* Deallocate the allocatable components of structures that are
5849 if (expr->ts.type == BT_DERIVED
5850 && expr->ts.u.derived->attr.alloc_comp
5851 && expr->expr_type != EXPR_VARIABLE)
5853 tmp = build_fold_indirect_ref_loc (input_location,
5855 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5856 gfc_add_expr_to_block (&se->post, tmp);
5859 if (g77 || (fsym && fsym->attr.contiguous
5860 && !gfc_is_simply_contiguous (expr, false)))
5862 tree origptr = NULL_TREE;
5866 /* For contiguous arrays, save the original value of the descriptor. */
5869 origptr = gfc_create_var (pvoid_type_node, "origptr");
5870 tmp = build_fold_indirect_ref_loc (input_location, desc);
5871 tmp = gfc_conv_array_data (tmp);
5872 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5873 TREE_TYPE (origptr), origptr,
5874 fold_convert (TREE_TYPE (origptr), tmp));
5875 gfc_add_expr_to_block (&se->pre, tmp);
5878 /* Repack the array. */
5879 if (gfc_option.warn_array_temp)
5882 gfc_warning ("Creating array temporary at %L for argument '%s'",
5883 &expr->where, fsym->name);
5885 gfc_warning ("Creating array temporary at %L", &expr->where);
5888 ptr = build_call_expr_loc (input_location,
5889 gfor_fndecl_in_pack, 1, desc);
5891 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5893 tmp = gfc_conv_expr_present (sym);
5894 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
5895 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
5896 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5899 ptr = gfc_evaluate_now (ptr, &se->pre);
5901 /* Use the packed data for the actual argument, except for contiguous arrays,
5902 where the descriptor's data component is set. */
5907 tmp = build_fold_indirect_ref_loc (input_location, desc);
5908 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
5911 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5915 if (fsym && proc_name)
5916 asprintf (&msg, "An array temporary was created for argument "
5917 "'%s' of procedure '%s'", fsym->name, proc_name);
5919 asprintf (&msg, "An array temporary was created");
5921 tmp = build_fold_indirect_ref_loc (input_location,
5923 tmp = gfc_conv_array_data (tmp);
5924 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5925 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5927 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5928 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5930 gfc_conv_expr_present (sym), tmp);
5932 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5937 gfc_start_block (&block);
5939 /* Copy the data back. */
5940 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5942 tmp = build_call_expr_loc (input_location,
5943 gfor_fndecl_in_unpack, 2, desc, ptr);
5944 gfc_add_expr_to_block (&block, tmp);
5947 /* Free the temporary. */
5948 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5949 gfc_add_expr_to_block (&block, tmp);
5951 stmt = gfc_finish_block (&block);
5953 gfc_init_block (&block);
5954 /* Only if it was repacked. This code needs to be executed before the
5955 loop cleanup code. */
5956 tmp = build_fold_indirect_ref_loc (input_location,
5958 tmp = gfc_conv_array_data (tmp);
5959 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5960 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5962 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5963 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5965 gfc_conv_expr_present (sym), tmp);
5967 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5969 gfc_add_expr_to_block (&block, tmp);
5970 gfc_add_block_to_block (&block, &se->post);
5972 gfc_init_block (&se->post);
5974 /* Reset the descriptor pointer. */
5977 tmp = build_fold_indirect_ref_loc (input_location, desc);
5978 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
5981 gfc_add_block_to_block (&se->post, &block);
5986 /* Generate code to deallocate an array, if it is allocated. */
5989 gfc_trans_dealloc_allocated (tree descriptor)
5995 gfc_start_block (&block);
5997 var = gfc_conv_descriptor_data_get (descriptor);
6000 /* Call array_deallocate with an int * present in the second argument.
6001 Although it is ignored here, it's presence ensures that arrays that
6002 are already deallocated are ignored. */
6003 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6004 gfc_add_expr_to_block (&block, tmp);
6006 /* Zero the data pointer. */
6007 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6008 var, build_int_cst (TREE_TYPE (var), 0));
6009 gfc_add_expr_to_block (&block, tmp);
6011 return gfc_finish_block (&block);
6015 /* This helper function calculates the size in words of a full array. */
6018 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6023 idx = gfc_rank_cst[rank - 1];
6024 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6025 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6026 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6028 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6029 tmp, gfc_index_one_node);
6030 tmp = gfc_evaluate_now (tmp, block);
6032 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6033 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6035 return gfc_evaluate_now (tmp, block);
6039 /* Allocate dest to the same size as src, and copy src -> dest.
6040 If no_malloc is set, only the copy is done. */
6043 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6053 /* If the source is null, set the destination to null. Then,
6054 allocate memory to the destination. */
6055 gfc_init_block (&block);
6059 tmp = null_pointer_node;
6060 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6061 gfc_add_expr_to_block (&block, tmp);
6062 null_data = gfc_finish_block (&block);
6064 gfc_init_block (&block);
6065 size = TYPE_SIZE_UNIT (type);
6068 tmp = gfc_call_malloc (&block, type, size);
6069 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6070 dest, fold_convert (type, tmp));
6071 gfc_add_expr_to_block (&block, tmp);
6074 tmp = built_in_decls[BUILT_IN_MEMCPY];
6075 tmp = build_call_expr_loc (input_location, tmp, 3,
6080 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6081 null_data = gfc_finish_block (&block);
6083 gfc_init_block (&block);
6084 nelems = get_full_array_size (&block, src, rank);
6085 tmp = fold_convert (gfc_array_index_type,
6086 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6087 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6091 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6092 tmp = gfc_call_malloc (&block, tmp, size);
6093 gfc_conv_descriptor_data_set (&block, dest, tmp);
6096 /* We know the temporary and the value will be the same length,
6097 so can use memcpy. */
6098 tmp = built_in_decls[BUILT_IN_MEMCPY];
6099 tmp = build_call_expr_loc (input_location,
6100 tmp, 3, gfc_conv_descriptor_data_get (dest),
6101 gfc_conv_descriptor_data_get (src), size);
6104 gfc_add_expr_to_block (&block, tmp);
6105 tmp = gfc_finish_block (&block);
6107 /* Null the destination if the source is null; otherwise do
6108 the allocate and copy. */
6112 null_cond = gfc_conv_descriptor_data_get (src);
6114 null_cond = convert (pvoid_type_node, null_cond);
6115 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6116 null_cond, null_pointer_node);
6117 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6121 /* Allocate dest to the same size as src, and copy data src -> dest. */
6124 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6126 return duplicate_allocatable (dest, src, type, rank, false);
6130 /* Copy data src -> dest. */
6133 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6135 return duplicate_allocatable (dest, src, type, rank, true);
6139 /* Recursively traverse an object of derived type, generating code to
6140 deallocate, nullify or copy allocatable components. This is the work horse
6141 function for the functions named in this enum. */
6143 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6144 COPY_ONLY_ALLOC_COMP};
6147 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6148 tree dest, int rank, int purpose)
6152 stmtblock_t fnblock;
6153 stmtblock_t loopbody;
6164 tree null_cond = NULL_TREE;
6166 gfc_init_block (&fnblock);
6168 decl_type = TREE_TYPE (decl);
6170 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6171 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6173 decl = build_fold_indirect_ref_loc (input_location,
6176 /* Just in case in gets dereferenced. */
6177 decl_type = TREE_TYPE (decl);
6179 /* If this an array of derived types with allocatable components
6180 build a loop and recursively call this function. */
6181 if (TREE_CODE (decl_type) == ARRAY_TYPE
6182 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6184 tmp = gfc_conv_array_data (decl);
6185 var = build_fold_indirect_ref_loc (input_location,
6188 /* Get the number of elements - 1 and set the counter. */
6189 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6191 /* Use the descriptor for an allocatable array. Since this
6192 is a full array reference, we only need the descriptor
6193 information from dimension = rank. */
6194 tmp = get_full_array_size (&fnblock, decl, rank);
6195 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6196 gfc_array_index_type, tmp,
6197 gfc_index_one_node);
6199 null_cond = gfc_conv_descriptor_data_get (decl);
6200 null_cond = fold_build2_loc (input_location, NE_EXPR,
6201 boolean_type_node, null_cond,
6202 build_int_cst (TREE_TYPE (null_cond), 0));
6206 /* Otherwise use the TYPE_DOMAIN information. */
6207 tmp = array_type_nelts (decl_type);
6208 tmp = fold_convert (gfc_array_index_type, tmp);
6211 /* Remember that this is, in fact, the no. of elements - 1. */
6212 nelems = gfc_evaluate_now (tmp, &fnblock);
6213 index = gfc_create_var (gfc_array_index_type, "S");
6215 /* Build the body of the loop. */
6216 gfc_init_block (&loopbody);
6218 vref = gfc_build_array_ref (var, index, NULL);
6220 if (purpose == COPY_ALLOC_COMP)
6222 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6224 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6225 gfc_add_expr_to_block (&fnblock, tmp);
6227 tmp = build_fold_indirect_ref_loc (input_location,
6228 gfc_conv_array_data (dest));
6229 dref = gfc_build_array_ref (tmp, index, NULL);
6230 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6232 else if (purpose == COPY_ONLY_ALLOC_COMP)
6234 tmp = build_fold_indirect_ref_loc (input_location,
6235 gfc_conv_array_data (dest));
6236 dref = gfc_build_array_ref (tmp, index, NULL);
6237 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6241 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6243 gfc_add_expr_to_block (&loopbody, tmp);
6245 /* Build the loop and return. */
6246 gfc_init_loopinfo (&loop);
6248 loop.from[0] = gfc_index_zero_node;
6249 loop.loopvar[0] = index;
6250 loop.to[0] = nelems;
6251 gfc_trans_scalarizing_loops (&loop, &loopbody);
6252 gfc_add_block_to_block (&fnblock, &loop.pre);
6254 tmp = gfc_finish_block (&fnblock);
6255 if (null_cond != NULL_TREE)
6256 tmp = build3_v (COND_EXPR, null_cond, tmp,
6257 build_empty_stmt (input_location));
6262 /* Otherwise, act on the components or recursively call self to
6263 act on a chain of components. */
6264 for (c = der_type->components; c; c = c->next)
6266 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6267 && c->ts.u.derived->attr.alloc_comp;
6268 cdecl = c->backend_decl;
6269 ctype = TREE_TYPE (cdecl);
6273 case DEALLOCATE_ALLOC_COMP:
6274 /* Do not deallocate the components of ultimate pointer
6276 if (cmp_has_alloc_comps && !c->attr.pointer)
6278 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6279 decl, cdecl, NULL_TREE);
6280 rank = c->as ? c->as->rank : 0;
6281 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6283 gfc_add_expr_to_block (&fnblock, tmp);
6286 if (c->attr.allocatable && c->attr.dimension)
6288 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6289 decl, cdecl, NULL_TREE);
6290 tmp = gfc_trans_dealloc_allocated (comp);
6291 gfc_add_expr_to_block (&fnblock, tmp);
6293 else if (c->attr.allocatable)
6295 /* Allocatable scalar components. */
6296 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6297 decl, cdecl, NULL_TREE);
6299 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6300 gfc_add_expr_to_block (&fnblock, tmp);
6302 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6303 void_type_node, comp,
6304 build_int_cst (TREE_TYPE (comp), 0));
6305 gfc_add_expr_to_block (&fnblock, tmp);
6307 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6309 /* Allocatable scalar CLASS components. */
6310 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6311 decl, cdecl, NULL_TREE);
6313 /* Add reference to '$data' component. */
6314 tmp = CLASS_DATA (c)->backend_decl;
6315 comp = fold_build3_loc (input_location, COMPONENT_REF,
6316 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6318 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6319 gfc_add_expr_to_block (&fnblock, tmp);
6321 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6322 void_type_node, comp,
6323 build_int_cst (TREE_TYPE (comp), 0));
6324 gfc_add_expr_to_block (&fnblock, tmp);
6328 case NULLIFY_ALLOC_COMP:
6329 if (c->attr.pointer)
6331 else if (c->attr.allocatable && c->attr.dimension)
6333 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6334 decl, cdecl, NULL_TREE);
6335 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6337 else if (c->attr.allocatable)
6339 /* Allocatable scalar components. */
6340 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6341 decl, cdecl, NULL_TREE);
6342 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6343 void_type_node, comp,
6344 build_int_cst (TREE_TYPE (comp), 0));
6345 gfc_add_expr_to_block (&fnblock, tmp);
6347 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6349 /* Allocatable scalar CLASS components. */
6350 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6351 decl, cdecl, NULL_TREE);
6352 /* Add reference to '$data' component. */
6353 tmp = CLASS_DATA (c)->backend_decl;
6354 comp = fold_build3_loc (input_location, COMPONENT_REF,
6355 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6356 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6357 void_type_node, comp,
6358 build_int_cst (TREE_TYPE (comp), 0));
6359 gfc_add_expr_to_block (&fnblock, tmp);
6361 else if (cmp_has_alloc_comps)
6363 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6364 decl, cdecl, NULL_TREE);
6365 rank = c->as ? c->as->rank : 0;
6366 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6368 gfc_add_expr_to_block (&fnblock, tmp);
6372 case COPY_ALLOC_COMP:
6373 if (c->attr.pointer)
6376 /* We need source and destination components. */
6377 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6379 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6381 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6383 if (c->attr.allocatable && !cmp_has_alloc_comps)
6385 rank = c->as ? c->as->rank : 0;
6386 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6387 gfc_add_expr_to_block (&fnblock, tmp);
6390 if (cmp_has_alloc_comps)
6392 rank = c->as ? c->as->rank : 0;
6393 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6394 gfc_add_modify (&fnblock, dcmp, tmp);
6395 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6397 gfc_add_expr_to_block (&fnblock, tmp);
6407 return gfc_finish_block (&fnblock);
6410 /* Recursively traverse an object of derived type, generating code to
6411 nullify allocatable components. */
6414 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6416 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6417 NULLIFY_ALLOC_COMP);
6421 /* Recursively traverse an object of derived type, generating code to
6422 deallocate allocatable components. */
6425 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6427 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6428 DEALLOCATE_ALLOC_COMP);
6432 /* Recursively traverse an object of derived type, generating code to
6433 copy it and its allocatable components. */
6436 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6438 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6442 /* Recursively traverse an object of derived type, generating code to
6443 copy only its allocatable components. */
6446 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6448 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6452 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6453 Do likewise, recursively if necessary, with the allocatable components of
6457 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
6463 stmtblock_t cleanup;
6466 bool sym_has_alloc_comp;
6468 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6469 && sym->ts.u.derived->attr.alloc_comp;
6471 /* Make sure the frontend gets these right. */
6472 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6473 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6474 "allocatable attribute or derived type without allocatable "
6477 gfc_init_block (&init);
6479 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6480 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6482 if (sym->ts.type == BT_CHARACTER
6483 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6485 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6486 gfc_trans_vla_type_sizes (sym, &init);
6489 /* Dummy, use associated and result variables don't need anything special. */
6490 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6492 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6496 gfc_get_backend_locus (&loc);
6497 gfc_set_backend_locus (&sym->declared_at);
6498 descriptor = sym->backend_decl;
6500 /* Although static, derived types with default initializers and
6501 allocatable components must not be nulled wholesale; instead they
6502 are treated component by component. */
6503 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6505 /* SAVEd variables are not freed on exit. */
6506 gfc_trans_static_array_pointer (sym);
6508 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6512 /* Get the descriptor type. */
6513 type = TREE_TYPE (sym->backend_decl);
6515 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6518 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6520 if (sym->value == NULL
6521 || !gfc_has_default_initializer (sym->ts.u.derived))
6523 rank = sym->as ? sym->as->rank : 0;
6524 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
6526 gfc_add_expr_to_block (&init, tmp);
6529 gfc_init_default_dt (sym, &init, false);
6532 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6534 /* If the backend_decl is not a descriptor, we must have a pointer
6536 descriptor = build_fold_indirect_ref_loc (input_location,
6538 type = TREE_TYPE (descriptor);
6541 /* NULLIFY the data pointer. */
6542 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6543 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
6545 gfc_init_block (&cleanup);
6546 gfc_set_backend_locus (&loc);
6548 /* Allocatable arrays need to be freed when they go out of scope.
6549 The allocatable components of pointers must not be touched. */
6550 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6551 && !sym->attr.pointer && !sym->attr.save)
6554 rank = sym->as ? sym->as->rank : 0;
6555 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6556 gfc_add_expr_to_block (&cleanup, tmp);
6559 if (sym->attr.allocatable && sym->attr.dimension
6560 && !sym->attr.save && !sym->attr.result)
6562 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6563 gfc_add_expr_to_block (&cleanup, tmp);
6566 gfc_add_init_cleanup (block, gfc_finish_block (&init),
6567 gfc_finish_block (&cleanup));
6570 /************ Expression Walking Functions ******************/
6572 /* Walk a variable reference.
6574 Possible extension - multiple component subscripts.
6575 x(:,:) = foo%a(:)%b(:)
6577 forall (i=..., j=...)
6578 x(i,j) = foo%a(j)%b(i)
6580 This adds a fair amount of complexity because you need to deal with more
6581 than one ref. Maybe handle in a similar manner to vector subscripts.
6582 Maybe not worth the effort. */
6586 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6593 for (ref = expr->ref; ref; ref = ref->next)
6594 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6597 for (; ref; ref = ref->next)
6599 if (ref->type == REF_SUBSTRING)
6601 newss = gfc_get_ss ();
6602 newss->type = GFC_SS_SCALAR;
6603 newss->expr = ref->u.ss.start;
6607 newss = gfc_get_ss ();
6608 newss->type = GFC_SS_SCALAR;
6609 newss->expr = ref->u.ss.end;
6614 /* We're only interested in array sections from now on. */
6615 if (ref->type != REF_ARRAY)
6620 if (ar->as->rank == 0)
6622 /* Scalar coarray. */
6629 for (n = 0; n < ar->dimen; n++)
6631 newss = gfc_get_ss ();
6632 newss->type = GFC_SS_SCALAR;
6633 newss->expr = ar->start[n];
6640 newss = gfc_get_ss ();
6641 newss->type = GFC_SS_SECTION;
6644 newss->data.info.dimen = ar->as->rank;
6645 newss->data.info.ref = ref;
6647 /* Make sure array is the same as array(:,:), this way
6648 we don't need to special case all the time. */
6649 ar->dimen = ar->as->rank;
6650 for (n = 0; n < ar->dimen; n++)
6652 newss->data.info.dim[n] = n;
6653 ar->dimen_type[n] = DIMEN_RANGE;
6655 gcc_assert (ar->start[n] == NULL);
6656 gcc_assert (ar->end[n] == NULL);
6657 gcc_assert (ar->stride[n] == NULL);
6663 newss = gfc_get_ss ();
6664 newss->type = GFC_SS_SECTION;
6667 newss->data.info.dimen = 0;
6668 newss->data.info.ref = ref;
6670 /* We add SS chains for all the subscripts in the section. */
6671 for (n = 0; n < ar->dimen; n++)
6675 switch (ar->dimen_type[n])
6678 /* Add SS for elemental (scalar) subscripts. */
6679 gcc_assert (ar->start[n]);
6680 indexss = gfc_get_ss ();
6681 indexss->type = GFC_SS_SCALAR;
6682 indexss->expr = ar->start[n];
6683 indexss->next = gfc_ss_terminator;
6684 indexss->loop_chain = gfc_ss_terminator;
6685 newss->data.info.subscript[n] = indexss;
6689 /* We don't add anything for sections, just remember this
6690 dimension for later. */
6691 newss->data.info.dim[newss->data.info.dimen] = n;
6692 newss->data.info.dimen++;
6696 /* Create a GFC_SS_VECTOR index in which we can store
6697 the vector's descriptor. */
6698 indexss = gfc_get_ss ();
6699 indexss->type = GFC_SS_VECTOR;
6700 indexss->expr = ar->start[n];
6701 indexss->next = gfc_ss_terminator;
6702 indexss->loop_chain = gfc_ss_terminator;
6703 newss->data.info.subscript[n] = indexss;
6704 newss->data.info.dim[newss->data.info.dimen] = n;
6705 newss->data.info.dimen++;
6709 /* We should know what sort of section it is by now. */
6713 /* We should have at least one non-elemental dimension. */
6714 gcc_assert (newss->data.info.dimen > 0);
6719 /* We should know what sort of section it is by now. */
6728 /* Walk an expression operator. If only one operand of a binary expression is
6729 scalar, we must also add the scalar term to the SS chain. */
6732 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6738 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6739 if (expr->value.op.op2 == NULL)
6742 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6744 /* All operands are scalar. Pass back and let the caller deal with it. */
6748 /* All operands require scalarization. */
6749 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6752 /* One of the operands needs scalarization, the other is scalar.
6753 Create a gfc_ss for the scalar expression. */
6754 newss = gfc_get_ss ();
6755 newss->type = GFC_SS_SCALAR;
6758 /* First operand is scalar. We build the chain in reverse order, so
6759 add the scalar SS after the second operand. */
6761 while (head && head->next != ss)
6763 /* Check we haven't somehow broken the chain. */
6767 newss->expr = expr->value.op.op1;
6769 else /* head2 == head */
6771 gcc_assert (head2 == head);
6772 /* Second operand is scalar. */
6773 newss->next = head2;
6775 newss->expr = expr->value.op.op2;
6782 /* Reverse a SS chain. */
6785 gfc_reverse_ss (gfc_ss * ss)
6790 gcc_assert (ss != NULL);
6792 head = gfc_ss_terminator;
6793 while (ss != gfc_ss_terminator)
6796 /* Check we didn't somehow break the chain. */
6797 gcc_assert (next != NULL);
6807 /* Walk the arguments of an elemental function. */
6810 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6818 head = gfc_ss_terminator;
6821 for (; arg; arg = arg->next)
6826 newss = gfc_walk_subexpr (head, arg->expr);
6829 /* Scalar argument. */
6830 newss = gfc_get_ss ();
6832 newss->expr = arg->expr;
6842 while (tail->next != gfc_ss_terminator)
6849 /* If all the arguments are scalar we don't need the argument SS. */
6850 gfc_free_ss_chain (head);
6855 /* Add it onto the existing chain. */
6861 /* Walk a function call. Scalar functions are passed back, and taken out of
6862 scalarization loops. For elemental functions we walk their arguments.
6863 The result of functions returning arrays is stored in a temporary outside
6864 the loop, so that the function is only called once. Hence we do not need
6865 to walk their arguments. */
6868 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6871 gfc_intrinsic_sym *isym;
6873 gfc_component *comp = NULL;
6876 isym = expr->value.function.isym;
6878 /* Handle intrinsic functions separately. */
6880 return gfc_walk_intrinsic_function (ss, expr, isym);
6882 sym = expr->value.function.esym;
6884 sym = expr->symtree->n.sym;
6886 /* A function that returns arrays. */
6887 gfc_is_proc_ptr_comp (expr, &comp);
6888 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6889 || (comp && comp->attr.dimension))
6891 newss = gfc_get_ss ();
6892 newss->type = GFC_SS_FUNCTION;
6895 newss->data.info.dimen = expr->rank;
6896 for (n = 0; n < newss->data.info.dimen; n++)
6897 newss->data.info.dim[n] = n;
6901 /* Walk the parameters of an elemental function. For now we always pass
6903 if (sym->attr.elemental)
6904 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6907 /* Scalar functions are OK as these are evaluated outside the scalarization
6908 loop. Pass back and let the caller deal with it. */
6913 /* An array temporary is constructed for array constructors. */
6916 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6921 newss = gfc_get_ss ();
6922 newss->type = GFC_SS_CONSTRUCTOR;
6925 newss->data.info.dimen = expr->rank;
6926 for (n = 0; n < expr->rank; n++)
6927 newss->data.info.dim[n] = n;
6933 /* Walk an expression. Add walked expressions to the head of the SS chain.
6934 A wholly scalar expression will not be added. */
6937 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6941 switch (expr->expr_type)
6944 head = gfc_walk_variable_expr (ss, expr);
6948 head = gfc_walk_op_expr (ss, expr);
6952 head = gfc_walk_function_expr (ss, expr);
6957 case EXPR_STRUCTURE:
6958 /* Pass back and let the caller deal with it. */
6962 head = gfc_walk_array_constructor (ss, expr);
6965 case EXPR_SUBSTRING:
6966 /* Pass back and let the caller deal with it. */
6970 internal_error ("bad expression type during walk (%d)",
6977 /* Entry point for expression walking.
6978 A return value equal to the passed chain means this is
6979 a scalar expression. It is up to the caller to take whatever action is
6980 necessary to translate these. */
6983 gfc_walk_expr (gfc_expr * expr)
6987 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6988 return gfc_reverse_ss (res);