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"
89 #include "constructor.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
106 gfc_array_dataptr_type (tree desc)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc)
147 type = TREE_TYPE (desc);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
150 field = TYPE_FIELDS (type);
151 gcc_assert (DATA_FIELD == 0);
153 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set. */
168 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
172 type = TREE_TYPE (desc);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
175 field = TYPE_FIELDS (type);
176 gcc_assert (DATA_FIELD == 0);
178 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
179 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
183 /* This provides address access to the data field. This should only be
184 used by array allocation, passing this on to the runtime. */
187 gfc_conv_descriptor_data_addr (tree desc)
191 type = TREE_TYPE (desc);
192 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
194 field = TYPE_FIELDS (type);
195 gcc_assert (DATA_FIELD == 0);
197 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
198 return gfc_build_addr_expr (NULL_TREE, t);
202 gfc_conv_descriptor_offset (tree desc)
207 type = TREE_TYPE (desc);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
210 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
211 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
213 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
214 desc, field, NULL_TREE);
218 gfc_conv_descriptor_offset_get (tree desc)
220 return gfc_conv_descriptor_offset (desc);
224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
227 tree t = gfc_conv_descriptor_offset (desc);
228 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
233 gfc_conv_descriptor_dtype (tree desc)
238 type = TREE_TYPE (desc);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
241 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
242 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
244 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
245 desc, field, NULL_TREE);
249 gfc_conv_descriptor_dimension (tree desc, tree dim)
255 type = TREE_TYPE (desc);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
258 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
259 gcc_assert (field != NULL_TREE
260 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
261 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
263 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
264 desc, field, NULL_TREE);
265 tmp = gfc_build_array_ref (tmp, dim, NULL);
270 gfc_conv_descriptor_stride (tree desc, tree dim)
275 tmp = gfc_conv_descriptor_dimension (desc, dim);
276 field = TYPE_FIELDS (TREE_TYPE (tmp));
277 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
278 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
280 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
281 tmp, field, NULL_TREE);
286 gfc_conv_descriptor_stride_get (tree desc, tree dim)
288 tree type = TREE_TYPE (desc);
289 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
290 if (integer_zerop (dim)
291 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
292 return gfc_index_one_node;
294 return gfc_conv_descriptor_stride (desc, dim);
298 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
299 tree dim, tree value)
301 tree t = gfc_conv_descriptor_stride (desc, dim);
302 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
306 gfc_conv_descriptor_lbound (tree desc, tree dim)
311 tmp = gfc_conv_descriptor_dimension (desc, dim);
312 field = TYPE_FIELDS (TREE_TYPE (tmp));
313 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
314 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
316 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
317 tmp, field, NULL_TREE);
322 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
324 return gfc_conv_descriptor_lbound (desc, dim);
328 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
329 tree dim, tree value)
331 tree t = gfc_conv_descriptor_lbound (desc, dim);
332 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
336 gfc_conv_descriptor_ubound (tree desc, tree dim)
341 tmp = gfc_conv_descriptor_dimension (desc, dim);
342 field = TYPE_FIELDS (TREE_TYPE (tmp));
343 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
344 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
346 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
347 tmp, field, NULL_TREE);
352 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
354 return gfc_conv_descriptor_ubound (desc, dim);
358 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
359 tree dim, tree value)
361 tree t = gfc_conv_descriptor_ubound (desc, dim);
362 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
365 /* Build a null array descriptor constructor. */
368 gfc_build_null_descriptor (tree type)
373 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
374 gcc_assert (DATA_FIELD == 0);
375 field = TYPE_FIELDS (type);
377 /* Set a NULL data pointer. */
378 tmp = build_constructor_single (type, field, null_pointer_node);
379 TREE_CONSTANT (tmp) = 1;
380 /* All other fields are ignored. */
386 /* Cleanup those #defines. */
391 #undef DIMENSION_FIELD
392 #undef STRIDE_SUBFIELD
393 #undef LBOUND_SUBFIELD
394 #undef UBOUND_SUBFIELD
397 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
398 flags & 1 = Main loop body.
399 flags & 2 = temp copy loop. */
402 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
404 for (; ss != gfc_ss_terminator; ss = ss->next)
405 ss->useflags = flags;
408 static void gfc_free_ss (gfc_ss *);
411 /* Free a gfc_ss chain. */
414 gfc_free_ss_chain (gfc_ss * ss)
418 while (ss != gfc_ss_terminator)
420 gcc_assert (ss != NULL);
431 gfc_free_ss (gfc_ss * ss)
438 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
440 if (ss->data.info.subscript[n])
441 gfc_free_ss_chain (ss->data.info.subscript[n]);
453 /* Free all the SS associated with a loop. */
456 gfc_cleanup_loop (gfc_loopinfo * loop)
462 while (ss != gfc_ss_terminator)
464 gcc_assert (ss != NULL);
465 next = ss->loop_chain;
472 /* Associate a SS chain with a loop. */
475 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
479 if (head == gfc_ss_terminator)
483 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
485 if (ss->next == gfc_ss_terminator)
486 ss->loop_chain = loop->ss;
488 ss->loop_chain = ss->next;
490 gcc_assert (ss == gfc_ss_terminator);
495 /* Generate an initializer for a static pointer or allocatable array. */
498 gfc_trans_static_array_pointer (gfc_symbol * sym)
502 gcc_assert (TREE_STATIC (sym->backend_decl));
503 /* Just zero the data member. */
504 type = TREE_TYPE (sym->backend_decl);
505 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
509 /* If the bounds of SE's loop have not yet been set, see if they can be
510 determined from array spec AS, which is the array spec of a called
511 function. MAPPING maps the callee's dummy arguments to the values
512 that the caller is passing. Add any initialization and finalization
516 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
517 gfc_se * se, gfc_array_spec * as)
525 if (as && as->type == AS_EXPLICIT)
526 for (dim = 0; dim < se->loop->dimen; dim++)
528 n = se->loop->order[dim];
529 if (se->loop->to[n] == NULL_TREE)
531 /* Evaluate the lower bound. */
532 gfc_init_se (&tmpse, NULL);
533 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
534 gfc_add_block_to_block (&se->pre, &tmpse.pre);
535 gfc_add_block_to_block (&se->post, &tmpse.post);
536 lower = fold_convert (gfc_array_index_type, tmpse.expr);
538 /* ...and the upper bound. */
539 gfc_init_se (&tmpse, NULL);
540 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
541 gfc_add_block_to_block (&se->pre, &tmpse.pre);
542 gfc_add_block_to_block (&se->post, &tmpse.post);
543 upper = fold_convert (gfc_array_index_type, tmpse.expr);
545 /* Set the upper bound of the loop to UPPER - LOWER. */
546 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
547 tmp = gfc_evaluate_now (tmp, &se->pre);
548 se->loop->to[n] = tmp;
554 /* Generate code to allocate an array temporary, or create a variable to
555 hold the data. If size is NULL, zero the descriptor so that the
556 callee will allocate the array. If DEALLOC is true, also generate code to
557 free the array afterwards.
559 If INITIAL is not NULL, it is packed using internal_pack and the result used
560 as data instead of allocating a fresh, unitialized area of memory.
562 Initialization code is added to PRE and finalization code to POST.
563 DYNAMIC is true if the caller may want to extend the array later
564 using realloc. This prevents us from putting the array on the stack. */
567 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
568 gfc_ss_info * info, tree size, tree nelem,
569 tree initial, bool dynamic, bool dealloc)
575 desc = info->descriptor;
576 info->offset = gfc_index_zero_node;
577 if (size == NULL_TREE || integer_zerop (size))
579 /* A callee allocated array. */
580 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
585 /* Allocate the temporary. */
586 onstack = !dynamic && initial == NULL_TREE
587 && gfc_can_put_var_on_stack (size);
591 /* Make a temporary variable to hold the data. */
592 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
594 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
596 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
598 tmp = gfc_create_var (tmp, "A");
599 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
600 gfc_conv_descriptor_data_set (pre, desc, tmp);
604 /* Allocate memory to hold the data or call internal_pack. */
605 if (initial == NULL_TREE)
607 tmp = gfc_call_malloc (pre, NULL, size);
608 tmp = gfc_evaluate_now (tmp, pre);
615 stmtblock_t do_copying;
617 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
618 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
619 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
620 tmp = gfc_get_element_type (tmp);
621 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
622 packed = gfc_create_var (build_pointer_type (tmp), "data");
624 tmp = build_call_expr_loc (input_location,
625 gfor_fndecl_in_pack, 1, initial);
626 tmp = fold_convert (TREE_TYPE (packed), tmp);
627 gfc_add_modify (pre, packed, tmp);
629 tmp = build_fold_indirect_ref_loc (input_location,
631 source_data = gfc_conv_descriptor_data_get (tmp);
633 /* internal_pack may return source->data without any allocation
634 or copying if it is already packed. If that's the case, we
635 need to allocate and copy manually. */
637 gfc_start_block (&do_copying);
638 tmp = gfc_call_malloc (&do_copying, NULL, size);
639 tmp = fold_convert (TREE_TYPE (packed), tmp);
640 gfc_add_modify (&do_copying, packed, tmp);
641 tmp = gfc_build_memcpy_call (packed, source_data, size);
642 gfc_add_expr_to_block (&do_copying, tmp);
644 was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
645 packed, source_data);
646 tmp = gfc_finish_block (&do_copying);
647 tmp = build3_v (COND_EXPR, was_packed, tmp,
648 build_empty_stmt (input_location));
649 gfc_add_expr_to_block (pre, tmp);
651 tmp = fold_convert (pvoid_type_node, packed);
654 gfc_conv_descriptor_data_set (pre, desc, tmp);
657 info->data = gfc_conv_descriptor_data_get (desc);
659 /* The offset is zero because we create temporaries with a zero
661 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
663 if (dealloc && !onstack)
665 /* Free the temporary. */
666 tmp = gfc_conv_descriptor_data_get (desc);
667 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
668 gfc_add_expr_to_block (post, tmp);
673 /* Generate code to create and initialize the descriptor for a temporary
674 array. This is used for both temporaries needed by the scalarizer, and
675 functions returning arrays. Adjusts the loop variables to be
676 zero-based, and calculates the loop bounds for callee allocated arrays.
677 Allocate the array unless it's callee allocated (we have a callee
678 allocated array if 'callee_alloc' is true, or if loop->to[n] is
679 NULL_TREE for any n). Also fills in the descriptor, data and offset
680 fields of info if known. Returns the size of the array, or NULL for a
681 callee allocated array.
683 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
684 gfc_trans_allocate_array_storage.
688 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
689 gfc_loopinfo * loop, gfc_ss_info * info,
690 tree eltype, tree initial, bool dynamic,
691 bool dealloc, bool callee_alloc, locus * where)
703 gcc_assert (info->dimen > 0);
705 if (gfc_option.warn_array_temp && where)
706 gfc_warning ("Creating array temporary at %L", where);
708 /* Set the lower bound to zero. */
709 for (dim = 0; dim < info->dimen; dim++)
711 n = loop->order[dim];
712 /* Callee allocated arrays may not have a known bound yet. */
714 loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
715 gfc_array_index_type,
716 loop->to[n], loop->from[n]), pre);
717 loop->from[n] = gfc_index_zero_node;
719 info->delta[dim] = gfc_index_zero_node;
720 info->start[dim] = gfc_index_zero_node;
721 info->end[dim] = gfc_index_zero_node;
722 info->stride[dim] = gfc_index_one_node;
723 info->dim[dim] = dim;
726 /* Initialize the descriptor. */
728 gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
729 GFC_ARRAY_UNKNOWN, true);
730 desc = gfc_create_var (type, "atmp");
731 GFC_DECL_PACKED_ARRAY (desc) = 1;
733 info->descriptor = desc;
734 size = gfc_index_one_node;
736 /* Fill in the array dtype. */
737 tmp = gfc_conv_descriptor_dtype (desc);
738 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
741 Fill in the bounds and stride. This is a packed array, so:
744 for (n = 0; n < rank; n++)
747 delta = ubound[n] + 1 - lbound[n];
750 size = size * sizeof(element);
755 /* If there is at least one null loop->to[n], it is a callee allocated
757 for (n = 0; n < info->dimen; n++)
758 if (loop->to[n] == NULL_TREE)
764 for (n = 0; n < info->dimen; n++)
766 if (size == NULL_TREE)
768 /* For a callee allocated array express the loop bounds in terms
769 of the descriptor fields. */
771 fold_build2 (MINUS_EXPR, gfc_array_index_type,
772 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
773 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
778 /* Store the stride and bound components in the descriptor. */
779 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
781 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
782 gfc_index_zero_node);
784 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
786 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
787 loop->to[n], gfc_index_one_node);
789 /* Check whether the size for this dimension is negative. */
790 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
791 gfc_index_zero_node);
792 cond = gfc_evaluate_now (cond, pre);
797 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
799 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
800 size = gfc_evaluate_now (size, pre);
803 /* Get the size of the array. */
805 if (size && !callee_alloc)
807 /* If or_expr is true, then the extent in at least one
808 dimension is zero and the size is set to zero. */
809 size = fold_build3 (COND_EXPR, gfc_array_index_type,
810 or_expr, gfc_index_zero_node, size);
813 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
814 fold_convert (gfc_array_index_type,
815 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
823 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
826 if (info->dimen > loop->temp_dim)
827 loop->temp_dim = info->dimen;
833 /* Generate code to transpose array EXPR by creating a new descriptor
834 in which the dimension specifications have been reversed. */
837 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
839 tree dest, src, dest_index, src_index;
841 gfc_ss_info *dest_info;
842 gfc_ss *dest_ss, *src_ss;
848 src_ss = gfc_walk_expr (expr);
851 dest_info = &dest_ss->data.info;
852 gcc_assert (dest_info->dimen == 2);
854 /* Get a descriptor for EXPR. */
855 gfc_init_se (&src_se, NULL);
856 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
857 gfc_add_block_to_block (&se->pre, &src_se.pre);
858 gfc_add_block_to_block (&se->post, &src_se.post);
861 /* Allocate a new descriptor for the return value. */
862 dest = gfc_create_var (TREE_TYPE (src), "atmp");
863 dest_info->descriptor = dest;
866 /* Copy across the dtype field. */
867 gfc_add_modify (&se->pre,
868 gfc_conv_descriptor_dtype (dest),
869 gfc_conv_descriptor_dtype (src));
871 /* Copy the dimension information, renumbering dimension 1 to 0 and
873 for (n = 0; n < 2; n++)
875 dest_info->delta[n] = gfc_index_zero_node;
876 dest_info->start[n] = gfc_index_zero_node;
877 dest_info->end[n] = gfc_index_zero_node;
878 dest_info->stride[n] = gfc_index_one_node;
879 dest_info->dim[n] = n;
881 dest_index = gfc_rank_cst[n];
882 src_index = gfc_rank_cst[1 - n];
884 gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
885 gfc_conv_descriptor_stride_get (src, src_index));
887 gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
888 gfc_conv_descriptor_lbound_get (src, src_index));
890 gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
891 gfc_conv_descriptor_ubound_get (src, src_index));
895 gcc_assert (integer_zerop (loop->from[n]));
897 fold_build2 (MINUS_EXPR, gfc_array_index_type,
898 gfc_conv_descriptor_ubound_get (dest, dest_index),
899 gfc_conv_descriptor_lbound_get (dest, dest_index));
903 /* Copy the data pointer. */
904 dest_info->data = gfc_conv_descriptor_data_get (src);
905 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
907 /* Copy the offset. This is not changed by transposition; the top-left
908 element is still at the same offset as before, except where the loop
910 if (!integer_zerop (loop->from[0]))
911 dest_info->offset = gfc_conv_descriptor_offset_get (src);
913 dest_info->offset = gfc_index_zero_node;
915 gfc_conv_descriptor_offset_set (&se->pre, dest,
918 if (dest_info->dimen > loop->temp_dim)
919 loop->temp_dim = dest_info->dimen;
923 /* Return the number of iterations in a loop that starts at START,
924 ends at END, and has step STEP. */
927 gfc_get_iteration_count (tree start, tree end, tree step)
932 type = TREE_TYPE (step);
933 tmp = fold_build2 (MINUS_EXPR, type, end, start);
934 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
935 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
936 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
937 return fold_convert (gfc_array_index_type, tmp);
941 /* Extend the data in array DESC by EXTRA elements. */
944 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
951 if (integer_zerop (extra))
954 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
956 /* Add EXTRA to the upper bound. */
957 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
958 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
960 /* Get the value of the current data pointer. */
961 arg0 = gfc_conv_descriptor_data_get (desc);
963 /* Calculate the new array size. */
964 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
965 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
966 ubound, gfc_index_one_node);
967 arg1 = fold_build2 (MULT_EXPR, size_type_node,
968 fold_convert (size_type_node, tmp),
969 fold_convert (size_type_node, size));
971 /* Call the realloc() function. */
972 tmp = gfc_call_realloc (pblock, arg0, arg1);
973 gfc_conv_descriptor_data_set (pblock, desc, tmp);
977 /* Return true if the bounds of iterator I can only be determined
981 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
983 return (i->start->expr_type != EXPR_CONSTANT
984 || i->end->expr_type != EXPR_CONSTANT
985 || i->step->expr_type != EXPR_CONSTANT);
989 /* Split the size of constructor element EXPR into the sum of two terms,
990 one of which can be determined at compile time and one of which must
991 be calculated at run time. Set *SIZE to the former and return true
992 if the latter might be nonzero. */
995 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
997 if (expr->expr_type == EXPR_ARRAY)
998 return gfc_get_array_constructor_size (size, expr->value.constructor);
999 else if (expr->rank > 0)
1001 /* Calculate everything at run time. */
1002 mpz_set_ui (*size, 0);
1007 /* A single element. */
1008 mpz_set_ui (*size, 1);
1014 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1015 of array constructor C. */
1018 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1026 mpz_set_ui (*size, 0);
1031 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1034 if (i && gfc_iterator_has_dynamic_bounds (i))
1038 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1041 /* Multiply the static part of the element size by the
1042 number of iterations. */
1043 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1044 mpz_fdiv_q (val, val, i->step->value.integer);
1045 mpz_add_ui (val, val, 1);
1046 if (mpz_sgn (val) > 0)
1047 mpz_mul (len, len, val);
1049 mpz_set_ui (len, 0);
1051 mpz_add (*size, *size, len);
1060 /* Make sure offset is a variable. */
1063 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1066 /* We should have already created the offset variable. We cannot
1067 create it here because we may be in an inner scope. */
1068 gcc_assert (*offsetvar != NULL_TREE);
1069 gfc_add_modify (pblock, *offsetvar, *poffset);
1070 *poffset = *offsetvar;
1071 TREE_USED (*offsetvar) = 1;
1075 /* Variables needed for bounds-checking. */
1076 static bool first_len;
1077 static tree first_len_val;
1078 static bool typespec_chararray_ctor;
1081 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1082 tree offset, gfc_se * se, gfc_expr * expr)
1086 gfc_conv_expr (se, expr);
1088 /* Store the value. */
1089 tmp = build_fold_indirect_ref_loc (input_location,
1090 gfc_conv_descriptor_data_get (desc));
1091 tmp = gfc_build_array_ref (tmp, offset, NULL);
1093 if (expr->ts.type == BT_CHARACTER)
1095 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1098 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1099 esize = fold_convert (gfc_charlen_type_node, esize);
1100 esize = fold_build2 (TRUNC_DIV_EXPR, 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 (NE_EXPR, boolean_type_node,
1133 first_len_val, se->string_length);
1134 gfc_trans_runtime_check
1135 (true, false, cond, &se->pre, &expr->where,
1136 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1137 fold_convert (long_integer_type_node, first_len_val),
1138 fold_convert (long_integer_type_node, se->string_length));
1144 /* TODO: Should the frontend already have done this conversion? */
1145 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1146 gfc_add_modify (&se->pre, tmp, se->expr);
1149 gfc_add_block_to_block (pblock, &se->pre);
1150 gfc_add_block_to_block (pblock, &se->post);
1154 /* Add the contents of an array to the constructor. DYNAMIC is as for
1155 gfc_trans_array_constructor_value. */
1158 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1159 tree type ATTRIBUTE_UNUSED,
1160 tree desc, gfc_expr * expr,
1161 tree * poffset, tree * offsetvar,
1172 /* We need this to be a variable so we can increment it. */
1173 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1175 gfc_init_se (&se, NULL);
1177 /* Walk the array expression. */
1178 ss = gfc_walk_expr (expr);
1179 gcc_assert (ss != gfc_ss_terminator);
1181 /* Initialize the scalarizer. */
1182 gfc_init_loopinfo (&loop);
1183 gfc_add_ss_to_loop (&loop, ss);
1185 /* Initialize the loop. */
1186 gfc_conv_ss_startstride (&loop);
1187 gfc_conv_loop_setup (&loop, &expr->where);
1189 /* Make sure the constructed array has room for the new data. */
1192 /* Set SIZE to the total number of elements in the subarray. */
1193 size = gfc_index_one_node;
1194 for (n = 0; n < loop.dimen; n++)
1196 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1197 gfc_index_one_node);
1198 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1201 /* Grow the constructed array by SIZE elements. */
1202 gfc_grow_array (&loop.pre, desc, size);
1205 /* Make the loop body. */
1206 gfc_mark_ss_chain_used (ss, 1);
1207 gfc_start_scalarized_body (&loop, &body);
1208 gfc_copy_loopinfo_to_se (&se, &loop);
1211 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1212 gcc_assert (se.ss == gfc_ss_terminator);
1214 /* Increment the offset. */
1215 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1216 *poffset, gfc_index_one_node);
1217 gfc_add_modify (&body, *poffset, tmp);
1219 /* Finish the loop. */
1220 gfc_trans_scalarizing_loops (&loop, &body);
1221 gfc_add_block_to_block (&loop.pre, &loop.post);
1222 tmp = gfc_finish_block (&loop.pre);
1223 gfc_add_expr_to_block (pblock, tmp);
1225 gfc_cleanup_loop (&loop);
1229 /* Assign the values to the elements of an array constructor. DYNAMIC
1230 is true if descriptor DESC only contains enough data for the static
1231 size calculated by gfc_get_array_constructor_size. When true, memory
1232 for the dynamic parts must be allocated using realloc. */
1235 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1236 tree desc, gfc_constructor_base base,
1237 tree * poffset, tree * offsetvar,
1246 tree shadow_loopvar = NULL_TREE;
1247 gfc_saved_var saved_loopvar;
1250 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1252 /* If this is an iterator or an array, the offset must be a variable. */
1253 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1254 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1256 /* Shadowing the iterator avoids changing its value and saves us from
1257 keeping track of it. Further, it makes sure that there's always a
1258 backend-decl for the symbol, even if there wasn't one before,
1259 e.g. in the case of an iterator that appears in a specification
1260 expression in an interface mapping. */
1263 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1264 tree type = gfc_typenode_for_spec (&sym->ts);
1266 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1267 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1270 gfc_start_block (&body);
1272 if (c->expr->expr_type == EXPR_ARRAY)
1274 /* Array constructors can be nested. */
1275 gfc_trans_array_constructor_value (&body, type, desc,
1276 c->expr->value.constructor,
1277 poffset, offsetvar, dynamic);
1279 else if (c->expr->rank > 0)
1281 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1282 poffset, offsetvar, dynamic);
1286 /* This code really upsets the gimplifier so don't bother for now. */
1293 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1295 p = gfc_constructor_next (p);
1300 /* Scalar values. */
1301 gfc_init_se (&se, NULL);
1302 gfc_trans_array_ctor_element (&body, desc, *poffset,
1305 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1306 *poffset, gfc_index_one_node);
1310 /* Collect multiple scalar constants into a constructor. */
1311 VEC(constructor_elt,gc) *v = NULL;
1315 HOST_WIDE_INT idx = 0;
1318 /* Count the number of consecutive scalar constants. */
1319 while (p && !(p->iterator
1320 || p->expr->expr_type != EXPR_CONSTANT))
1322 gfc_init_se (&se, NULL);
1323 gfc_conv_constant (&se, p->expr);
1325 if (c->expr->ts.type != BT_CHARACTER)
1326 se.expr = fold_convert (type, se.expr);
1327 /* For constant character array constructors we build
1328 an array of pointers. */
1329 else if (POINTER_TYPE_P (type))
1330 se.expr = gfc_build_addr_expr
1331 (gfc_get_pchar_type (p->expr->ts.kind),
1334 CONSTRUCTOR_APPEND_ELT (v,
1335 build_int_cst (gfc_array_index_type,
1339 p = gfc_constructor_next (p);
1342 bound = build_int_cst (NULL_TREE, n - 1);
1343 /* Create an array type to hold them. */
1344 tmptype = build_range_type (gfc_array_index_type,
1345 gfc_index_zero_node, bound);
1346 tmptype = build_array_type (type, tmptype);
1348 init = build_constructor (tmptype, v);
1349 TREE_CONSTANT (init) = 1;
1350 TREE_STATIC (init) = 1;
1351 /* Create a static variable to hold the data. */
1352 tmp = gfc_create_var (tmptype, "data");
1353 TREE_STATIC (tmp) = 1;
1354 TREE_CONSTANT (tmp) = 1;
1355 TREE_READONLY (tmp) = 1;
1356 DECL_INITIAL (tmp) = init;
1359 /* Use BUILTIN_MEMCPY to assign the values. */
1360 tmp = gfc_conv_descriptor_data_get (desc);
1361 tmp = build_fold_indirect_ref_loc (input_location,
1363 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1364 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1365 init = gfc_build_addr_expr (NULL_TREE, init);
1367 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1368 bound = build_int_cst (NULL_TREE, n * size);
1369 tmp = build_call_expr_loc (input_location,
1370 built_in_decls[BUILT_IN_MEMCPY], 3,
1372 gfc_add_expr_to_block (&body, tmp);
1374 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1376 build_int_cst (gfc_array_index_type, n));
1378 if (!INTEGER_CST_P (*poffset))
1380 gfc_add_modify (&body, *offsetvar, *poffset);
1381 *poffset = *offsetvar;
1385 /* The frontend should already have done any expansions
1389 /* Pass the code as is. */
1390 tmp = gfc_finish_block (&body);
1391 gfc_add_expr_to_block (pblock, tmp);
1395 /* Build the implied do-loop. */
1396 stmtblock_t implied_do_block;
1404 loopbody = gfc_finish_block (&body);
1406 /* Create a new block that holds the implied-do loop. A temporary
1407 loop-variable is used. */
1408 gfc_start_block(&implied_do_block);
1410 /* Initialize the loop. */
1411 gfc_init_se (&se, NULL);
1412 gfc_conv_expr_val (&se, c->iterator->start);
1413 gfc_add_block_to_block (&implied_do_block, &se.pre);
1414 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1416 gfc_init_se (&se, NULL);
1417 gfc_conv_expr_val (&se, c->iterator->end);
1418 gfc_add_block_to_block (&implied_do_block, &se.pre);
1419 end = gfc_evaluate_now (se.expr, &implied_do_block);
1421 gfc_init_se (&se, NULL);
1422 gfc_conv_expr_val (&se, c->iterator->step);
1423 gfc_add_block_to_block (&implied_do_block, &se.pre);
1424 step = gfc_evaluate_now (se.expr, &implied_do_block);
1426 /* If this array expands dynamically, and the number of iterations
1427 is not constant, we won't have allocated space for the static
1428 part of C->EXPR's size. Do that now. */
1429 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1431 /* Get the number of iterations. */
1432 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1434 /* Get the static part of C->EXPR's size. */
1435 gfc_get_array_constructor_element_size (&size, c->expr);
1436 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1438 /* Grow the array by TMP * TMP2 elements. */
1439 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1440 gfc_grow_array (&implied_do_block, desc, tmp);
1443 /* Generate the loop body. */
1444 exit_label = gfc_build_label_decl (NULL_TREE);
1445 gfc_start_block (&body);
1447 /* Generate the exit condition. Depending on the sign of
1448 the step variable we have to generate the correct
1450 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1451 build_int_cst (TREE_TYPE (step), 0));
1452 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1453 fold_build2 (GT_EXPR, boolean_type_node,
1454 shadow_loopvar, end),
1455 fold_build2 (LT_EXPR, boolean_type_node,
1456 shadow_loopvar, end));
1457 tmp = build1_v (GOTO_EXPR, exit_label);
1458 TREE_USED (exit_label) = 1;
1459 tmp = build3_v (COND_EXPR, cond, tmp,
1460 build_empty_stmt (input_location));
1461 gfc_add_expr_to_block (&body, tmp);
1463 /* The main loop body. */
1464 gfc_add_expr_to_block (&body, loopbody);
1466 /* Increase loop variable by step. */
1467 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1468 gfc_add_modify (&body, shadow_loopvar, tmp);
1470 /* Finish the loop. */
1471 tmp = gfc_finish_block (&body);
1472 tmp = build1_v (LOOP_EXPR, tmp);
1473 gfc_add_expr_to_block (&implied_do_block, tmp);
1475 /* Add the exit label. */
1476 tmp = build1_v (LABEL_EXPR, exit_label);
1477 gfc_add_expr_to_block (&implied_do_block, tmp);
1479 /* Finishe the implied-do loop. */
1480 tmp = gfc_finish_block(&implied_do_block);
1481 gfc_add_expr_to_block(pblock, tmp);
1483 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1490 /* Figure out the string length of a variable reference expression.
1491 Used by get_array_ctor_strlen. */
1494 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1500 /* Don't bother if we already know the length is a constant. */
1501 if (*len && INTEGER_CST_P (*len))
1504 ts = &expr->symtree->n.sym->ts;
1505 for (ref = expr->ref; ref; ref = ref->next)
1510 /* Array references don't change the string length. */
1514 /* Use the length of the component. */
1515 ts = &ref->u.c.component->ts;
1519 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1520 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1522 mpz_init_set_ui (char_len, 1);
1523 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1524 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1525 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1526 *len = convert (gfc_charlen_type_node, *len);
1527 mpz_clear (char_len);
1531 /* TODO: Substrings are tricky because we can't evaluate the
1532 expression more than once. For now we just give up, and hope
1533 we can figure it out elsewhere. */
1538 *len = ts->u.cl->backend_decl;
1542 /* A catch-all to obtain the string length for anything that is not a
1543 constant, array or variable. */
1545 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1550 /* Don't bother if we already know the length is a constant. */
1551 if (*len && INTEGER_CST_P (*len))
1554 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1555 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1558 gfc_conv_const_charlen (e->ts.u.cl);
1559 *len = e->ts.u.cl->backend_decl;
1563 /* Otherwise, be brutal even if inefficient. */
1564 ss = gfc_walk_expr (e);
1565 gfc_init_se (&se, NULL);
1567 /* No function call, in case of side effects. */
1568 se.no_function_call = 1;
1569 if (ss == gfc_ss_terminator)
1570 gfc_conv_expr (&se, e);
1572 gfc_conv_expr_descriptor (&se, e, ss);
1574 /* Fix the value. */
1575 *len = gfc_evaluate_now (se.string_length, &se.pre);
1577 gfc_add_block_to_block (block, &se.pre);
1578 gfc_add_block_to_block (block, &se.post);
1580 e->ts.u.cl->backend_decl = *len;
1585 /* Figure out the string length of a character array constructor.
1586 If len is NULL, don't calculate the length; this happens for recursive calls
1587 when a sub-array-constructor is an element but not at the first position,
1588 so when we're not interested in the length.
1589 Returns TRUE if all elements are character constants. */
1592 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1599 if (gfc_constructor_first (base) == NULL)
1602 *len = build_int_cstu (gfc_charlen_type_node, 0);
1606 /* Loop over all constructor elements to find out is_const, but in len we
1607 want to store the length of the first, not the last, element. We can
1608 of course exit the loop as soon as is_const is found to be false. */
1609 for (c = gfc_constructor_first (base);
1610 c && is_const; c = gfc_constructor_next (c))
1612 switch (c->expr->expr_type)
1615 if (len && !(*len && INTEGER_CST_P (*len)))
1616 *len = build_int_cstu (gfc_charlen_type_node,
1617 c->expr->value.character.length);
1621 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1628 get_array_ctor_var_strlen (c->expr, len);
1634 get_array_ctor_all_strlen (block, c->expr, len);
1638 /* After the first iteration, we don't want the length modified. */
1645 /* Check whether the array constructor C consists entirely of constant
1646 elements, and if so returns the number of those elements, otherwise
1647 return zero. Note, an empty or NULL array constructor returns zero. */
1649 unsigned HOST_WIDE_INT
1650 gfc_constant_array_constructor_p (gfc_constructor_base base)
1652 unsigned HOST_WIDE_INT nelem = 0;
1654 gfc_constructor *c = gfc_constructor_first (base);
1658 || c->expr->rank > 0
1659 || c->expr->expr_type != EXPR_CONSTANT)
1661 c = gfc_constructor_next (c);
1668 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1669 and the tree type of it's elements, TYPE, return a static constant
1670 variable that is compile-time initialized. */
1673 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1675 tree tmptype, init, tmp;
1676 HOST_WIDE_INT nelem;
1681 VEC(constructor_elt,gc) *v = NULL;
1683 /* First traverse the constructor list, converting the constants
1684 to tree to build an initializer. */
1686 c = gfc_constructor_first (expr->value.constructor);
1689 gfc_init_se (&se, NULL);
1690 gfc_conv_constant (&se, c->expr);
1691 if (c->expr->ts.type != BT_CHARACTER)
1692 se.expr = fold_convert (type, se.expr);
1693 else if (POINTER_TYPE_P (type))
1694 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1696 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1698 c = gfc_constructor_next (c);
1702 /* Next determine the tree type for the array. We use the gfortran
1703 front-end's gfc_get_nodesc_array_type in order to create a suitable
1704 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1706 memset (&as, 0, sizeof (gfc_array_spec));
1708 as.rank = expr->rank;
1709 as.type = AS_EXPLICIT;
1712 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1713 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1717 for (i = 0; i < expr->rank; i++)
1719 int tmp = (int) mpz_get_si (expr->shape[i]);
1720 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1721 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1725 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1727 init = build_constructor (tmptype, v);
1729 TREE_CONSTANT (init) = 1;
1730 TREE_STATIC (init) = 1;
1732 tmp = gfc_create_var (tmptype, "A");
1733 TREE_STATIC (tmp) = 1;
1734 TREE_CONSTANT (tmp) = 1;
1735 TREE_READONLY (tmp) = 1;
1736 DECL_INITIAL (tmp) = init;
1742 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1743 This mostly initializes the scalarizer state info structure with the
1744 appropriate values to directly use the array created by the function
1745 gfc_build_constant_array_constructor. */
1748 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1749 gfc_ss * ss, tree type)
1755 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1757 info = &ss->data.info;
1759 info->descriptor = tmp;
1760 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1761 info->offset = gfc_index_zero_node;
1763 for (i = 0; i < info->dimen; i++)
1765 info->delta[i] = gfc_index_zero_node;
1766 info->start[i] = gfc_index_zero_node;
1767 info->end[i] = gfc_index_zero_node;
1768 info->stride[i] = gfc_index_one_node;
1772 if (info->dimen > loop->temp_dim)
1773 loop->temp_dim = info->dimen;
1776 /* Helper routine of gfc_trans_array_constructor to determine if the
1777 bounds of the loop specified by LOOP are constant and simple enough
1778 to use with gfc_trans_constant_array_constructor. Returns the
1779 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1782 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1784 tree size = gfc_index_one_node;
1788 for (i = 0; i < loop->dimen; i++)
1790 /* If the bounds aren't constant, return NULL_TREE. */
1791 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1793 if (!integer_zerop (loop->from[i]))
1795 /* Only allow nonzero "from" in one-dimensional arrays. */
1796 if (loop->dimen != 1)
1798 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1799 loop->to[i], loop->from[i]);
1803 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1804 tmp, gfc_index_one_node);
1805 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1812 /* Array constructors are handled by constructing a temporary, then using that
1813 within the scalarization loop. This is not optimal, but seems by far the
1817 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1819 gfc_constructor_base c;
1825 bool old_first_len, old_typespec_chararray_ctor;
1826 tree old_first_len_val;
1828 /* Save the old values for nested checking. */
1829 old_first_len = first_len;
1830 old_first_len_val = first_len_val;
1831 old_typespec_chararray_ctor = typespec_chararray_ctor;
1833 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1834 typespec was given for the array constructor. */
1835 typespec_chararray_ctor = (ss->expr->ts.u.cl
1836 && ss->expr->ts.u.cl->length_from_typespec);
1838 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1839 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1841 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1845 ss->data.info.dimen = loop->dimen;
1847 c = ss->expr->value.constructor;
1848 if (ss->expr->ts.type == BT_CHARACTER)
1852 /* get_array_ctor_strlen walks the elements of the constructor, if a
1853 typespec was given, we already know the string length and want the one
1855 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1856 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1860 const_string = false;
1861 gfc_init_se (&length_se, NULL);
1862 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1863 gfc_charlen_type_node);
1864 ss->string_length = length_se.expr;
1865 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1866 gfc_add_block_to_block (&loop->post, &length_se.post);
1869 const_string = get_array_ctor_strlen (&loop->pre, c,
1870 &ss->string_length);
1872 /* Complex character array constructors should have been taken care of
1873 and not end up here. */
1874 gcc_assert (ss->string_length);
1876 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1878 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1880 type = build_pointer_type (type);
1883 type = gfc_typenode_for_spec (&ss->expr->ts);
1885 /* See if the constructor determines the loop bounds. */
1888 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1890 /* We have a multidimensional parameter. */
1892 for (n = 0; n < ss->expr->rank; n++)
1894 loop->from[n] = gfc_index_zero_node;
1895 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1896 gfc_index_integer_kind);
1897 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1898 loop->to[n], gfc_index_one_node);
1902 if (loop->to[0] == NULL_TREE)
1906 /* We should have a 1-dimensional, zero-based loop. */
1907 gcc_assert (loop->dimen == 1);
1908 gcc_assert (integer_zerop (loop->from[0]));
1910 /* Split the constructor size into a static part and a dynamic part.
1911 Allocate the static size up-front and record whether the dynamic
1912 size might be nonzero. */
1914 dynamic = gfc_get_array_constructor_size (&size, c);
1915 mpz_sub_ui (size, size, 1);
1916 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1920 /* Special case constant array constructors. */
1923 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1926 tree size = constant_array_constructor_loop_size (loop);
1927 if (size && compare_tree_int (size, nelem) == 0)
1929 gfc_trans_constant_array_constructor (loop, ss, type);
1935 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1936 type, NULL_TREE, dynamic, true, false, where);
1938 desc = ss->data.info.descriptor;
1939 offset = gfc_index_zero_node;
1940 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1941 TREE_NO_WARNING (offsetvar) = 1;
1942 TREE_USED (offsetvar) = 0;
1943 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1944 &offset, &offsetvar, dynamic);
1946 /* If the array grows dynamically, the upper bound of the loop variable
1947 is determined by the array's final upper bound. */
1949 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1951 if (TREE_USED (offsetvar))
1952 pushdecl (offsetvar);
1954 gcc_assert (INTEGER_CST_P (offset));
1956 /* Disable bound checking for now because it's probably broken. */
1957 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1964 /* Restore old values of globals. */
1965 first_len = old_first_len;
1966 first_len_val = old_first_len_val;
1967 typespec_chararray_ctor = old_typespec_chararray_ctor;
1971 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1972 called after evaluating all of INFO's vector dimensions. Go through
1973 each such vector dimension and see if we can now fill in any missing
1977 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1986 for (n = 0; n < loop->dimen; n++)
1989 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1990 && loop->to[n] == NULL)
1992 /* Loop variable N indexes vector dimension DIM, and we don't
1993 yet know the upper bound of loop variable N. Set it to the
1994 difference between the vector's upper and lower bounds. */
1995 gcc_assert (loop->from[n] == gfc_index_zero_node);
1996 gcc_assert (info->subscript[dim]
1997 && info->subscript[dim]->type == GFC_SS_VECTOR);
1999 gfc_init_se (&se, NULL);
2000 desc = info->subscript[dim]->data.info.descriptor;
2001 zero = gfc_rank_cst[0];
2002 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2003 gfc_conv_descriptor_ubound_get (desc, zero),
2004 gfc_conv_descriptor_lbound_get (desc, zero));
2005 tmp = gfc_evaluate_now (tmp, &loop->pre);
2012 /* Add the pre and post chains for all the scalar expressions in a SS chain
2013 to loop. This is called after the loop parameters have been calculated,
2014 but before the actual scalarizing loops. */
2017 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2023 /* TODO: This can generate bad code if there are ordering dependencies,
2024 e.g., a callee allocated function and an unknown size constructor. */
2025 gcc_assert (ss != NULL);
2027 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2034 /* Scalar expression. Evaluate this now. This includes elemental
2035 dimension indices, but not array section bounds. */
2036 gfc_init_se (&se, NULL);
2037 gfc_conv_expr (&se, ss->expr);
2038 gfc_add_block_to_block (&loop->pre, &se.pre);
2040 if (ss->expr->ts.type != BT_CHARACTER)
2042 /* Move the evaluation of scalar expressions outside the
2043 scalarization loop, except for WHERE assignments. */
2045 se.expr = convert(gfc_array_index_type, se.expr);
2047 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2048 gfc_add_block_to_block (&loop->pre, &se.post);
2051 gfc_add_block_to_block (&loop->post, &se.post);
2053 ss->data.scalar.expr = se.expr;
2054 ss->string_length = se.string_length;
2057 case GFC_SS_REFERENCE:
2058 /* Scalar argument to elemental procedure. Evaluate this
2060 gfc_init_se (&se, NULL);
2061 gfc_conv_expr (&se, ss->expr);
2062 gfc_add_block_to_block (&loop->pre, &se.pre);
2063 gfc_add_block_to_block (&loop->post, &se.post);
2065 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2066 ss->string_length = se.string_length;
2069 case GFC_SS_SECTION:
2070 /* Add the expressions for scalar and vector subscripts. */
2071 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2072 if (ss->data.info.subscript[n])
2073 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2076 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2080 /* Get the vector's descriptor and store it in SS. */
2081 gfc_init_se (&se, NULL);
2082 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2083 gfc_add_block_to_block (&loop->pre, &se.pre);
2084 gfc_add_block_to_block (&loop->post, &se.post);
2085 ss->data.info.descriptor = se.expr;
2088 case GFC_SS_INTRINSIC:
2089 gfc_add_intrinsic_ss_code (loop, ss);
2092 case GFC_SS_FUNCTION:
2093 /* Array function return value. We call the function and save its
2094 result in a temporary for use inside the loop. */
2095 gfc_init_se (&se, NULL);
2098 gfc_conv_expr (&se, ss->expr);
2099 gfc_add_block_to_block (&loop->pre, &se.pre);
2100 gfc_add_block_to_block (&loop->post, &se.post);
2101 ss->string_length = se.string_length;
2104 case GFC_SS_CONSTRUCTOR:
2105 if (ss->expr->ts.type == BT_CHARACTER
2106 && ss->string_length == NULL
2107 && ss->expr->ts.u.cl
2108 && ss->expr->ts.u.cl->length)
2110 gfc_init_se (&se, NULL);
2111 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2112 gfc_charlen_type_node);
2113 ss->string_length = se.expr;
2114 gfc_add_block_to_block (&loop->pre, &se.pre);
2115 gfc_add_block_to_block (&loop->post, &se.post);
2117 gfc_trans_array_constructor (loop, ss, where);
2121 case GFC_SS_COMPONENT:
2122 /* Do nothing. These are handled elsewhere. */
2132 /* Translate expressions for the descriptor and data pointer of a SS. */
2136 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2141 /* Get the descriptor for the array to be scalarized. */
2142 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2143 gfc_init_se (&se, NULL);
2144 se.descriptor_only = 1;
2145 gfc_conv_expr_lhs (&se, ss->expr);
2146 gfc_add_block_to_block (block, &se.pre);
2147 ss->data.info.descriptor = se.expr;
2148 ss->string_length = se.string_length;
2152 /* Also the data pointer. */
2153 tmp = gfc_conv_array_data (se.expr);
2154 /* If this is a variable or address of a variable we use it directly.
2155 Otherwise we must evaluate it now to avoid breaking dependency
2156 analysis by pulling the expressions for elemental array indices
2159 || (TREE_CODE (tmp) == ADDR_EXPR
2160 && DECL_P (TREE_OPERAND (tmp, 0)))))
2161 tmp = gfc_evaluate_now (tmp, block);
2162 ss->data.info.data = tmp;
2164 tmp = gfc_conv_array_offset (se.expr);
2165 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2170 /* Initialize a gfc_loopinfo structure. */
2173 gfc_init_loopinfo (gfc_loopinfo * loop)
2177 memset (loop, 0, sizeof (gfc_loopinfo));
2178 gfc_init_block (&loop->pre);
2179 gfc_init_block (&loop->post);
2181 /* Initially scalarize in order. */
2182 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2185 loop->ss = gfc_ss_terminator;
2189 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2193 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2199 /* Return an expression for the data pointer of an array. */
2202 gfc_conv_array_data (tree descriptor)
2206 type = TREE_TYPE (descriptor);
2207 if (GFC_ARRAY_TYPE_P (type))
2209 if (TREE_CODE (type) == POINTER_TYPE)
2213 /* Descriptorless arrays. */
2214 return gfc_build_addr_expr (NULL_TREE, descriptor);
2218 return gfc_conv_descriptor_data_get (descriptor);
2222 /* Return an expression for the base offset of an array. */
2225 gfc_conv_array_offset (tree descriptor)
2229 type = TREE_TYPE (descriptor);
2230 if (GFC_ARRAY_TYPE_P (type))
2231 return GFC_TYPE_ARRAY_OFFSET (type);
2233 return gfc_conv_descriptor_offset_get (descriptor);
2237 /* Get an expression for the array stride. */
2240 gfc_conv_array_stride (tree descriptor, int dim)
2245 type = TREE_TYPE (descriptor);
2247 /* For descriptorless arrays use the array size. */
2248 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2249 if (tmp != NULL_TREE)
2252 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2257 /* Like gfc_conv_array_stride, but for the lower bound. */
2260 gfc_conv_array_lbound (tree descriptor, int dim)
2265 type = TREE_TYPE (descriptor);
2267 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2268 if (tmp != NULL_TREE)
2271 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2276 /* Like gfc_conv_array_stride, but for the upper bound. */
2279 gfc_conv_array_ubound (tree descriptor, int dim)
2284 type = TREE_TYPE (descriptor);
2286 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2287 if (tmp != NULL_TREE)
2290 /* This should only ever happen when passing an assumed shape array
2291 as an actual parameter. The value will never be used. */
2292 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2293 return gfc_index_zero_node;
2295 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2300 /* Generate code to perform an array index bound check. */
2303 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2304 locus * where, bool check_upper)
2307 tree tmp_lo, tmp_up;
2309 const char * name = NULL;
2311 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2314 index = gfc_evaluate_now (index, &se->pre);
2316 /* We find a name for the error message. */
2318 name = se->ss->expr->symtree->name;
2320 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2321 && se->loop->ss->expr->symtree)
2322 name = se->loop->ss->expr->symtree->name;
2324 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2325 && se->loop->ss->loop_chain->expr
2326 && se->loop->ss->loop_chain->expr->symtree)
2327 name = se->loop->ss->loop_chain->expr->symtree->name;
2329 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2331 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2332 && se->loop->ss->expr->value.function.name)
2333 name = se->loop->ss->expr->value.function.name;
2335 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2336 || se->loop->ss->type == GFC_SS_SCALAR)
2337 name = "unnamed constant";
2340 if (TREE_CODE (descriptor) == VAR_DECL)
2341 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2343 /* If upper bound is present, include both bounds in the error message. */
2346 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2347 tmp_up = gfc_conv_array_ubound (descriptor, n);
2350 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2351 "outside of expected range (%%ld:%%ld)", n+1, name);
2353 asprintf (&msg, "Index '%%ld' of dimension %d "
2354 "outside of expected range (%%ld:%%ld)", n+1);
2356 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2357 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2358 fold_convert (long_integer_type_node, index),
2359 fold_convert (long_integer_type_node, tmp_lo),
2360 fold_convert (long_integer_type_node, tmp_up));
2361 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2362 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2363 fold_convert (long_integer_type_node, index),
2364 fold_convert (long_integer_type_node, tmp_lo),
2365 fold_convert (long_integer_type_node, tmp_up));
2370 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2373 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2374 "below lower bound of %%ld", n+1, name);
2376 asprintf (&msg, "Index '%%ld' of dimension %d "
2377 "below lower bound of %%ld", n+1);
2379 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2380 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2381 fold_convert (long_integer_type_node, index),
2382 fold_convert (long_integer_type_node, tmp_lo));
2390 /* Return the offset for an index. Performs bound checking for elemental
2391 dimensions. Single element references are processed separately. */
2394 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2395 gfc_array_ref * ar, tree stride)
2401 /* Get the index into the array for this dimension. */
2404 gcc_assert (ar->type != AR_ELEMENT);
2405 switch (ar->dimen_type[dim])
2408 /* Elemental dimension. */
2409 gcc_assert (info->subscript[dim]
2410 && info->subscript[dim]->type == GFC_SS_SCALAR);
2411 /* We've already translated this value outside the loop. */
2412 index = info->subscript[dim]->data.scalar.expr;
2414 index = gfc_trans_array_bound_check (se, info->descriptor,
2415 index, dim, &ar->where,
2416 ar->as->type != AS_ASSUMED_SIZE
2417 || dim < ar->dimen - 1);
2421 gcc_assert (info && se->loop);
2422 gcc_assert (info->subscript[dim]
2423 && info->subscript[dim]->type == GFC_SS_VECTOR);
2424 desc = info->subscript[dim]->data.info.descriptor;
2426 /* Get a zero-based index into the vector. */
2427 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2428 se->loop->loopvar[i], se->loop->from[i]);
2430 /* Multiply the index by the stride. */
2431 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2432 index, gfc_conv_array_stride (desc, 0));
2434 /* Read the vector to get an index into info->descriptor. */
2435 data = build_fold_indirect_ref_loc (input_location,
2436 gfc_conv_array_data (desc));
2437 index = gfc_build_array_ref (data, index, NULL);
2438 index = gfc_evaluate_now (index, &se->pre);
2439 index = fold_convert (gfc_array_index_type, index);
2441 /* Do any bounds checking on the final info->descriptor index. */
2442 index = gfc_trans_array_bound_check (se, info->descriptor,
2443 index, dim, &ar->where,
2444 ar->as->type != AS_ASSUMED_SIZE
2445 || dim < ar->dimen - 1);
2449 /* Scalarized dimension. */
2450 gcc_assert (info && se->loop);
2452 /* Multiply the loop variable by the stride and delta. */
2453 index = se->loop->loopvar[i];
2454 if (!integer_onep (info->stride[i]))
2455 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2457 if (!integer_zerop (info->delta[i]))
2458 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2468 /* Temporary array or derived type component. */
2469 gcc_assert (se->loop);
2470 index = se->loop->loopvar[se->loop->order[i]];
2471 if (!integer_zerop (info->delta[i]))
2472 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2473 index, info->delta[i]);
2476 /* Multiply by the stride. */
2477 if (!integer_onep (stride))
2478 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2484 /* Build a scalarized reference to an array. */
2487 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2490 tree decl = NULL_TREE;
2495 info = &se->ss->data.info;
2497 n = se->loop->order[0];
2501 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2503 /* Add the offset for this dimension to the stored offset for all other
2505 if (!integer_zerop (info->offset))
2506 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2508 if (se->ss->expr && is_subref_array (se->ss->expr))
2509 decl = se->ss->expr->symtree->n.sym->backend_decl;
2511 tmp = build_fold_indirect_ref_loc (input_location,
2513 se->expr = gfc_build_array_ref (tmp, index, decl);
2517 /* Translate access of temporary array. */
2520 gfc_conv_tmp_array_ref (gfc_se * se)
2522 se->string_length = se->ss->string_length;
2523 gfc_conv_scalarized_array_ref (se, NULL);
2527 /* Build an array reference. se->expr already holds the array descriptor.
2528 This should be either a variable, indirect variable reference or component
2529 reference. For arrays which do not have a descriptor, se->expr will be
2531 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2534 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2547 /* Handle scalarized references separately. */
2548 if (ar->type != AR_ELEMENT)
2550 gfc_conv_scalarized_array_ref (se, ar);
2551 gfc_advance_se_ss_chain (se);
2555 index = gfc_index_zero_node;
2557 /* Calculate the offsets from all the dimensions. */
2558 for (n = 0; n < ar->dimen; n++)
2560 /* Calculate the index for this dimension. */
2561 gfc_init_se (&indexse, se);
2562 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2563 gfc_add_block_to_block (&se->pre, &indexse.pre);
2565 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2567 /* Check array bounds. */
2571 /* Evaluate the indexse.expr only once. */
2572 indexse.expr = save_expr (indexse.expr);
2575 tmp = gfc_conv_array_lbound (se->expr, n);
2576 if (sym->attr.temporary)
2578 gfc_init_se (&tmpse, se);
2579 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2580 gfc_array_index_type);
2581 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2585 cond = fold_build2 (LT_EXPR, boolean_type_node,
2587 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2588 "below lower bound of %%ld", n+1, sym->name);
2589 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2590 fold_convert (long_integer_type_node,
2592 fold_convert (long_integer_type_node, tmp));
2595 /* Upper bound, but not for the last dimension of assumed-size
2597 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2599 tmp = gfc_conv_array_ubound (se->expr, n);
2600 if (sym->attr.temporary)
2602 gfc_init_se (&tmpse, se);
2603 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2604 gfc_array_index_type);
2605 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2609 cond = fold_build2 (GT_EXPR, boolean_type_node,
2611 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2612 "above upper 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));
2621 /* Multiply the index by the stride. */
2622 stride = gfc_conv_array_stride (se->expr, n);
2623 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2626 /* And add it to the total. */
2627 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2630 tmp = gfc_conv_array_offset (se->expr);
2631 if (!integer_zerop (tmp))
2632 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2634 /* Access the calculated element. */
2635 tmp = gfc_conv_array_data (se->expr);
2636 tmp = build_fold_indirect_ref (tmp);
2637 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2641 /* Generate the code to be executed immediately before entering a
2642 scalarization loop. */
2645 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2646 stmtblock_t * pblock)
2655 /* This code will be executed before entering the scalarization loop
2656 for this dimension. */
2657 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2659 if ((ss->useflags & flag) == 0)
2662 if (ss->type != GFC_SS_SECTION
2663 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2664 && ss->type != GFC_SS_COMPONENT)
2667 info = &ss->data.info;
2669 if (dim >= info->dimen)
2672 if (dim == info->dimen - 1)
2674 /* For the outermost loop calculate the offset due to any
2675 elemental dimensions. It will have been initialized with the
2676 base offset of the array. */
2679 for (i = 0; i < info->ref->u.ar.dimen; i++)
2681 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2684 gfc_init_se (&se, NULL);
2686 se.expr = info->descriptor;
2687 stride = gfc_conv_array_stride (info->descriptor, i);
2688 index = gfc_conv_array_index_offset (&se, info, i, -1,
2691 gfc_add_block_to_block (pblock, &se.pre);
2693 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2694 info->offset, index);
2695 info->offset = gfc_evaluate_now (info->offset, pblock);
2699 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2702 stride = gfc_conv_array_stride (info->descriptor, 0);
2704 /* Calculate the stride of the innermost loop. Hopefully this will
2705 allow the backend optimizers to do their stuff more effectively.
2707 info->stride0 = gfc_evaluate_now (stride, pblock);
2711 /* Add the offset for the previous loop dimension. */
2716 ar = &info->ref->u.ar;
2717 i = loop->order[dim + 1];
2725 gfc_init_se (&se, NULL);
2727 se.expr = info->descriptor;
2728 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2729 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2731 gfc_add_block_to_block (pblock, &se.pre);
2732 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2733 info->offset, index);
2734 info->offset = gfc_evaluate_now (info->offset, pblock);
2737 /* Remember this offset for the second loop. */
2738 if (dim == loop->temp_dim - 1)
2739 info->saved_offset = info->offset;
2744 /* Start a scalarized expression. Creates a scope and declares loop
2748 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2754 gcc_assert (!loop->array_parameter);
2756 for (dim = loop->dimen - 1; dim >= 0; dim--)
2758 n = loop->order[dim];
2760 gfc_start_block (&loop->code[n]);
2762 /* Create the loop variable. */
2763 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2765 if (dim < loop->temp_dim)
2769 /* Calculate values that will be constant within this loop. */
2770 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2772 gfc_start_block (pbody);
2776 /* Generates the actual loop code for a scalarization loop. */
2779 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2780 stmtblock_t * pbody)
2791 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2792 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2793 && n == loop->dimen - 1)
2795 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2796 init = make_tree_vec (1);
2797 cond = make_tree_vec (1);
2798 incr = make_tree_vec (1);
2800 /* Cycle statement is implemented with a goto. Exit statement must not
2801 be present for this loop. */
2802 exit_label = gfc_build_label_decl (NULL_TREE);
2803 TREE_USED (exit_label) = 1;
2805 /* Label for cycle statements (if needed). */
2806 tmp = build1_v (LABEL_EXPR, exit_label);
2807 gfc_add_expr_to_block (pbody, tmp);
2809 stmt = make_node (OMP_FOR);
2811 TREE_TYPE (stmt) = void_type_node;
2812 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2814 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2815 OMP_CLAUSE_SCHEDULE);
2816 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2817 = OMP_CLAUSE_SCHEDULE_STATIC;
2818 if (ompws_flags & OMPWS_NOWAIT)
2819 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2820 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2822 /* Initialize the loopvar. */
2823 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2825 OMP_FOR_INIT (stmt) = init;
2826 /* The exit condition. */
2827 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2828 loop->loopvar[n], loop->to[n]);
2829 OMP_FOR_COND (stmt) = cond;
2830 /* Increment the loopvar. */
2831 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2832 loop->loopvar[n], gfc_index_one_node);
2833 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2834 void_type_node, loop->loopvar[n], tmp);
2835 OMP_FOR_INCR (stmt) = incr;
2837 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2838 gfc_add_expr_to_block (&loop->code[n], stmt);
2842 loopbody = gfc_finish_block (pbody);
2844 /* Initialize the loopvar. */
2845 if (loop->loopvar[n] != loop->from[n])
2846 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2848 exit_label = gfc_build_label_decl (NULL_TREE);
2850 /* Generate the loop body. */
2851 gfc_init_block (&block);
2853 /* The exit condition. */
2854 cond = fold_build2 (GT_EXPR, boolean_type_node,
2855 loop->loopvar[n], loop->to[n]);
2856 tmp = build1_v (GOTO_EXPR, exit_label);
2857 TREE_USED (exit_label) = 1;
2858 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2859 gfc_add_expr_to_block (&block, tmp);
2861 /* The main body. */
2862 gfc_add_expr_to_block (&block, loopbody);
2864 /* Increment the loopvar. */
2865 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2866 loop->loopvar[n], gfc_index_one_node);
2867 gfc_add_modify (&block, loop->loopvar[n], tmp);
2869 /* Build the loop. */
2870 tmp = gfc_finish_block (&block);
2871 tmp = build1_v (LOOP_EXPR, tmp);
2872 gfc_add_expr_to_block (&loop->code[n], tmp);
2874 /* Add the exit label. */
2875 tmp = build1_v (LABEL_EXPR, exit_label);
2876 gfc_add_expr_to_block (&loop->code[n], tmp);
2882 /* Finishes and generates the loops for a scalarized expression. */
2885 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2890 stmtblock_t *pblock;
2894 /* Generate the loops. */
2895 for (dim = 0; dim < loop->dimen; dim++)
2897 n = loop->order[dim];
2898 gfc_trans_scalarized_loop_end (loop, n, pblock);
2899 loop->loopvar[n] = NULL_TREE;
2900 pblock = &loop->code[n];
2903 tmp = gfc_finish_block (pblock);
2904 gfc_add_expr_to_block (&loop->pre, tmp);
2906 /* Clear all the used flags. */
2907 for (ss = loop->ss; ss; ss = ss->loop_chain)
2912 /* Finish the main body of a scalarized expression, and start the secondary
2916 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2920 stmtblock_t *pblock;
2924 /* We finish as many loops as are used by the temporary. */
2925 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2927 n = loop->order[dim];
2928 gfc_trans_scalarized_loop_end (loop, n, pblock);
2929 loop->loopvar[n] = NULL_TREE;
2930 pblock = &loop->code[n];
2933 /* We don't want to finish the outermost loop entirely. */
2934 n = loop->order[loop->temp_dim - 1];
2935 gfc_trans_scalarized_loop_end (loop, n, pblock);
2937 /* Restore the initial offsets. */
2938 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2940 if ((ss->useflags & 2) == 0)
2943 if (ss->type != GFC_SS_SECTION
2944 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2945 && ss->type != GFC_SS_COMPONENT)
2948 ss->data.info.offset = ss->data.info.saved_offset;
2951 /* Restart all the inner loops we just finished. */
2952 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2954 n = loop->order[dim];
2956 gfc_start_block (&loop->code[n]);
2958 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2960 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2963 /* Start a block for the secondary copying code. */
2964 gfc_start_block (body);
2968 /* Calculate the upper bound of an array section. */
2971 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2980 gcc_assert (ss->type == GFC_SS_SECTION);
2982 info = &ss->data.info;
2985 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2986 /* We'll calculate the upper bound once we have access to the
2987 vector's descriptor. */
2990 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2991 desc = info->descriptor;
2992 end = info->ref->u.ar.end[dim];
2996 /* The upper bound was specified. */
2997 gfc_init_se (&se, NULL);
2998 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2999 gfc_add_block_to_block (pblock, &se.pre);
3004 /* No upper bound was specified, so use the bound of the array. */
3005 bound = gfc_conv_array_ubound (desc, dim);
3012 /* Calculate the lower bound of an array section. */
3015 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3025 gcc_assert (ss->type == GFC_SS_SECTION);
3027 info = &ss->data.info;
3030 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3032 /* We use a zero-based index to access the vector. */
3033 info->start[n] = gfc_index_zero_node;
3034 info->end[n] = gfc_index_zero_node;
3035 info->stride[n] = gfc_index_one_node;
3039 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3040 desc = info->descriptor;
3041 start = info->ref->u.ar.start[dim];
3042 end = info->ref->u.ar.end[dim];
3043 stride = info->ref->u.ar.stride[dim];
3045 /* Calculate the start of the range. For vector subscripts this will
3046 be the range of the vector. */
3049 /* Specified section start. */
3050 gfc_init_se (&se, NULL);
3051 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3052 gfc_add_block_to_block (&loop->pre, &se.pre);
3053 info->start[n] = se.expr;
3057 /* No lower bound specified so use the bound of the array. */
3058 info->start[n] = gfc_conv_array_lbound (desc, dim);
3060 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3062 /* Similarly calculate the end. Although this is not used in the
3063 scalarizer, it is needed when checking bounds and where the end
3064 is an expression with side-effects. */
3067 /* Specified section start. */
3068 gfc_init_se (&se, NULL);
3069 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3070 gfc_add_block_to_block (&loop->pre, &se.pre);
3071 info->end[n] = se.expr;
3075 /* No upper bound specified so use the bound of the array. */
3076 info->end[n] = gfc_conv_array_ubound (desc, dim);
3078 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3080 /* Calculate the stride. */
3082 info->stride[n] = gfc_index_one_node;
3085 gfc_init_se (&se, NULL);
3086 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3087 gfc_add_block_to_block (&loop->pre, &se.pre);
3088 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3093 /* Calculates the range start and stride for a SS chain. Also gets the
3094 descriptor and data pointer. The range of vector subscripts is the size
3095 of the vector. Array bounds are also checked. */
3098 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3106 /* Determine the rank of the loop. */
3108 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3112 case GFC_SS_SECTION:
3113 case GFC_SS_CONSTRUCTOR:
3114 case GFC_SS_FUNCTION:
3115 case GFC_SS_COMPONENT:
3116 loop->dimen = ss->data.info.dimen;
3119 /* As usual, lbound and ubound are exceptions!. */
3120 case GFC_SS_INTRINSIC:
3121 switch (ss->expr->value.function.isym->id)
3123 case GFC_ISYM_LBOUND:
3124 case GFC_ISYM_UBOUND:
3125 loop->dimen = ss->data.info.dimen;
3136 /* We should have determined the rank of the expression by now. If
3137 not, that's bad news. */
3138 gcc_assert (loop->dimen != 0);
3140 /* Loop over all the SS in the chain. */
3141 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3143 if (ss->expr && ss->expr->shape && !ss->shape)
3144 ss->shape = ss->expr->shape;
3148 case GFC_SS_SECTION:
3149 /* Get the descriptor for the array. */
3150 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3152 for (n = 0; n < ss->data.info.dimen; n++)
3153 gfc_conv_section_startstride (loop, ss, n);
3156 case GFC_SS_INTRINSIC:
3157 switch (ss->expr->value.function.isym->id)
3159 /* Fall through to supply start and stride. */
3160 case GFC_ISYM_LBOUND:
3161 case GFC_ISYM_UBOUND:
3167 case GFC_SS_CONSTRUCTOR:
3168 case GFC_SS_FUNCTION:
3169 for (n = 0; n < ss->data.info.dimen; n++)
3171 ss->data.info.start[n] = gfc_index_zero_node;
3172 ss->data.info.end[n] = gfc_index_zero_node;
3173 ss->data.info.stride[n] = gfc_index_one_node;
3182 /* The rest is just runtime bound checking. */
3183 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3186 tree lbound, ubound;
3188 tree size[GFC_MAX_DIMENSIONS];
3189 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3194 gfc_start_block (&block);
3196 for (n = 0; n < loop->dimen; n++)
3197 size[n] = NULL_TREE;
3199 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3203 if (ss->type != GFC_SS_SECTION)
3206 gfc_start_block (&inner);
3208 /* TODO: range checking for mapped dimensions. */
3209 info = &ss->data.info;
3211 /* This code only checks ranges. Elemental and vector
3212 dimensions are checked later. */
3213 for (n = 0; n < loop->dimen; n++)
3218 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3221 if (dim == info->ref->u.ar.dimen - 1
3222 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3223 check_upper = false;
3227 /* Zero stride is not allowed. */
3228 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3229 gfc_index_zero_node);
3230 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3231 "of array '%s'", info->dim[n]+1,
3232 ss->expr->symtree->name);
3233 gfc_trans_runtime_check (true, false, tmp, &inner,
3234 &ss->expr->where, msg);
3237 desc = ss->data.info.descriptor;
3239 /* This is the run-time equivalent of resolve.c's
3240 check_dimension(). The logical is more readable there
3241 than it is here, with all the trees. */
3242 lbound = gfc_conv_array_lbound (desc, dim);
3245 ubound = gfc_conv_array_ubound (desc, dim);
3249 /* non_zerosized is true when the selected range is not
3251 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3252 info->stride[n], gfc_index_zero_node);
3253 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3255 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3258 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3259 info->stride[n], gfc_index_zero_node);
3260 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3262 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3264 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3265 stride_pos, stride_neg);
3267 /* Check the start of the range against the lower and upper
3268 bounds of the array, if the range is not empty.
3269 If upper bound is present, include both bounds in the
3273 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3274 info->start[n], lbound);
3275 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3276 non_zerosized, tmp);
3277 tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3278 info->start[n], ubound);
3279 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3280 non_zerosized, tmp2);
3281 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3282 "outside of expected range (%%ld:%%ld)",
3283 info->dim[n]+1, ss->expr->symtree->name);
3284 gfc_trans_runtime_check (true, false, tmp, &inner,
3285 &ss->expr->where, msg,
3286 fold_convert (long_integer_type_node, info->start[n]),
3287 fold_convert (long_integer_type_node, lbound),
3288 fold_convert (long_integer_type_node, ubound));
3289 gfc_trans_runtime_check (true, false, tmp2, &inner,
3290 &ss->expr->where, msg,
3291 fold_convert (long_integer_type_node, info->start[n]),
3292 fold_convert (long_integer_type_node, lbound),
3293 fold_convert (long_integer_type_node, ubound));
3298 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3299 info->start[n], lbound);
3300 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3301 non_zerosized, tmp);
3302 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3303 "below lower bound of %%ld",
3304 info->dim[n]+1, ss->expr->symtree->name);
3305 gfc_trans_runtime_check (true, false, tmp, &inner,
3306 &ss->expr->where, msg,
3307 fold_convert (long_integer_type_node, info->start[n]),
3308 fold_convert (long_integer_type_node, lbound));
3312 /* Compute the last element of the range, which is not
3313 necessarily "end" (think 0:5:3, which doesn't contain 5)
3314 and check it against both lower and upper bounds. */
3316 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3318 tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3320 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3322 tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3323 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3324 non_zerosized, tmp2);
3327 tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3328 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3329 non_zerosized, tmp3);
3330 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3331 "outside of expected range (%%ld:%%ld)",
3332 info->dim[n]+1, ss->expr->symtree->name);
3333 gfc_trans_runtime_check (true, false, tmp2, &inner,
3334 &ss->expr->where, msg,
3335 fold_convert (long_integer_type_node, tmp),
3336 fold_convert (long_integer_type_node, ubound),
3337 fold_convert (long_integer_type_node, lbound));
3338 gfc_trans_runtime_check (true, false, tmp3, &inner,
3339 &ss->expr->where, msg,
3340 fold_convert (long_integer_type_node, tmp),
3341 fold_convert (long_integer_type_node, ubound),
3342 fold_convert (long_integer_type_node, lbound));
3347 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3348 "below lower bound of %%ld",
3349 info->dim[n]+1, ss->expr->symtree->name);
3350 gfc_trans_runtime_check (true, false, tmp2, &inner,
3351 &ss->expr->where, msg,
3352 fold_convert (long_integer_type_node, tmp),
3353 fold_convert (long_integer_type_node, lbound));
3357 /* Check the section sizes match. */
3358 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3360 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3362 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3363 gfc_index_one_node, tmp);
3364 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3365 build_int_cst (gfc_array_index_type, 0));
3366 /* We remember the size of the first section, and check all the
3367 others against this. */
3370 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3371 asprintf (&msg, "Array bound mismatch for dimension %d "
3372 "of array '%s' (%%ld/%%ld)",
3373 info->dim[n]+1, ss->expr->symtree->name);
3375 gfc_trans_runtime_check (true, false, tmp3, &inner,
3376 &ss->expr->where, msg,
3377 fold_convert (long_integer_type_node, tmp),
3378 fold_convert (long_integer_type_node, size[n]));
3383 size[n] = gfc_evaluate_now (tmp, &inner);
3386 tmp = gfc_finish_block (&inner);
3388 /* For optional arguments, only check bounds if the argument is
3390 if (ss->expr->symtree->n.sym->attr.optional
3391 || ss->expr->symtree->n.sym->attr.not_always_present)
3392 tmp = build3_v (COND_EXPR,
3393 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3394 tmp, build_empty_stmt (input_location));
3396 gfc_add_expr_to_block (&block, tmp);
3400 tmp = gfc_finish_block (&block);
3401 gfc_add_expr_to_block (&loop->pre, tmp);
3406 /* Return true if the two SS could be aliased, i.e. both point to the same data
3408 /* TODO: resolve aliases based on frontend expressions. */
3411 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3418 lsym = lss->expr->symtree->n.sym;
3419 rsym = rss->expr->symtree->n.sym;
3420 if (gfc_symbols_could_alias (lsym, rsym))
3423 if (rsym->ts.type != BT_DERIVED
3424 && lsym->ts.type != BT_DERIVED)
3427 /* For derived types we must check all the component types. We can ignore
3428 array references as these will have the same base type as the previous
3430 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3432 if (lref->type != REF_COMPONENT)
3435 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3438 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3441 if (rref->type != REF_COMPONENT)
3444 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3449 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3451 if (rref->type != REF_COMPONENT)
3454 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3462 /* Resolve array data dependencies. Creates a temporary if required. */
3463 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3467 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3475 loop->temp_ss = NULL;
3477 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3479 if (ss->type != GFC_SS_SECTION)
3482 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3484 if (gfc_could_be_alias (dest, ss)
3485 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3493 lref = dest->expr->ref;
3494 rref = ss->expr->ref;
3496 nDepend = gfc_dep_resolver (lref, rref);
3500 /* TODO : loop shifting. */
3503 /* Mark the dimensions for LOOP SHIFTING */
3504 for (n = 0; n < loop->dimen; n++)
3506 int dim = dest->data.info.dim[n];
3508 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3510 else if (! gfc_is_same_range (&lref->u.ar,
3511 &rref->u.ar, dim, 0))
3515 /* Put all the dimensions with dependencies in the
3518 for (n = 0; n < loop->dimen; n++)
3520 gcc_assert (loop->order[n] == n);
3522 loop->order[dim++] = n;
3524 for (n = 0; n < loop->dimen; n++)
3527 loop->order[dim++] = n;
3530 gcc_assert (dim == loop->dimen);
3539 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3540 if (GFC_ARRAY_TYPE_P (base_type)
3541 || GFC_DESCRIPTOR_TYPE_P (base_type))
3542 base_type = gfc_get_element_type (base_type);
3543 loop->temp_ss = gfc_get_ss ();
3544 loop->temp_ss->type = GFC_SS_TEMP;
3545 loop->temp_ss->data.temp.type = base_type;
3546 loop->temp_ss->string_length = dest->string_length;
3547 loop->temp_ss->data.temp.dimen = loop->dimen;
3548 loop->temp_ss->next = gfc_ss_terminator;
3549 gfc_add_ss_to_loop (loop, loop->temp_ss);
3552 loop->temp_ss = NULL;
3556 /* Initialize the scalarization loop. Creates the loop variables. Determines
3557 the range of the loop variables. Creates a temporary if required.
3558 Calculates how to transform from loop variables to array indices for each
3559 expression. Also generates code for scalar expressions which have been
3560 moved outside the loop. */
3563 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3567 gfc_ss_info *specinfo;
3570 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3571 bool dynamic[GFC_MAX_DIMENSIONS];
3576 for (n = 0; n < loop->dimen; n++)
3580 /* We use one SS term, and use that to determine the bounds of the
3581 loop for this dimension. We try to pick the simplest term. */
3582 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3586 /* The frontend has worked out the size for us. */
3587 if (!loopspec[n] || !loopspec[n]->shape
3588 || !integer_zerop (loopspec[n]->data.info.start[n]))
3589 /* Prefer zero-based descriptors if possible. */
3594 if (ss->type == GFC_SS_CONSTRUCTOR)
3596 gfc_constructor_base base;
3597 /* An unknown size constructor will always be rank one.
3598 Higher rank constructors will either have known shape,
3599 or still be wrapped in a call to reshape. */
3600 gcc_assert (loop->dimen == 1);
3602 /* Always prefer to use the constructor bounds if the size
3603 can be determined at compile time. Prefer not to otherwise,
3604 since the general case involves realloc, and it's better to
3605 avoid that overhead if possible. */
3606 base = ss->expr->value.constructor;
3607 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3608 if (!dynamic[n] || !loopspec[n])
3613 /* TODO: Pick the best bound if we have a choice between a
3614 function and something else. */
3615 if (ss->type == GFC_SS_FUNCTION)
3621 if (ss->type != GFC_SS_SECTION)
3625 specinfo = &loopspec[n]->data.info;
3628 info = &ss->data.info;
3632 /* Criteria for choosing a loop specifier (most important first):
3633 doesn't need realloc
3639 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3641 else if (integer_onep (info->stride[n])
3642 && !integer_onep (specinfo->stride[n]))
3644 else if (INTEGER_CST_P (info->stride[n])
3645 && !INTEGER_CST_P (specinfo->stride[n]))
3647 else if (INTEGER_CST_P (info->start[n])
3648 && !INTEGER_CST_P (specinfo->start[n]))
3650 /* We don't work out the upper bound.
3651 else if (INTEGER_CST_P (info->finish[n])
3652 && ! INTEGER_CST_P (specinfo->finish[n]))
3653 loopspec[n] = ss; */
3656 /* We should have found the scalarization loop specifier. If not,
3658 gcc_assert (loopspec[n]);
3660 info = &loopspec[n]->data.info;
3662 /* Set the extents of this range. */
3663 cshape = loopspec[n]->shape;
3664 if (cshape && INTEGER_CST_P (info->start[n])
3665 && INTEGER_CST_P (info->stride[n]))
3667 loop->from[n] = info->start[n];
3668 mpz_set (i, cshape[n]);
3669 mpz_sub_ui (i, i, 1);
3670 /* To = from + (size - 1) * stride. */
3671 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3672 if (!integer_onep (info->stride[n]))
3673 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3674 tmp, info->stride[n]);
3675 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3676 loop->from[n], tmp);
3680 loop->from[n] = info->start[n];
3681 switch (loopspec[n]->type)
3683 case GFC_SS_CONSTRUCTOR:
3684 /* The upper bound is calculated when we expand the
3686 gcc_assert (loop->to[n] == NULL_TREE);
3689 case GFC_SS_SECTION:
3690 /* Use the end expression if it exists and is not constant,
3691 so that it is only evaluated once. */
3692 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3693 loop->to[n] = info->end[n];
3695 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3699 case GFC_SS_FUNCTION:
3700 /* The loop bound will be set when we generate the call. */
3701 gcc_assert (loop->to[n] == NULL_TREE);
3709 /* Transform everything so we have a simple incrementing variable. */
3710 if (integer_onep (info->stride[n]))
3711 info->delta[n] = gfc_index_zero_node;
3714 /* Set the delta for this section. */
3715 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3716 /* Number of iterations is (end - start + step) / step.
3717 with start = 0, this simplifies to
3719 for (i = 0; i<=last; i++){...}; */
3720 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3721 loop->to[n], loop->from[n]);
3722 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3723 tmp, info->stride[n]);
3724 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3725 build_int_cst (gfc_array_index_type, -1));
3726 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3727 /* Make the loop variable start at 0. */
3728 loop->from[n] = gfc_index_zero_node;
3732 /* Add all the scalar code that can be taken out of the loops.
3733 This may include calculating the loop bounds, so do it before
3734 allocating the temporary. */
3735 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3737 /* If we want a temporary then create it. */
3738 if (loop->temp_ss != NULL)
3740 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3742 /* Make absolutely sure that this is a complete type. */
3743 if (loop->temp_ss->string_length)
3744 loop->temp_ss->data.temp.type
3745 = gfc_get_character_type_len_for_eltype
3746 (TREE_TYPE (loop->temp_ss->data.temp.type),
3747 loop->temp_ss->string_length);
3749 tmp = loop->temp_ss->data.temp.type;
3750 n = loop->temp_ss->data.temp.dimen;
3751 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3752 loop->temp_ss->type = GFC_SS_SECTION;
3753 loop->temp_ss->data.info.dimen = n;
3754 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3755 &loop->temp_ss->data.info, tmp, NULL_TREE,
3756 false, true, false, where);
3759 for (n = 0; n < loop->temp_dim; n++)
3760 loopspec[loop->order[n]] = NULL;
3764 /* For array parameters we don't have loop variables, so don't calculate the
3766 if (loop->array_parameter)
3769 /* Calculate the translation from loop variables to array indices. */
3770 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3772 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3773 && ss->type != GFC_SS_CONSTRUCTOR)
3777 info = &ss->data.info;
3779 for (n = 0; n < info->dimen; n++)
3781 /* If we are specifying the range the delta is already set. */
3782 if (loopspec[n] != ss)
3784 /* Calculate the offset relative to the loop variable.
3785 First multiply by the stride. */
3786 tmp = loop->from[n];
3787 if (!integer_onep (info->stride[n]))
3788 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3789 tmp, info->stride[n]);
3791 /* Then subtract this from our starting value. */
3792 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3793 info->start[n], tmp);
3795 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3802 /* Fills in an array descriptor, and returns the size of the array. The size
3803 will be a simple_val, ie a variable or a constant. Also calculates the
3804 offset of the base. Returns the size of the array.
3808 for (n = 0; n < rank; n++)
3810 a.lbound[n] = specified_lower_bound;
3811 offset = offset + a.lbond[n] * stride;
3813 a.ubound[n] = specified_upper_bound;
3814 a.stride[n] = stride;
3815 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3816 stride = stride * size;
3823 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
3824 gfc_expr ** lower, gfc_expr ** upper,
3825 stmtblock_t * pblock)
3837 stmtblock_t thenblock;
3838 stmtblock_t elseblock;
3843 type = TREE_TYPE (descriptor);
3845 stride = gfc_index_one_node;
3846 offset = gfc_index_zero_node;
3848 /* Set the dtype. */
3849 tmp = gfc_conv_descriptor_dtype (descriptor);
3850 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3852 or_expr = NULL_TREE;
3854 for (n = 0; n < rank; n++)
3856 /* We have 3 possibilities for determining the size of the array:
3857 lower == NULL => lbound = 1, ubound = upper[n]
3858 upper[n] = NULL => lbound = 1, ubound = lower[n]
3859 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3862 /* Set lower bound. */
3863 gfc_init_se (&se, NULL);
3865 se.expr = gfc_index_one_node;
3868 gcc_assert (lower[n]);
3871 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3872 gfc_add_block_to_block (pblock, &se.pre);
3876 se.expr = gfc_index_one_node;
3880 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3883 /* Work out the offset for this component. */
3884 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3885 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3887 /* Start the calculation for the size of this dimension. */
3888 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3889 gfc_index_one_node, se.expr);
3891 /* Set upper bound. */
3892 gfc_init_se (&se, NULL);
3893 gcc_assert (ubound);
3894 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3895 gfc_add_block_to_block (pblock, &se.pre);
3897 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3899 /* Store the stride. */
3900 gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3902 /* Calculate the size of this dimension. */
3903 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3905 /* Check whether the size for this dimension is negative. */
3906 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3907 gfc_index_zero_node);
3911 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3913 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3914 gfc_index_zero_node, size);
3916 /* Multiply the stride by the number of elements in this dimension. */
3917 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3918 stride = gfc_evaluate_now (stride, pblock);
3921 for (n = rank; n < rank + corank; n++)
3925 /* Set lower bound. */
3926 gfc_init_se (&se, NULL);
3927 if (lower == NULL || lower[n] == NULL)
3929 gcc_assert (n == rank + corank - 1);
3930 se.expr = gfc_index_one_node;
3934 if (ubound || n == rank + corank - 1)
3936 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3937 gfc_add_block_to_block (pblock, &se.pre);
3941 se.expr = gfc_index_one_node;
3945 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3948 if (n < rank + corank - 1)
3950 gfc_init_se (&se, NULL);
3951 gcc_assert (ubound);
3952 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3953 gfc_add_block_to_block (pblock, &se.pre);
3954 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3958 /* The stride is the number of elements in the array, so multiply by the
3959 size of an element to get the total size. */
3960 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3961 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3962 fold_convert (gfc_array_index_type, tmp));
3964 if (poffset != NULL)
3966 offset = gfc_evaluate_now (offset, pblock);
3970 if (integer_zerop (or_expr))
3972 if (integer_onep (or_expr))
3973 return gfc_index_zero_node;
3975 var = gfc_create_var (TREE_TYPE (size), "size");
3976 gfc_start_block (&thenblock);
3977 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3978 thencase = gfc_finish_block (&thenblock);
3980 gfc_start_block (&elseblock);
3981 gfc_add_modify (&elseblock, var, size);
3982 elsecase = gfc_finish_block (&elseblock);
3984 tmp = gfc_evaluate_now (or_expr, pblock);
3985 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3986 gfc_add_expr_to_block (pblock, tmp);
3992 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3993 the work for an ALLOCATE statement. */
3997 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4005 gfc_ref *ref, *prev_ref = NULL;
4006 bool allocatable_array, coarray;
4010 /* Find the last reference in the chain. */
4011 while (ref && ref->next != NULL)
4013 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4014 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4019 if (ref == NULL || ref->type != REF_ARRAY)
4024 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4025 coarray = expr->symtree->n.sym->attr.codimension;
4029 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4030 coarray = prev_ref->u.c.component->attr.codimension;
4033 /* Return if this is a scalar coarray. */
4034 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4035 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4037 gcc_assert (coarray);
4041 /* Figure out the size of the array. */
4042 switch (ref->u.ar.type)
4048 upper = ref->u.ar.start;
4054 lower = ref->u.ar.start;
4055 upper = ref->u.ar.end;
4059 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4061 lower = ref->u.ar.as->lower;
4062 upper = ref->u.ar.as->upper;
4070 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4071 ref->u.ar.as->corank, &offset, lower, upper,
4074 /* Allocate memory to store the data. */
4075 pointer = gfc_conv_descriptor_data_get (se->expr);
4076 STRIP_NOPS (pointer);
4078 /* The allocate_array variants take the old pointer as first argument. */
4079 if (allocatable_array)
4080 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4082 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4083 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
4084 gfc_add_expr_to_block (&se->pre, tmp);
4086 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4088 if (expr->ts.type == BT_DERIVED
4089 && expr->ts.u.derived->attr.alloc_comp)
4091 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4092 ref->u.ar.as->rank);
4093 gfc_add_expr_to_block (&se->pre, tmp);
4100 /* Deallocate an array variable. Also used when an allocated variable goes
4105 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4111 gfc_start_block (&block);
4112 /* Get a pointer to the data. */
4113 var = gfc_conv_descriptor_data_get (descriptor);
4116 /* Parameter is the address of the data component. */
4117 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4118 gfc_add_expr_to_block (&block, tmp);
4120 /* Zero the data pointer. */
4121 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4122 var, build_int_cst (TREE_TYPE (var), 0));
4123 gfc_add_expr_to_block (&block, tmp);
4125 return gfc_finish_block (&block);
4129 /* Create an array constructor from an initialization expression.
4130 We assume the frontend already did any expansions and conversions. */
4133 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4139 unsigned HOST_WIDE_INT lo;
4141 VEC(constructor_elt,gc) *v = NULL;
4143 switch (expr->expr_type)
4146 case EXPR_STRUCTURE:
4147 /* A single scalar or derived type value. Create an array with all
4148 elements equal to that value. */
4149 gfc_init_se (&se, NULL);
4151 if (expr->expr_type == EXPR_CONSTANT)
4152 gfc_conv_constant (&se, expr);
4154 gfc_conv_structure (&se, expr, 1);
4156 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4157 gcc_assert (tmp && INTEGER_CST_P (tmp));
4158 hi = TREE_INT_CST_HIGH (tmp);
4159 lo = TREE_INT_CST_LOW (tmp);
4163 /* This will probably eat buckets of memory for large arrays. */
4164 while (hi != 0 || lo != 0)
4166 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4174 /* Create a vector of all the elements. */
4175 for (c = gfc_constructor_first (expr->value.constructor);
4176 c; c = gfc_constructor_next (c))
4180 /* Problems occur when we get something like
4181 integer :: a(lots) = (/(i, i=1, lots)/) */
4182 gfc_fatal_error ("The number of elements in the array constructor "
4183 "at %L requires an increase of the allowed %d "
4184 "upper limit. See -fmax-array-constructor "
4185 "option", &expr->where,
4186 gfc_option.flag_max_array_constructor);
4189 if (mpz_cmp_si (c->offset, 0) != 0)
4190 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4194 gfc_init_se (&se, NULL);
4195 switch (c->expr->expr_type)
4198 gfc_conv_constant (&se, c->expr);
4199 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4202 case EXPR_STRUCTURE:
4203 gfc_conv_structure (&se, c->expr, 1);
4204 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4209 /* Catch those occasional beasts that do not simplify
4210 for one reason or another, assuming that if they are
4211 standard defying the frontend will catch them. */
4212 gfc_conv_expr (&se, c->expr);
4213 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4220 return gfc_build_null_descriptor (type);
4226 /* Create a constructor from the list of elements. */
4227 tmp = build_constructor (type, v);
4228 TREE_CONSTANT (tmp) = 1;
4233 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4234 returns the size (in elements) of the array. */
4237 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4238 stmtblock_t * pblock)
4253 size = gfc_index_one_node;
4254 offset = gfc_index_zero_node;
4255 for (dim = 0; dim < as->rank; dim++)
4257 /* Evaluate non-constant array bound expressions. */
4258 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4259 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4261 gfc_init_se (&se, NULL);
4262 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4263 gfc_add_block_to_block (pblock, &se.pre);
4264 gfc_add_modify (pblock, lbound, se.expr);
4266 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4267 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4269 gfc_init_se (&se, NULL);
4270 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4271 gfc_add_block_to_block (pblock, &se.pre);
4272 gfc_add_modify (pblock, ubound, se.expr);
4274 /* The offset of this dimension. offset = offset - lbound * stride. */
4275 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4276 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4278 /* The size of this dimension, and the stride of the next. */
4279 if (dim + 1 < as->rank)
4280 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4282 stride = GFC_TYPE_ARRAY_SIZE (type);
4284 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4286 /* Calculate stride = size * (ubound + 1 - lbound). */
4287 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4288 gfc_index_one_node, lbound);
4289 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4290 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4292 gfc_add_modify (pblock, stride, tmp);
4294 stride = gfc_evaluate_now (tmp, pblock);
4296 /* Make sure that negative size arrays are translated
4297 to being zero size. */
4298 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4299 stride, gfc_index_zero_node);
4300 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4301 stride, gfc_index_zero_node);
4302 gfc_add_modify (pblock, stride, tmp);
4308 gfc_trans_vla_type_sizes (sym, pblock);
4315 /* Generate code to initialize/allocate an array variable. */
4318 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4327 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4329 /* Do nothing for USEd variables. */
4330 if (sym->attr.use_assoc)
4333 type = TREE_TYPE (decl);
4334 gcc_assert (GFC_ARRAY_TYPE_P (type));
4335 onstack = TREE_CODE (type) != POINTER_TYPE;
4337 gfc_start_block (&block);
4339 /* Evaluate character string length. */
4340 if (sym->ts.type == BT_CHARACTER
4341 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4343 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4345 gfc_trans_vla_type_sizes (sym, &block);
4347 /* Emit a DECL_EXPR for this variable, which will cause the
4348 gimplifier to allocate storage, and all that good stuff. */
4349 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4350 gfc_add_expr_to_block (&block, tmp);
4355 gfc_add_expr_to_block (&block, fnbody);
4356 return gfc_finish_block (&block);
4359 type = TREE_TYPE (type);
4361 gcc_assert (!sym->attr.use_assoc);
4362 gcc_assert (!TREE_STATIC (decl));
4363 gcc_assert (!sym->module);
4365 if (sym->ts.type == BT_CHARACTER
4366 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4367 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4369 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4371 /* Don't actually allocate space for Cray Pointees. */
4372 if (sym->attr.cray_pointee)
4374 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4375 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4376 gfc_add_expr_to_block (&block, fnbody);
4377 return gfc_finish_block (&block);
4380 /* The size is the number of elements in the array, so multiply by the
4381 size of an element to get the total size. */
4382 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4383 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4384 fold_convert (gfc_array_index_type, tmp));
4386 /* Allocate memory to hold the data. */
4387 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4388 gfc_add_modify (&block, decl, tmp);
4390 /* Set offset of the array. */
4391 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4392 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4395 /* Automatic arrays should not have initializers. */
4396 gcc_assert (!sym->value);
4398 gfc_add_expr_to_block (&block, fnbody);
4400 /* Free the temporary. */
4401 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4402 gfc_add_expr_to_block (&block, tmp);
4404 return gfc_finish_block (&block);
4408 /* Generate entry and exit code for g77 calling convention arrays. */
4411 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4421 gfc_get_backend_locus (&loc);
4422 gfc_set_backend_locus (&sym->declared_at);
4424 /* Descriptor type. */
4425 parm = sym->backend_decl;
4426 type = TREE_TYPE (parm);
4427 gcc_assert (GFC_ARRAY_TYPE_P (type));
4429 gfc_start_block (&block);
4431 if (sym->ts.type == BT_CHARACTER
4432 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4433 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4435 /* Evaluate the bounds of the array. */
4436 gfc_trans_array_bounds (type, sym, &offset, &block);
4438 /* Set the offset. */
4439 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4440 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4442 /* Set the pointer itself if we aren't using the parameter directly. */
4443 if (TREE_CODE (parm) != PARM_DECL)
4445 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4446 gfc_add_modify (&block, parm, tmp);
4448 stmt = gfc_finish_block (&block);
4450 gfc_set_backend_locus (&loc);
4452 gfc_start_block (&block);
4454 /* Add the initialization code to the start of the function. */
4456 if (sym->attr.optional || sym->attr.not_always_present)
4458 tmp = gfc_conv_expr_present (sym);
4459 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4462 gfc_add_expr_to_block (&block, stmt);
4463 gfc_add_expr_to_block (&block, body);
4465 return gfc_finish_block (&block);
4469 /* Modify the descriptor of an array parameter so that it has the
4470 correct lower bound. Also move the upper bound accordingly.
4471 If the array is not packed, it will be copied into a temporary.
4472 For each dimension we set the new lower and upper bounds. Then we copy the
4473 stride and calculate the offset for this dimension. We also work out
4474 what the stride of a packed array would be, and see it the two match.
4475 If the array need repacking, we set the stride to the values we just
4476 calculated, recalculate the offset and copy the array data.
4477 Code is also added to copy the data back at the end of the function.
4481 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4488 stmtblock_t cleanup;
4496 tree stride, stride2;
4506 /* Do nothing for pointer and allocatable arrays. */
4507 if (sym->attr.pointer || sym->attr.allocatable)
4510 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4511 return gfc_trans_g77_array (sym, body);
4513 gfc_get_backend_locus (&loc);
4514 gfc_set_backend_locus (&sym->declared_at);
4516 /* Descriptor type. */
4517 type = TREE_TYPE (tmpdesc);
4518 gcc_assert (GFC_ARRAY_TYPE_P (type));
4519 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4520 dumdesc = build_fold_indirect_ref_loc (input_location,
4522 gfc_start_block (&block);
4524 if (sym->ts.type == BT_CHARACTER
4525 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4526 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4528 checkparm = (sym->as->type == AS_EXPLICIT
4529 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4531 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4532 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4534 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4536 /* For non-constant shape arrays we only check if the first dimension
4537 is contiguous. Repacking higher dimensions wouldn't gain us
4538 anything as we still don't know the array stride. */
4539 partial = gfc_create_var (boolean_type_node, "partial");
4540 TREE_USED (partial) = 1;
4541 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4542 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4543 gfc_add_modify (&block, partial, tmp);
4547 partial = NULL_TREE;
4550 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4551 here, however I think it does the right thing. */
4554 /* Set the first stride. */
4555 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4556 stride = gfc_evaluate_now (stride, &block);
4558 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4559 stride, gfc_index_zero_node);
4560 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4561 gfc_index_one_node, stride);
4562 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4563 gfc_add_modify (&block, stride, tmp);
4565 /* Allow the user to disable array repacking. */
4566 stmt_unpacked = NULL_TREE;
4570 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4571 /* A library call to repack the array if necessary. */
4572 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4573 stmt_unpacked = build_call_expr_loc (input_location,
4574 gfor_fndecl_in_pack, 1, tmp);
4576 stride = gfc_index_one_node;
4578 if (gfc_option.warn_array_temp)
4579 gfc_warning ("Creating array temporary at %L", &loc);
4582 /* This is for the case where the array data is used directly without
4583 calling the repack function. */
4584 if (no_repack || partial != NULL_TREE)
4585 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4587 stmt_packed = NULL_TREE;
4589 /* Assign the data pointer. */
4590 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4592 /* Don't repack unknown shape arrays when the first stride is 1. */
4593 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4594 partial, stmt_packed, stmt_unpacked);
4597 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4598 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4600 offset = gfc_index_zero_node;
4601 size = gfc_index_one_node;
4603 /* Evaluate the bounds of the array. */
4604 for (n = 0; n < sym->as->rank; n++)
4606 if (checkparm || !sym->as->upper[n])
4608 /* Get the bounds of the actual parameter. */
4609 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4610 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4614 dubound = NULL_TREE;
4615 dlbound = NULL_TREE;
4618 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4619 if (!INTEGER_CST_P (lbound))
4621 gfc_init_se (&se, NULL);
4622 gfc_conv_expr_type (&se, sym->as->lower[n],
4623 gfc_array_index_type);
4624 gfc_add_block_to_block (&block, &se.pre);
4625 gfc_add_modify (&block, lbound, se.expr);
4628 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4629 /* Set the desired upper bound. */
4630 if (sym->as->upper[n])
4632 /* We know what we want the upper bound to be. */
4633 if (!INTEGER_CST_P (ubound))
4635 gfc_init_se (&se, NULL);
4636 gfc_conv_expr_type (&se, sym->as->upper[n],
4637 gfc_array_index_type);
4638 gfc_add_block_to_block (&block, &se.pre);
4639 gfc_add_modify (&block, ubound, se.expr);
4642 /* Check the sizes match. */
4645 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4649 temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4651 temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4652 gfc_index_one_node, temp);
4654 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4656 stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4657 gfc_index_one_node, stride2);
4659 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
4660 asprintf (&msg, "Dimension %d of array '%s' has extent "
4661 "%%ld instead of %%ld", n+1, sym->name);
4663 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg,
4664 fold_convert (long_integer_type_node, temp),
4665 fold_convert (long_integer_type_node, stride2));
4672 /* For assumed shape arrays move the upper bound by the same amount
4673 as the lower bound. */
4674 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4676 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4677 gfc_add_modify (&block, ubound, tmp);
4679 /* The offset of this dimension. offset = offset - lbound * stride. */
4680 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4681 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4683 /* The size of this dimension, and the stride of the next. */
4684 if (n + 1 < sym->as->rank)
4686 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4688 if (no_repack || partial != NULL_TREE)
4691 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4694 /* Figure out the stride if not a known constant. */
4695 if (!INTEGER_CST_P (stride))
4698 stmt_packed = NULL_TREE;
4701 /* Calculate stride = size * (ubound + 1 - lbound). */
4702 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4703 gfc_index_one_node, lbound);
4704 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4706 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4711 /* Assign the stride. */
4712 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4713 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4714 stmt_unpacked, stmt_packed);
4716 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4717 gfc_add_modify (&block, stride, tmp);
4722 stride = GFC_TYPE_ARRAY_SIZE (type);
4724 if (stride && !INTEGER_CST_P (stride))
4726 /* Calculate size = stride * (ubound + 1 - lbound). */
4727 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4728 gfc_index_one_node, lbound);
4729 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4731 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4732 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4733 gfc_add_modify (&block, stride, tmp);
4738 /* Set the offset. */
4739 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4740 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4742 gfc_trans_vla_type_sizes (sym, &block);
4744 stmt = gfc_finish_block (&block);
4746 gfc_start_block (&block);
4748 /* Only do the entry/initialization code if the arg is present. */
4749 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4750 optional_arg = (sym->attr.optional
4751 || (sym->ns->proc_name->attr.entry_master
4752 && sym->attr.dummy));
4755 tmp = gfc_conv_expr_present (sym);
4756 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4758 gfc_add_expr_to_block (&block, stmt);
4760 /* Add the main function body. */
4761 gfc_add_expr_to_block (&block, body);
4766 gfc_start_block (&cleanup);
4768 if (sym->attr.intent != INTENT_IN)
4770 /* Copy the data back. */
4771 tmp = build_call_expr_loc (input_location,
4772 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4773 gfc_add_expr_to_block (&cleanup, tmp);
4776 /* Free the temporary. */
4777 tmp = gfc_call_free (tmpdesc);
4778 gfc_add_expr_to_block (&cleanup, tmp);
4780 stmt = gfc_finish_block (&cleanup);
4782 /* Only do the cleanup if the array was repacked. */
4783 tmp = build_fold_indirect_ref_loc (input_location,
4785 tmp = gfc_conv_descriptor_data_get (tmp);
4786 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4787 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4791 tmp = gfc_conv_expr_present (sym);
4792 stmt = build3_v (COND_EXPR, tmp, stmt,
4793 build_empty_stmt (input_location));
4795 gfc_add_expr_to_block (&block, stmt);
4797 /* We don't need to free any memory allocated by internal_pack as it will
4798 be freed at the end of the function by pop_context. */
4799 return gfc_finish_block (&block);
4803 /* Calculate the overall offset, including subreferences. */
4805 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4806 bool subref, gfc_expr *expr)
4816 /* If offset is NULL and this is not a subreferenced array, there is
4818 if (offset == NULL_TREE)
4821 offset = gfc_index_zero_node;
4826 tmp = gfc_conv_array_data (desc);
4827 tmp = build_fold_indirect_ref_loc (input_location,
4829 tmp = gfc_build_array_ref (tmp, offset, NULL);
4831 /* Offset the data pointer for pointer assignments from arrays with
4832 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4835 /* Go past the array reference. */
4836 for (ref = expr->ref; ref; ref = ref->next)
4837 if (ref->type == REF_ARRAY &&
4838 ref->u.ar.type != AR_ELEMENT)
4844 /* Calculate the offset for each subsequent subreference. */
4845 for (; ref; ref = ref->next)
4850 field = ref->u.c.component->backend_decl;
4851 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4852 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4853 tmp, field, NULL_TREE);
4857 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4858 gfc_init_se (&start, NULL);
4859 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4860 gfc_add_block_to_block (block, &start.pre);
4861 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4865 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4866 && ref->u.ar.type == AR_ELEMENT);
4868 /* TODO - Add bounds checking. */
4869 stride = gfc_index_one_node;
4870 index = gfc_index_zero_node;
4871 for (n = 0; n < ref->u.ar.dimen; n++)
4876 /* Update the index. */
4877 gfc_init_se (&start, NULL);
4878 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4879 itmp = gfc_evaluate_now (start.expr, block);
4880 gfc_init_se (&start, NULL);
4881 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4882 jtmp = gfc_evaluate_now (start.expr, block);
4883 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4884 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4885 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4886 index = gfc_evaluate_now (index, block);
4888 /* Update the stride. */
4889 gfc_init_se (&start, NULL);
4890 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4891 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4892 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4893 gfc_index_one_node, itmp);
4894 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4895 stride = gfc_evaluate_now (stride, block);
4898 /* Apply the index to obtain the array element. */
4899 tmp = gfc_build_array_ref (tmp, index, NULL);
4909 /* Set the target data pointer. */
4910 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4911 gfc_conv_descriptor_data_set (block, parm, offset);
4915 /* gfc_conv_expr_descriptor needs the string length an expression
4916 so that the size of the temporary can be obtained. This is done
4917 by adding up the string lengths of all the elements in the
4918 expression. Function with non-constant expressions have their
4919 string lengths mapped onto the actual arguments using the
4920 interface mapping machinery in trans-expr.c. */
4922 get_array_charlen (gfc_expr *expr, gfc_se *se)
4924 gfc_interface_mapping mapping;
4925 gfc_formal_arglist *formal;
4926 gfc_actual_arglist *arg;
4929 if (expr->ts.u.cl->length
4930 && gfc_is_constant_expr (expr->ts.u.cl->length))
4932 if (!expr->ts.u.cl->backend_decl)
4933 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4937 switch (expr->expr_type)
4940 get_array_charlen (expr->value.op.op1, se);
4942 /* For parentheses the expression ts.u.cl is identical. */
4943 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4946 expr->ts.u.cl->backend_decl =
4947 gfc_create_var (gfc_charlen_type_node, "sln");
4949 if (expr->value.op.op2)
4951 get_array_charlen (expr->value.op.op2, se);
4953 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4955 /* Add the string lengths and assign them to the expression
4956 string length backend declaration. */
4957 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4958 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4959 expr->value.op.op1->ts.u.cl->backend_decl,
4960 expr->value.op.op2->ts.u.cl->backend_decl));
4963 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4964 expr->value.op.op1->ts.u.cl->backend_decl);
4968 if (expr->value.function.esym == NULL
4969 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4971 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4975 /* Map expressions involving the dummy arguments onto the actual
4976 argument expressions. */
4977 gfc_init_interface_mapping (&mapping);
4978 formal = expr->symtree->n.sym->formal;
4979 arg = expr->value.function.actual;
4981 /* Set se = NULL in the calls to the interface mapping, to suppress any
4983 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4988 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4991 gfc_init_se (&tse, NULL);
4993 /* Build the expression for the character length and convert it. */
4994 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
4996 gfc_add_block_to_block (&se->pre, &tse.pre);
4997 gfc_add_block_to_block (&se->post, &tse.post);
4998 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4999 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
5000 build_int_cst (gfc_charlen_type_node, 0));
5001 expr->ts.u.cl->backend_decl = tse.expr;
5002 gfc_free_interface_mapping (&mapping);
5006 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5013 /* Convert an array for passing as an actual argument. Expressions and
5014 vector subscripts are evaluated and stored in a temporary, which is then
5015 passed. For whole arrays the descriptor is passed. For array sections
5016 a modified copy of the descriptor is passed, but using the original data.
5018 This function is also used for array pointer assignments, and there
5021 - se->want_pointer && !se->direct_byref
5022 EXPR is an actual argument. On exit, se->expr contains a
5023 pointer to the array descriptor.
5025 - !se->want_pointer && !se->direct_byref
5026 EXPR is an actual argument to an intrinsic function or the
5027 left-hand side of a pointer assignment. On exit, se->expr
5028 contains the descriptor for EXPR.
5030 - !se->want_pointer && se->direct_byref
5031 EXPR is the right-hand side of a pointer assignment and
5032 se->expr is the descriptor for the previously-evaluated
5033 left-hand side. The function creates an assignment from
5034 EXPR to se->expr. */
5037 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5050 bool subref_array_target = false;
5052 gcc_assert (ss != gfc_ss_terminator);
5054 /* Special case things we know we can pass easily. */
5055 switch (expr->expr_type)
5058 /* If we have a linear array section, we can pass it directly.
5059 Otherwise we need to copy it into a temporary. */
5061 /* Find the SS for the array section. */
5063 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5064 secss = secss->next;
5066 gcc_assert (secss != gfc_ss_terminator);
5067 info = &secss->data.info;
5069 /* Get the descriptor for the array. */
5070 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5071 desc = info->descriptor;
5073 subref_array_target = se->direct_byref && is_subref_array (expr);
5074 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5075 && !subref_array_target;
5079 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5081 /* Create a new descriptor if the array doesn't have one. */
5084 else if (info->ref->u.ar.type == AR_FULL)
5086 else if (se->direct_byref)
5089 full = gfc_full_array_ref_p (info->ref, NULL);
5093 if (se->direct_byref)
5095 /* Copy the descriptor for pointer assignments. */
5096 gfc_add_modify (&se->pre, se->expr, desc);
5098 /* Add any offsets from subreferences. */
5099 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5100 subref_array_target, expr);
5102 else if (se->want_pointer)
5104 /* We pass full arrays directly. This means that pointers and
5105 allocatable arrays should also work. */
5106 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5113 if (expr->ts.type == BT_CHARACTER)
5114 se->string_length = gfc_get_expr_charlen (expr);
5121 /* A transformational function return value will be a temporary
5122 array descriptor. We still need to go through the scalarizer
5123 to create the descriptor. Elemental functions ar handled as
5124 arbitrary expressions, i.e. copy to a temporary. */
5126 /* Look for the SS for this function. */
5127 while (secss != gfc_ss_terminator
5128 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5129 secss = secss->next;
5131 if (se->direct_byref)
5133 gcc_assert (secss != gfc_ss_terminator);
5135 /* For pointer assignments pass the descriptor directly. */
5137 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5138 gfc_conv_expr (se, expr);
5142 if (secss == gfc_ss_terminator)
5144 /* Elemental function. */
5146 if (expr->ts.type == BT_CHARACTER
5147 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5148 get_array_charlen (expr, se);
5154 /* Transformational function. */
5155 info = &secss->data.info;
5161 /* Constant array constructors don't need a temporary. */
5162 if (ss->type == GFC_SS_CONSTRUCTOR
5163 && expr->ts.type != BT_CHARACTER
5164 && gfc_constant_array_constructor_p (expr->value.constructor))
5167 info = &ss->data.info;
5179 /* Something complicated. Copy it into a temporary. */
5186 gfc_init_loopinfo (&loop);
5188 /* Associate the SS with the loop. */
5189 gfc_add_ss_to_loop (&loop, ss);
5191 /* Tell the scalarizer not to bother creating loop variables, etc. */
5193 loop.array_parameter = 1;
5195 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5196 gcc_assert (!se->direct_byref);
5198 /* Setup the scalarizing loops and bounds. */
5199 gfc_conv_ss_startstride (&loop);
5203 /* Tell the scalarizer to make a temporary. */
5204 loop.temp_ss = gfc_get_ss ();
5205 loop.temp_ss->type = GFC_SS_TEMP;
5206 loop.temp_ss->next = gfc_ss_terminator;
5208 if (expr->ts.type == BT_CHARACTER
5209 && !expr->ts.u.cl->backend_decl)
5210 get_array_charlen (expr, se);
5212 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5214 if (expr->ts.type == BT_CHARACTER)
5215 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5217 loop.temp_ss->string_length = NULL;
5219 se->string_length = loop.temp_ss->string_length;
5220 loop.temp_ss->data.temp.dimen = loop.dimen;
5221 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5224 gfc_conv_loop_setup (&loop, & expr->where);
5228 /* Copy into a temporary and pass that. We don't need to copy the data
5229 back because expressions and vector subscripts must be INTENT_IN. */
5230 /* TODO: Optimize passing function return values. */
5234 /* Start the copying loops. */
5235 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5236 gfc_mark_ss_chain_used (ss, 1);
5237 gfc_start_scalarized_body (&loop, &block);
5239 /* Copy each data element. */
5240 gfc_init_se (&lse, NULL);
5241 gfc_copy_loopinfo_to_se (&lse, &loop);
5242 gfc_init_se (&rse, NULL);
5243 gfc_copy_loopinfo_to_se (&rse, &loop);
5245 lse.ss = loop.temp_ss;
5248 gfc_conv_scalarized_array_ref (&lse, NULL);
5249 if (expr->ts.type == BT_CHARACTER)
5251 gfc_conv_expr (&rse, expr);
5252 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5253 rse.expr = build_fold_indirect_ref_loc (input_location,
5257 gfc_conv_expr_val (&rse, expr);
5259 gfc_add_block_to_block (&block, &rse.pre);
5260 gfc_add_block_to_block (&block, &lse.pre);
5262 lse.string_length = rse.string_length;
5263 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5264 expr->expr_type == EXPR_VARIABLE, true);
5265 gfc_add_expr_to_block (&block, tmp);
5267 /* Finish the copying loops. */
5268 gfc_trans_scalarizing_loops (&loop, &block);
5270 desc = loop.temp_ss->data.info.descriptor;
5272 gcc_assert (is_gimple_lvalue (desc));
5274 else if (expr->expr_type == EXPR_FUNCTION)
5276 desc = info->descriptor;
5277 se->string_length = ss->string_length;
5281 /* We pass sections without copying to a temporary. Make a new
5282 descriptor and point it at the section we want. The loop variable
5283 limits will be the limits of the section.
5284 A function may decide to repack the array to speed up access, but
5285 we're not bothered about that here. */
5294 /* Set the string_length for a character array. */
5295 if (expr->ts.type == BT_CHARACTER)
5296 se->string_length = gfc_get_expr_charlen (expr);
5298 desc = info->descriptor;
5299 gcc_assert (secss && secss != gfc_ss_terminator);
5300 if (se->direct_byref)
5302 /* For pointer assignments we fill in the destination. */
5304 parmtype = TREE_TYPE (parm);
5308 /* Otherwise make a new one. */
5309 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5310 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5311 loop.from, loop.to, 0,
5312 GFC_ARRAY_UNKNOWN, false);
5313 parm = gfc_create_var (parmtype, "parm");
5316 offset = gfc_index_zero_node;
5319 /* The following can be somewhat confusing. We have two
5320 descriptors, a new one and the original array.
5321 {parm, parmtype, dim} refer to the new one.
5322 {desc, type, n, secss, loop} refer to the original, which maybe
5323 a descriptorless array.
5324 The bounds of the scalarization are the bounds of the section.
5325 We don't have to worry about numeric overflows when calculating
5326 the offsets because all elements are within the array data. */
5328 /* Set the dtype. */
5329 tmp = gfc_conv_descriptor_dtype (parm);
5330 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5332 /* Set offset for assignments to pointer only to zero if it is not
5334 if (se->direct_byref
5335 && info->ref && info->ref->u.ar.type != AR_FULL)
5336 base = gfc_index_zero_node;
5337 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5338 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5342 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5343 for (n = 0; n < ndim; n++)
5345 stride = gfc_conv_array_stride (desc, n);
5347 /* Work out the offset. */
5349 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5351 gcc_assert (info->subscript[n]
5352 && info->subscript[n]->type == GFC_SS_SCALAR);
5353 start = info->subscript[n]->data.scalar.expr;
5357 /* Check we haven't somehow got out of sync. */
5358 gcc_assert (info->dim[dim] == n);
5360 /* Evaluate and remember the start of the section. */
5361 start = info->start[dim];
5362 stride = gfc_evaluate_now (stride, &loop.pre);
5365 tmp = gfc_conv_array_lbound (desc, n);
5366 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5368 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5369 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5372 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5374 /* For elemental dimensions, we only need the offset. */
5378 /* Vector subscripts need copying and are handled elsewhere. */
5380 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5382 /* Set the new lower bound. */
5383 from = loop.from[dim];
5386 /* If we have an array section or are assigning make sure that
5387 the lower bound is 1. References to the full
5388 array should otherwise keep the original bounds. */
5390 || info->ref->u.ar.type != AR_FULL)
5391 && !integer_onep (from))
5393 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5394 gfc_index_one_node, from);
5395 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5396 from = gfc_index_one_node;
5398 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5399 gfc_rank_cst[dim], from);
5401 /* Set the new upper bound. */
5402 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5403 gfc_rank_cst[dim], to);
5405 /* Multiply the stride by the section stride to get the
5407 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5408 stride, info->stride[dim]);
5410 if (se->direct_byref
5412 && info->ref->u.ar.type != AR_FULL)
5414 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5417 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5419 tmp = gfc_conv_array_lbound (desc, n);
5420 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5421 tmp, loop.from[dim]);
5422 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5423 tmp, gfc_conv_array_stride (desc, n));
5424 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5428 /* Store the new stride. */
5429 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5430 gfc_rank_cst[dim], stride);
5435 if (se->data_not_needed)
5436 gfc_conv_descriptor_data_set (&loop.pre, parm,
5437 gfc_index_zero_node);
5439 /* Point the data pointer at the 1st element in the section. */
5440 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5441 subref_array_target, expr);
5443 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5444 && !se->data_not_needed)
5446 /* Set the offset. */
5447 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5451 /* Only the callee knows what the correct offset it, so just set
5453 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5458 if (!se->direct_byref)
5460 /* Get a pointer to the new descriptor. */
5461 if (se->want_pointer)
5462 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5467 gfc_add_block_to_block (&se->pre, &loop.pre);
5468 gfc_add_block_to_block (&se->post, &loop.post);
5470 /* Cleanup the scalarizer. */
5471 gfc_cleanup_loop (&loop);
5474 /* Helper function for gfc_conv_array_parameter if array size needs to be
5478 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5481 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5482 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5483 else if (expr->rank > 1)
5484 *size = build_call_expr_loc (input_location,
5485 gfor_fndecl_size0, 1,
5486 gfc_build_addr_expr (NULL, desc));
5489 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5490 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5492 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5493 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5494 gfc_index_one_node);
5495 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5496 gfc_index_zero_node);
5498 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5499 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5500 fold_convert (gfc_array_index_type, elem));
5503 /* Convert an array for passing as an actual parameter. */
5504 /* TODO: Optimize passing g77 arrays. */
5507 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5508 const gfc_symbol *fsym, const char *proc_name,
5513 tree tmp = NULL_TREE;
5515 tree parent = DECL_CONTEXT (current_function_decl);
5516 bool full_array_var;
5517 bool this_array_result;
5520 bool array_constructor;
5521 bool good_allocatable;
5522 bool ultimate_ptr_comp;
5523 bool ultimate_alloc_comp;
5528 ultimate_ptr_comp = false;
5529 ultimate_alloc_comp = false;
5530 for (ref = expr->ref; ref; ref = ref->next)
5532 if (ref->next == NULL)
5535 if (ref->type == REF_COMPONENT)
5537 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5538 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5542 full_array_var = false;
5545 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5546 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5548 sym = full_array_var ? expr->symtree->n.sym : NULL;
5550 /* The symbol should have an array specification. */
5551 gcc_assert (!sym || sym->as || ref->u.ar.as);
5553 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5555 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5556 expr->ts.u.cl->backend_decl = tmp;
5557 se->string_length = tmp;
5560 /* Is this the result of the enclosing procedure? */
5561 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5562 if (this_array_result
5563 && (sym->backend_decl != current_function_decl)
5564 && (sym->backend_decl != parent))
5565 this_array_result = false;
5567 /* Passing address of the array if it is not pointer or assumed-shape. */
5568 if (full_array_var && g77 && !this_array_result)
5570 tmp = gfc_get_symbol_decl (sym);
5572 if (sym->ts.type == BT_CHARACTER)
5573 se->string_length = sym->ts.u.cl->backend_decl;
5575 if (sym->ts.type == BT_DERIVED)
5577 gfc_conv_expr_descriptor (se, expr, ss);
5578 se->expr = gfc_conv_array_data (se->expr);
5582 if (!sym->attr.pointer
5584 && sym->as->type != AS_ASSUMED_SHAPE
5585 && !sym->attr.allocatable)
5587 /* Some variables are declared directly, others are declared as
5588 pointers and allocated on the heap. */
5589 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5592 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5594 array_parameter_size (tmp, expr, size);
5598 if (sym->attr.allocatable)
5600 if (sym->attr.dummy || sym->attr.result)
5602 gfc_conv_expr_descriptor (se, expr, ss);
5606 array_parameter_size (tmp, expr, size);
5607 se->expr = gfc_conv_array_data (tmp);
5612 /* A convenient reduction in scope. */
5613 contiguous = g77 && !this_array_result && contiguous;
5615 /* There is no need to pack and unpack the array, if it is contiguous
5616 and not deferred or assumed shape. */
5617 no_pack = ((sym && sym->as
5618 && !sym->attr.pointer
5619 && sym->as->type != AS_DEFERRED
5620 && sym->as->type != AS_ASSUMED_SHAPE)
5622 (ref && ref->u.ar.as
5623 && ref->u.ar.as->type != AS_DEFERRED
5624 && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
5626 no_pack = contiguous && no_pack;
5628 /* Array constructors are always contiguous and do not need packing. */
5629 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5631 /* Same is true of contiguous sections from allocatable variables. */
5632 good_allocatable = contiguous
5634 && expr->symtree->n.sym->attr.allocatable;
5636 /* Or ultimate allocatable components. */
5637 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5639 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5641 gfc_conv_expr_descriptor (se, expr, ss);
5642 if (expr->ts.type == BT_CHARACTER)
5643 se->string_length = expr->ts.u.cl->backend_decl;
5645 array_parameter_size (se->expr, expr, size);
5646 se->expr = gfc_conv_array_data (se->expr);
5650 if (this_array_result)
5652 /* Result of the enclosing function. */
5653 gfc_conv_expr_descriptor (se, expr, ss);
5655 array_parameter_size (se->expr, expr, size);
5656 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5658 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5659 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5660 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5667 /* Every other type of array. */
5668 se->want_pointer = 1;
5669 gfc_conv_expr_descriptor (se, expr, ss);
5671 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5676 /* Deallocate the allocatable components of structures that are
5678 if (expr->ts.type == BT_DERIVED
5679 && expr->ts.u.derived->attr.alloc_comp
5680 && expr->expr_type != EXPR_VARIABLE)
5682 tmp = build_fold_indirect_ref_loc (input_location,
5684 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5685 gfc_add_expr_to_block (&se->post, tmp);
5691 /* Repack the array. */
5692 if (gfc_option.warn_array_temp)
5695 gfc_warning ("Creating array temporary at %L for argument '%s'",
5696 &expr->where, fsym->name);
5698 gfc_warning ("Creating array temporary at %L", &expr->where);
5701 ptr = build_call_expr_loc (input_location,
5702 gfor_fndecl_in_pack, 1, desc);
5704 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5706 tmp = gfc_conv_expr_present (sym);
5707 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5708 fold_convert (TREE_TYPE (se->expr), ptr),
5709 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5712 ptr = gfc_evaluate_now (ptr, &se->pre);
5716 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5720 if (fsym && proc_name)
5721 asprintf (&msg, "An array temporary was created for argument "
5722 "'%s' of procedure '%s'", fsym->name, proc_name);
5724 asprintf (&msg, "An array temporary was created");
5726 tmp = build_fold_indirect_ref_loc (input_location,
5728 tmp = gfc_conv_array_data (tmp);
5729 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5730 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5732 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5733 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5734 gfc_conv_expr_present (sym), tmp);
5736 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5741 gfc_start_block (&block);
5743 /* Copy the data back. */
5744 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5746 tmp = build_call_expr_loc (input_location,
5747 gfor_fndecl_in_unpack, 2, desc, ptr);
5748 gfc_add_expr_to_block (&block, tmp);
5751 /* Free the temporary. */
5752 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5753 gfc_add_expr_to_block (&block, tmp);
5755 stmt = gfc_finish_block (&block);
5757 gfc_init_block (&block);
5758 /* Only if it was repacked. This code needs to be executed before the
5759 loop cleanup code. */
5760 tmp = build_fold_indirect_ref_loc (input_location,
5762 tmp = gfc_conv_array_data (tmp);
5763 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5764 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5766 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5767 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5768 gfc_conv_expr_present (sym), tmp);
5770 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5772 gfc_add_expr_to_block (&block, tmp);
5773 gfc_add_block_to_block (&block, &se->post);
5775 gfc_init_block (&se->post);
5776 gfc_add_block_to_block (&se->post, &block);
5781 /* Generate code to deallocate an array, if it is allocated. */
5784 gfc_trans_dealloc_allocated (tree descriptor)
5790 gfc_start_block (&block);
5792 var = gfc_conv_descriptor_data_get (descriptor);
5795 /* Call array_deallocate with an int * present in the second argument.
5796 Although it is ignored here, it's presence ensures that arrays that
5797 are already deallocated are ignored. */
5798 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5799 gfc_add_expr_to_block (&block, tmp);
5801 /* Zero the data pointer. */
5802 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5803 var, build_int_cst (TREE_TYPE (var), 0));
5804 gfc_add_expr_to_block (&block, tmp);
5806 return gfc_finish_block (&block);
5810 /* This helper function calculates the size in words of a full array. */
5813 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5818 idx = gfc_rank_cst[rank - 1];
5819 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5820 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5821 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5822 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5823 tmp, gfc_index_one_node);
5824 tmp = gfc_evaluate_now (tmp, block);
5826 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5827 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5828 return gfc_evaluate_now (tmp, block);
5832 /* Allocate dest to the same size as src, and copy src -> dest.
5833 If no_malloc is set, only the copy is done. */
5836 duplicate_allocatable(tree dest, tree src, tree type, int rank,
5846 /* If the source is null, set the destination to null. Then,
5847 allocate memory to the destination. */
5848 gfc_init_block (&block);
5852 tmp = null_pointer_node;
5853 tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
5854 gfc_add_expr_to_block (&block, tmp);
5855 null_data = gfc_finish_block (&block);
5857 gfc_init_block (&block);
5858 size = TYPE_SIZE_UNIT (type);
5861 tmp = gfc_call_malloc (&block, type, size);
5862 tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
5863 fold_convert (type, tmp));
5864 gfc_add_expr_to_block (&block, tmp);
5867 tmp = built_in_decls[BUILT_IN_MEMCPY];
5868 tmp = build_call_expr_loc (input_location, tmp, 3,
5873 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5874 null_data = gfc_finish_block (&block);
5876 gfc_init_block (&block);
5877 nelems = get_full_array_size (&block, src, rank);
5878 tmp = fold_convert (gfc_array_index_type,
5879 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
5880 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5883 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
5884 tmp = gfc_call_malloc (&block, tmp, size);
5885 gfc_conv_descriptor_data_set (&block, dest, tmp);
5888 /* We know the temporary and the value will be the same length,
5889 so can use memcpy. */
5890 tmp = built_in_decls[BUILT_IN_MEMCPY];
5891 tmp = build_call_expr_loc (input_location,
5892 tmp, 3, gfc_conv_descriptor_data_get (dest),
5893 gfc_conv_descriptor_data_get (src), size);
5896 gfc_add_expr_to_block (&block, tmp);
5897 tmp = gfc_finish_block (&block);
5899 /* Null the destination if the source is null; otherwise do
5900 the allocate and copy. */
5904 null_cond = gfc_conv_descriptor_data_get (src);
5906 null_cond = convert (pvoid_type_node, null_cond);
5907 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5908 null_cond, null_pointer_node);
5909 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5913 /* Allocate dest to the same size as src, and copy data src -> dest. */
5916 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
5918 return duplicate_allocatable(dest, src, type, rank, false);
5922 /* Copy data src -> dest. */
5925 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
5927 return duplicate_allocatable(dest, src, type, rank, true);
5931 /* Recursively traverse an object of derived type, generating code to
5932 deallocate, nullify or copy allocatable components. This is the work horse
5933 function for the functions named in this enum. */
5935 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
5936 COPY_ONLY_ALLOC_COMP};
5939 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5940 tree dest, int rank, int purpose)
5944 stmtblock_t fnblock;
5945 stmtblock_t loopbody;
5955 tree null_cond = NULL_TREE;
5957 gfc_init_block (&fnblock);
5959 if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
5960 decl = build_fold_indirect_ref_loc (input_location,
5963 /* If this an array of derived types with allocatable components
5964 build a loop and recursively call this function. */
5965 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5966 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5968 tmp = gfc_conv_array_data (decl);
5969 var = build_fold_indirect_ref_loc (input_location,
5972 /* Get the number of elements - 1 and set the counter. */
5973 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5975 /* Use the descriptor for an allocatable array. Since this
5976 is a full array reference, we only need the descriptor
5977 information from dimension = rank. */
5978 tmp = get_full_array_size (&fnblock, decl, rank);
5979 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5980 tmp, gfc_index_one_node);
5982 null_cond = gfc_conv_descriptor_data_get (decl);
5983 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5984 build_int_cst (TREE_TYPE (null_cond), 0));
5988 /* Otherwise use the TYPE_DOMAIN information. */
5989 tmp = array_type_nelts (TREE_TYPE (decl));
5990 tmp = fold_convert (gfc_array_index_type, tmp);
5993 /* Remember that this is, in fact, the no. of elements - 1. */
5994 nelems = gfc_evaluate_now (tmp, &fnblock);
5995 index = gfc_create_var (gfc_array_index_type, "S");
5997 /* Build the body of the loop. */
5998 gfc_init_block (&loopbody);
6000 vref = gfc_build_array_ref (var, index, NULL);
6002 if (purpose == COPY_ALLOC_COMP)
6004 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6006 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
6007 gfc_add_expr_to_block (&fnblock, tmp);
6009 tmp = build_fold_indirect_ref_loc (input_location,
6010 gfc_conv_array_data (dest));
6011 dref = gfc_build_array_ref (tmp, index, NULL);
6012 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6014 else if (purpose == COPY_ONLY_ALLOC_COMP)
6016 tmp = build_fold_indirect_ref_loc (input_location,
6017 gfc_conv_array_data (dest));
6018 dref = gfc_build_array_ref (tmp, index, NULL);
6019 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6023 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6025 gfc_add_expr_to_block (&loopbody, tmp);
6027 /* Build the loop and return. */
6028 gfc_init_loopinfo (&loop);
6030 loop.from[0] = gfc_index_zero_node;
6031 loop.loopvar[0] = index;
6032 loop.to[0] = nelems;
6033 gfc_trans_scalarizing_loops (&loop, &loopbody);
6034 gfc_add_block_to_block (&fnblock, &loop.pre);
6036 tmp = gfc_finish_block (&fnblock);
6037 if (null_cond != NULL_TREE)
6038 tmp = build3_v (COND_EXPR, null_cond, tmp,
6039 build_empty_stmt (input_location));
6044 /* Otherwise, act on the components or recursively call self to
6045 act on a chain of components. */
6046 for (c = der_type->components; c; c = c->next)
6048 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6049 && c->ts.u.derived->attr.alloc_comp;
6050 cdecl = c->backend_decl;
6051 ctype = TREE_TYPE (cdecl);
6055 case DEALLOCATE_ALLOC_COMP:
6056 /* Do not deallocate the components of ultimate pointer
6058 if (cmp_has_alloc_comps && !c->attr.pointer)
6060 comp = fold_build3 (COMPONENT_REF, ctype,
6061 decl, cdecl, NULL_TREE);
6062 rank = c->as ? c->as->rank : 0;
6063 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6065 gfc_add_expr_to_block (&fnblock, tmp);
6068 if (c->attr.allocatable && c->attr.dimension)
6070 comp = fold_build3 (COMPONENT_REF, ctype,
6071 decl, cdecl, NULL_TREE);
6072 tmp = gfc_trans_dealloc_allocated (comp);
6073 gfc_add_expr_to_block (&fnblock, tmp);
6075 else if (c->attr.allocatable)
6077 /* Allocatable scalar components. */
6078 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6080 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6081 gfc_add_expr_to_block (&fnblock, tmp);
6083 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6084 build_int_cst (TREE_TYPE (comp), 0));
6085 gfc_add_expr_to_block (&fnblock, tmp);
6087 else if (c->ts.type == BT_CLASS
6088 && c->ts.u.derived->components->attr.allocatable)
6090 /* Allocatable scalar CLASS components. */
6091 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6093 /* Add reference to '$data' component. */
6094 tmp = c->ts.u.derived->components->backend_decl;
6095 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6096 comp, tmp, NULL_TREE);
6098 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6099 gfc_add_expr_to_block (&fnblock, tmp);
6101 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6102 build_int_cst (TREE_TYPE (comp), 0));
6103 gfc_add_expr_to_block (&fnblock, tmp);
6107 case NULLIFY_ALLOC_COMP:
6108 if (c->attr.pointer)
6110 else if (c->attr.allocatable && c->attr.dimension)
6112 comp = fold_build3 (COMPONENT_REF, ctype,
6113 decl, cdecl, NULL_TREE);
6114 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6116 else if (c->attr.allocatable)
6118 /* Allocatable scalar components. */
6119 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6120 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6121 build_int_cst (TREE_TYPE (comp), 0));
6122 gfc_add_expr_to_block (&fnblock, tmp);
6124 else if (c->ts.type == BT_CLASS
6125 && c->ts.u.derived->components->attr.allocatable)
6127 /* Allocatable scalar CLASS components. */
6128 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6129 /* Add reference to '$data' component. */
6130 tmp = c->ts.u.derived->components->backend_decl;
6131 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6132 comp, tmp, NULL_TREE);
6133 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6134 build_int_cst (TREE_TYPE (comp), 0));
6135 gfc_add_expr_to_block (&fnblock, tmp);
6137 else if (cmp_has_alloc_comps)
6139 comp = fold_build3 (COMPONENT_REF, ctype,
6140 decl, cdecl, NULL_TREE);
6141 rank = c->as ? c->as->rank : 0;
6142 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6144 gfc_add_expr_to_block (&fnblock, tmp);
6148 case COPY_ALLOC_COMP:
6149 if (c->attr.pointer)
6152 /* We need source and destination components. */
6153 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6154 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
6155 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6157 if (c->attr.allocatable && !cmp_has_alloc_comps)
6159 rank = c->as ? c->as->rank : 0;
6160 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
6161 gfc_add_expr_to_block (&fnblock, tmp);
6164 if (cmp_has_alloc_comps)
6166 rank = c->as ? c->as->rank : 0;
6167 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6168 gfc_add_modify (&fnblock, dcmp, tmp);
6169 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6171 gfc_add_expr_to_block (&fnblock, tmp);
6181 return gfc_finish_block (&fnblock);
6184 /* Recursively traverse an object of derived type, generating code to
6185 nullify allocatable components. */
6188 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6190 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6191 NULLIFY_ALLOC_COMP);
6195 /* Recursively traverse an object of derived type, generating code to
6196 deallocate allocatable components. */
6199 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6201 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6202 DEALLOCATE_ALLOC_COMP);
6206 /* Recursively traverse an object of derived type, generating code to
6207 copy it and its allocatable components. */
6210 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6212 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6216 /* Recursively traverse an object of derived type, generating code to
6217 copy only its allocatable components. */
6220 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6222 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6226 /* Check for default initializer; sym->value is not enough as it is also
6227 set for EXPR_NULL of allocatables. */
6230 has_default_initializer (gfc_symbol *der)
6234 gcc_assert (der->attr.flavor == FL_DERIVED);
6235 for (c = der->components; c; c = c->next)
6236 if ((c->ts.type != BT_DERIVED && c->initializer)
6237 || (c->ts.type == BT_DERIVED
6238 && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
6245 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6246 Do likewise, recursively if necessary, with the allocatable components of
6250 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
6255 stmtblock_t fnblock;
6258 bool sym_has_alloc_comp;
6260 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6261 && sym->ts.u.derived->attr.alloc_comp;
6263 /* Make sure the frontend gets these right. */
6264 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6265 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6266 "allocatable attribute or derived type without allocatable "
6269 gfc_init_block (&fnblock);
6271 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6272 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6274 if (sym->ts.type == BT_CHARACTER
6275 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6277 gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
6278 gfc_trans_vla_type_sizes (sym, &fnblock);
6281 /* Dummy, use associated and result variables don't need anything special. */
6282 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6284 gfc_add_expr_to_block (&fnblock, body);
6286 return gfc_finish_block (&fnblock);
6289 gfc_get_backend_locus (&loc);
6290 gfc_set_backend_locus (&sym->declared_at);
6291 descriptor = sym->backend_decl;
6293 /* Although static, derived types with default initializers and
6294 allocatable components must not be nulled wholesale; instead they
6295 are treated component by component. */
6296 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6298 /* SAVEd variables are not freed on exit. */
6299 gfc_trans_static_array_pointer (sym);
6303 /* Get the descriptor type. */
6304 type = TREE_TYPE (sym->backend_decl);
6306 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6309 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6311 if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived))
6313 rank = sym->as ? sym->as->rank : 0;
6314 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
6315 gfc_add_expr_to_block (&fnblock, tmp);
6319 tmp = gfc_init_default_dt (sym, NULL, false);
6320 gfc_add_expr_to_block (&fnblock, tmp);
6324 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6326 /* If the backend_decl is not a descriptor, we must have a pointer
6328 descriptor = build_fold_indirect_ref_loc (input_location,
6330 type = TREE_TYPE (descriptor);
6333 /* NULLIFY the data pointer. */
6334 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6335 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
6337 gfc_add_expr_to_block (&fnblock, body);
6339 gfc_set_backend_locus (&loc);
6341 /* Allocatable arrays need to be freed when they go out of scope.
6342 The allocatable components of pointers must not be touched. */
6343 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6344 && !sym->attr.pointer && !sym->attr.save)
6347 rank = sym->as ? sym->as->rank : 0;
6348 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6349 gfc_add_expr_to_block (&fnblock, tmp);
6352 if (sym->attr.allocatable && sym->attr.dimension
6353 && !sym->attr.save && !sym->attr.result)
6355 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6356 gfc_add_expr_to_block (&fnblock, tmp);
6359 return gfc_finish_block (&fnblock);
6362 /************ Expression Walking Functions ******************/
6364 /* Walk a variable reference.
6366 Possible extension - multiple component subscripts.
6367 x(:,:) = foo%a(:)%b(:)
6369 forall (i=..., j=...)
6370 x(i,j) = foo%a(j)%b(i)
6372 This adds a fair amount of complexity because you need to deal with more
6373 than one ref. Maybe handle in a similar manner to vector subscripts.
6374 Maybe not worth the effort. */
6378 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6385 for (ref = expr->ref; ref; ref = ref->next)
6386 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6389 for (; ref; ref = ref->next)
6391 if (ref->type == REF_SUBSTRING)
6393 newss = gfc_get_ss ();
6394 newss->type = GFC_SS_SCALAR;
6395 newss->expr = ref->u.ss.start;
6399 newss = gfc_get_ss ();
6400 newss->type = GFC_SS_SCALAR;
6401 newss->expr = ref->u.ss.end;
6406 /* We're only interested in array sections from now on. */
6407 if (ref->type != REF_ARRAY)
6412 if (ar->as->rank == 0)
6414 /* Scalar coarray. */
6421 for (n = 0; n < ar->dimen; n++)
6423 newss = gfc_get_ss ();
6424 newss->type = GFC_SS_SCALAR;
6425 newss->expr = ar->start[n];
6432 newss = gfc_get_ss ();
6433 newss->type = GFC_SS_SECTION;
6436 newss->data.info.dimen = ar->as->rank;
6437 newss->data.info.ref = ref;
6439 /* Make sure array is the same as array(:,:), this way
6440 we don't need to special case all the time. */
6441 ar->dimen = ar->as->rank;
6442 for (n = 0; n < ar->dimen; n++)
6444 newss->data.info.dim[n] = n;
6445 ar->dimen_type[n] = DIMEN_RANGE;
6447 gcc_assert (ar->start[n] == NULL);
6448 gcc_assert (ar->end[n] == NULL);
6449 gcc_assert (ar->stride[n] == NULL);
6455 newss = gfc_get_ss ();
6456 newss->type = GFC_SS_SECTION;
6459 newss->data.info.dimen = 0;
6460 newss->data.info.ref = ref;
6462 /* We add SS chains for all the subscripts in the section. */
6463 for (n = 0; n < ar->dimen; n++)
6467 switch (ar->dimen_type[n])
6470 /* Add SS for elemental (scalar) subscripts. */
6471 gcc_assert (ar->start[n]);
6472 indexss = gfc_get_ss ();
6473 indexss->type = GFC_SS_SCALAR;
6474 indexss->expr = ar->start[n];
6475 indexss->next = gfc_ss_terminator;
6476 indexss->loop_chain = gfc_ss_terminator;
6477 newss->data.info.subscript[n] = indexss;
6481 /* We don't add anything for sections, just remember this
6482 dimension for later. */
6483 newss->data.info.dim[newss->data.info.dimen] = n;
6484 newss->data.info.dimen++;
6488 /* Create a GFC_SS_VECTOR index in which we can store
6489 the vector's descriptor. */
6490 indexss = gfc_get_ss ();
6491 indexss->type = GFC_SS_VECTOR;
6492 indexss->expr = ar->start[n];
6493 indexss->next = gfc_ss_terminator;
6494 indexss->loop_chain = gfc_ss_terminator;
6495 newss->data.info.subscript[n] = indexss;
6496 newss->data.info.dim[newss->data.info.dimen] = n;
6497 newss->data.info.dimen++;
6501 /* We should know what sort of section it is by now. */
6505 /* We should have at least one non-elemental dimension. */
6506 gcc_assert (newss->data.info.dimen > 0);
6511 /* We should know what sort of section it is by now. */
6520 /* Walk an expression operator. If only one operand of a binary expression is
6521 scalar, we must also add the scalar term to the SS chain. */
6524 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6530 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6531 if (expr->value.op.op2 == NULL)
6534 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6536 /* All operands are scalar. Pass back and let the caller deal with it. */
6540 /* All operands require scalarization. */
6541 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6544 /* One of the operands needs scalarization, the other is scalar.
6545 Create a gfc_ss for the scalar expression. */
6546 newss = gfc_get_ss ();
6547 newss->type = GFC_SS_SCALAR;
6550 /* First operand is scalar. We build the chain in reverse order, so
6551 add the scalar SS after the second operand. */
6553 while (head && head->next != ss)
6555 /* Check we haven't somehow broken the chain. */
6559 newss->expr = expr->value.op.op1;
6561 else /* head2 == head */
6563 gcc_assert (head2 == head);
6564 /* Second operand is scalar. */
6565 newss->next = head2;
6567 newss->expr = expr->value.op.op2;
6574 /* Reverse a SS chain. */
6577 gfc_reverse_ss (gfc_ss * ss)
6582 gcc_assert (ss != NULL);
6584 head = gfc_ss_terminator;
6585 while (ss != gfc_ss_terminator)
6588 /* Check we didn't somehow break the chain. */
6589 gcc_assert (next != NULL);
6599 /* Walk the arguments of an elemental function. */
6602 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6610 head = gfc_ss_terminator;
6613 for (; arg; arg = arg->next)
6618 newss = gfc_walk_subexpr (head, arg->expr);
6621 /* Scalar argument. */
6622 newss = gfc_get_ss ();
6624 newss->expr = arg->expr;
6634 while (tail->next != gfc_ss_terminator)
6641 /* If all the arguments are scalar we don't need the argument SS. */
6642 gfc_free_ss_chain (head);
6647 /* Add it onto the existing chain. */
6653 /* Walk a function call. Scalar functions are passed back, and taken out of
6654 scalarization loops. For elemental functions we walk their arguments.
6655 The result of functions returning arrays is stored in a temporary outside
6656 the loop, so that the function is only called once. Hence we do not need
6657 to walk their arguments. */
6660 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6663 gfc_intrinsic_sym *isym;
6665 gfc_component *comp = NULL;
6667 isym = expr->value.function.isym;
6669 /* Handle intrinsic functions separately. */
6671 return gfc_walk_intrinsic_function (ss, expr, isym);
6673 sym = expr->value.function.esym;
6675 sym = expr->symtree->n.sym;
6677 /* A function that returns arrays. */
6678 gfc_is_proc_ptr_comp (expr, &comp);
6679 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6680 || (comp && comp->attr.dimension))
6682 newss = gfc_get_ss ();
6683 newss->type = GFC_SS_FUNCTION;
6686 newss->data.info.dimen = expr->rank;
6690 /* Walk the parameters of an elemental function. For now we always pass
6692 if (sym->attr.elemental)
6693 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6696 /* Scalar functions are OK as these are evaluated outside the scalarization
6697 loop. Pass back and let the caller deal with it. */
6702 /* An array temporary is constructed for array constructors. */
6705 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6710 newss = gfc_get_ss ();
6711 newss->type = GFC_SS_CONSTRUCTOR;
6714 newss->data.info.dimen = expr->rank;
6715 for (n = 0; n < expr->rank; n++)
6716 newss->data.info.dim[n] = n;
6722 /* Walk an expression. Add walked expressions to the head of the SS chain.
6723 A wholly scalar expression will not be added. */
6726 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6730 switch (expr->expr_type)
6733 head = gfc_walk_variable_expr (ss, expr);
6737 head = gfc_walk_op_expr (ss, expr);
6741 head = gfc_walk_function_expr (ss, expr);
6746 case EXPR_STRUCTURE:
6747 /* Pass back and let the caller deal with it. */
6751 head = gfc_walk_array_constructor (ss, expr);
6754 case EXPR_SUBSTRING:
6755 /* Pass back and let the caller deal with it. */
6759 internal_error ("bad expression type during walk (%d)",
6766 /* Entry point for expression walking.
6767 A return value equal to the passed chain means this is
6768 a scalar expression. It is up to the caller to take whatever action is
6769 necessary to translate these. */
6772 gfc_walk_expr (gfc_expr * expr)
6776 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6777 return gfc_reverse_ss (res);