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. */
1687 c = gfc_constructor_first (expr->value.constructor);
1690 gfc_init_se (&se, NULL);
1691 gfc_conv_constant (&se, c->expr);
1692 if (c->expr->ts.type != BT_CHARACTER)
1693 se.expr = fold_convert (type, se.expr);
1694 else if (POINTER_TYPE_P (type))
1695 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1697 list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1699 c = gfc_constructor_next (c);
1703 /* Next determine the tree type for the array. We use the gfortran
1704 front-end's gfc_get_nodesc_array_type in order to create a suitable
1705 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1707 memset (&as, 0, sizeof (gfc_array_spec));
1709 as.rank = expr->rank;
1710 as.type = AS_EXPLICIT;
1713 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1714 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1718 for (i = 0; i < expr->rank; i++)
1720 int tmp = (int) mpz_get_si (expr->shape[i]);
1721 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1722 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1726 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1728 init = build_constructor (tmptype, v);
1730 TREE_CONSTANT (init) = 1;
1731 TREE_STATIC (init) = 1;
1733 tmp = gfc_create_var (tmptype, "A");
1734 TREE_STATIC (tmp) = 1;
1735 TREE_CONSTANT (tmp) = 1;
1736 TREE_READONLY (tmp) = 1;
1737 DECL_INITIAL (tmp) = init;
1743 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1744 This mostly initializes the scalarizer state info structure with the
1745 appropriate values to directly use the array created by the function
1746 gfc_build_constant_array_constructor. */
1749 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1750 gfc_ss * ss, tree type)
1756 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1758 info = &ss->data.info;
1760 info->descriptor = tmp;
1761 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1762 info->offset = gfc_index_zero_node;
1764 for (i = 0; i < info->dimen; i++)
1766 info->delta[i] = gfc_index_zero_node;
1767 info->start[i] = gfc_index_zero_node;
1768 info->end[i] = gfc_index_zero_node;
1769 info->stride[i] = gfc_index_one_node;
1773 if (info->dimen > loop->temp_dim)
1774 loop->temp_dim = info->dimen;
1777 /* Helper routine of gfc_trans_array_constructor to determine if the
1778 bounds of the loop specified by LOOP are constant and simple enough
1779 to use with gfc_trans_constant_array_constructor. Returns the
1780 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1783 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1785 tree size = gfc_index_one_node;
1789 for (i = 0; i < loop->dimen; i++)
1791 /* If the bounds aren't constant, return NULL_TREE. */
1792 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1794 if (!integer_zerop (loop->from[i]))
1796 /* Only allow nonzero "from" in one-dimensional arrays. */
1797 if (loop->dimen != 1)
1799 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1800 loop->to[i], loop->from[i]);
1804 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1805 tmp, gfc_index_one_node);
1806 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1813 /* Array constructors are handled by constructing a temporary, then using that
1814 within the scalarization loop. This is not optimal, but seems by far the
1818 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1820 gfc_constructor_base c;
1826 bool old_first_len, old_typespec_chararray_ctor;
1827 tree old_first_len_val;
1829 /* Save the old values for nested checking. */
1830 old_first_len = first_len;
1831 old_first_len_val = first_len_val;
1832 old_typespec_chararray_ctor = typespec_chararray_ctor;
1834 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1835 typespec was given for the array constructor. */
1836 typespec_chararray_ctor = (ss->expr->ts.u.cl
1837 && ss->expr->ts.u.cl->length_from_typespec);
1839 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1840 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1842 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1846 ss->data.info.dimen = loop->dimen;
1848 c = ss->expr->value.constructor;
1849 if (ss->expr->ts.type == BT_CHARACTER)
1853 /* get_array_ctor_strlen walks the elements of the constructor, if a
1854 typespec was given, we already know the string length and want the one
1856 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1857 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1861 const_string = false;
1862 gfc_init_se (&length_se, NULL);
1863 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1864 gfc_charlen_type_node);
1865 ss->string_length = length_se.expr;
1866 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1867 gfc_add_block_to_block (&loop->post, &length_se.post);
1870 const_string = get_array_ctor_strlen (&loop->pre, c,
1871 &ss->string_length);
1873 /* Complex character array constructors should have been taken care of
1874 and not end up here. */
1875 gcc_assert (ss->string_length);
1877 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1879 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1881 type = build_pointer_type (type);
1884 type = gfc_typenode_for_spec (&ss->expr->ts);
1886 /* See if the constructor determines the loop bounds. */
1889 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1891 /* We have a multidimensional parameter. */
1893 for (n = 0; n < ss->expr->rank; n++)
1895 loop->from[n] = gfc_index_zero_node;
1896 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1897 gfc_index_integer_kind);
1898 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1899 loop->to[n], gfc_index_one_node);
1903 if (loop->to[0] == NULL_TREE)
1907 /* We should have a 1-dimensional, zero-based loop. */
1908 gcc_assert (loop->dimen == 1);
1909 gcc_assert (integer_zerop (loop->from[0]));
1911 /* Split the constructor size into a static part and a dynamic part.
1912 Allocate the static size up-front and record whether the dynamic
1913 size might be nonzero. */
1915 dynamic = gfc_get_array_constructor_size (&size, c);
1916 mpz_sub_ui (size, size, 1);
1917 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1921 /* Special case constant array constructors. */
1924 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1927 tree size = constant_array_constructor_loop_size (loop);
1928 if (size && compare_tree_int (size, nelem) == 0)
1930 gfc_trans_constant_array_constructor (loop, ss, type);
1936 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1937 type, NULL_TREE, dynamic, true, false, where);
1939 desc = ss->data.info.descriptor;
1940 offset = gfc_index_zero_node;
1941 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1942 TREE_NO_WARNING (offsetvar) = 1;
1943 TREE_USED (offsetvar) = 0;
1944 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1945 &offset, &offsetvar, dynamic);
1947 /* If the array grows dynamically, the upper bound of the loop variable
1948 is determined by the array's final upper bound. */
1950 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1952 if (TREE_USED (offsetvar))
1953 pushdecl (offsetvar);
1955 gcc_assert (INTEGER_CST_P (offset));
1957 /* Disable bound checking for now because it's probably broken. */
1958 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1965 /* Restore old values of globals. */
1966 first_len = old_first_len;
1967 first_len_val = old_first_len_val;
1968 typespec_chararray_ctor = old_typespec_chararray_ctor;
1972 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1973 called after evaluating all of INFO's vector dimensions. Go through
1974 each such vector dimension and see if we can now fill in any missing
1978 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1987 for (n = 0; n < loop->dimen; n++)
1990 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1991 && loop->to[n] == NULL)
1993 /* Loop variable N indexes vector dimension DIM, and we don't
1994 yet know the upper bound of loop variable N. Set it to the
1995 difference between the vector's upper and lower bounds. */
1996 gcc_assert (loop->from[n] == gfc_index_zero_node);
1997 gcc_assert (info->subscript[dim]
1998 && info->subscript[dim]->type == GFC_SS_VECTOR);
2000 gfc_init_se (&se, NULL);
2001 desc = info->subscript[dim]->data.info.descriptor;
2002 zero = gfc_rank_cst[0];
2003 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2004 gfc_conv_descriptor_ubound_get (desc, zero),
2005 gfc_conv_descriptor_lbound_get (desc, zero));
2006 tmp = gfc_evaluate_now (tmp, &loop->pre);
2013 /* Add the pre and post chains for all the scalar expressions in a SS chain
2014 to loop. This is called after the loop parameters have been calculated,
2015 but before the actual scalarizing loops. */
2018 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2024 /* TODO: This can generate bad code if there are ordering dependencies,
2025 e.g., a callee allocated function and an unknown size constructor. */
2026 gcc_assert (ss != NULL);
2028 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2035 /* Scalar expression. Evaluate this now. This includes elemental
2036 dimension indices, but not array section bounds. */
2037 gfc_init_se (&se, NULL);
2038 gfc_conv_expr (&se, ss->expr);
2039 gfc_add_block_to_block (&loop->pre, &se.pre);
2041 if (ss->expr->ts.type != BT_CHARACTER)
2043 /* Move the evaluation of scalar expressions outside the
2044 scalarization loop, except for WHERE assignments. */
2046 se.expr = convert(gfc_array_index_type, se.expr);
2048 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2049 gfc_add_block_to_block (&loop->pre, &se.post);
2052 gfc_add_block_to_block (&loop->post, &se.post);
2054 ss->data.scalar.expr = se.expr;
2055 ss->string_length = se.string_length;
2058 case GFC_SS_REFERENCE:
2059 /* Scalar argument to elemental procedure. Evaluate this
2061 gfc_init_se (&se, NULL);
2062 gfc_conv_expr (&se, ss->expr);
2063 gfc_add_block_to_block (&loop->pre, &se.pre);
2064 gfc_add_block_to_block (&loop->post, &se.post);
2066 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2067 ss->string_length = se.string_length;
2070 case GFC_SS_SECTION:
2071 /* Add the expressions for scalar and vector subscripts. */
2072 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2073 if (ss->data.info.subscript[n])
2074 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2077 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2081 /* Get the vector's descriptor and store it in SS. */
2082 gfc_init_se (&se, NULL);
2083 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2084 gfc_add_block_to_block (&loop->pre, &se.pre);
2085 gfc_add_block_to_block (&loop->post, &se.post);
2086 ss->data.info.descriptor = se.expr;
2089 case GFC_SS_INTRINSIC:
2090 gfc_add_intrinsic_ss_code (loop, ss);
2093 case GFC_SS_FUNCTION:
2094 /* Array function return value. We call the function and save its
2095 result in a temporary for use inside the loop. */
2096 gfc_init_se (&se, NULL);
2099 gfc_conv_expr (&se, ss->expr);
2100 gfc_add_block_to_block (&loop->pre, &se.pre);
2101 gfc_add_block_to_block (&loop->post, &se.post);
2102 ss->string_length = se.string_length;
2105 case GFC_SS_CONSTRUCTOR:
2106 if (ss->expr->ts.type == BT_CHARACTER
2107 && ss->string_length == NULL
2108 && ss->expr->ts.u.cl
2109 && ss->expr->ts.u.cl->length)
2111 gfc_init_se (&se, NULL);
2112 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2113 gfc_charlen_type_node);
2114 ss->string_length = se.expr;
2115 gfc_add_block_to_block (&loop->pre, &se.pre);
2116 gfc_add_block_to_block (&loop->post, &se.post);
2118 gfc_trans_array_constructor (loop, ss, where);
2122 case GFC_SS_COMPONENT:
2123 /* Do nothing. These are handled elsewhere. */
2133 /* Translate expressions for the descriptor and data pointer of a SS. */
2137 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2142 /* Get the descriptor for the array to be scalarized. */
2143 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2144 gfc_init_se (&se, NULL);
2145 se.descriptor_only = 1;
2146 gfc_conv_expr_lhs (&se, ss->expr);
2147 gfc_add_block_to_block (block, &se.pre);
2148 ss->data.info.descriptor = se.expr;
2149 ss->string_length = se.string_length;
2153 /* Also the data pointer. */
2154 tmp = gfc_conv_array_data (se.expr);
2155 /* If this is a variable or address of a variable we use it directly.
2156 Otherwise we must evaluate it now to avoid breaking dependency
2157 analysis by pulling the expressions for elemental array indices
2160 || (TREE_CODE (tmp) == ADDR_EXPR
2161 && DECL_P (TREE_OPERAND (tmp, 0)))))
2162 tmp = gfc_evaluate_now (tmp, block);
2163 ss->data.info.data = tmp;
2165 tmp = gfc_conv_array_offset (se.expr);
2166 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2171 /* Initialize a gfc_loopinfo structure. */
2174 gfc_init_loopinfo (gfc_loopinfo * loop)
2178 memset (loop, 0, sizeof (gfc_loopinfo));
2179 gfc_init_block (&loop->pre);
2180 gfc_init_block (&loop->post);
2182 /* Initially scalarize in order. */
2183 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2186 loop->ss = gfc_ss_terminator;
2190 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2194 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2200 /* Return an expression for the data pointer of an array. */
2203 gfc_conv_array_data (tree descriptor)
2207 type = TREE_TYPE (descriptor);
2208 if (GFC_ARRAY_TYPE_P (type))
2210 if (TREE_CODE (type) == POINTER_TYPE)
2214 /* Descriptorless arrays. */
2215 return gfc_build_addr_expr (NULL_TREE, descriptor);
2219 return gfc_conv_descriptor_data_get (descriptor);
2223 /* Return an expression for the base offset of an array. */
2226 gfc_conv_array_offset (tree descriptor)
2230 type = TREE_TYPE (descriptor);
2231 if (GFC_ARRAY_TYPE_P (type))
2232 return GFC_TYPE_ARRAY_OFFSET (type);
2234 return gfc_conv_descriptor_offset_get (descriptor);
2238 /* Get an expression for the array stride. */
2241 gfc_conv_array_stride (tree descriptor, int dim)
2246 type = TREE_TYPE (descriptor);
2248 /* For descriptorless arrays use the array size. */
2249 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2250 if (tmp != NULL_TREE)
2253 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2258 /* Like gfc_conv_array_stride, but for the lower bound. */
2261 gfc_conv_array_lbound (tree descriptor, int dim)
2266 type = TREE_TYPE (descriptor);
2268 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2269 if (tmp != NULL_TREE)
2272 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2277 /* Like gfc_conv_array_stride, but for the upper bound. */
2280 gfc_conv_array_ubound (tree descriptor, int dim)
2285 type = TREE_TYPE (descriptor);
2287 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2288 if (tmp != NULL_TREE)
2291 /* This should only ever happen when passing an assumed shape array
2292 as an actual parameter. The value will never be used. */
2293 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2294 return gfc_index_zero_node;
2296 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2301 /* Generate code to perform an array index bound check. */
2304 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2305 locus * where, bool check_upper)
2308 tree tmp_lo, tmp_up;
2310 const char * name = NULL;
2312 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2315 index = gfc_evaluate_now (index, &se->pre);
2317 /* We find a name for the error message. */
2319 name = se->ss->expr->symtree->name;
2321 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2322 && se->loop->ss->expr->symtree)
2323 name = se->loop->ss->expr->symtree->name;
2325 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2326 && se->loop->ss->loop_chain->expr
2327 && se->loop->ss->loop_chain->expr->symtree)
2328 name = se->loop->ss->loop_chain->expr->symtree->name;
2330 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2332 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2333 && se->loop->ss->expr->value.function.name)
2334 name = se->loop->ss->expr->value.function.name;
2336 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2337 || se->loop->ss->type == GFC_SS_SCALAR)
2338 name = "unnamed constant";
2341 if (TREE_CODE (descriptor) == VAR_DECL)
2342 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2344 /* If upper bound is present, include both bounds in the error message. */
2347 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2348 tmp_up = gfc_conv_array_ubound (descriptor, n);
2351 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2352 "outside of expected range (%%ld:%%ld)", n+1, name);
2354 asprintf (&msg, "Index '%%ld' of dimension %d "
2355 "outside of expected range (%%ld:%%ld)", n+1);
2357 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2358 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2359 fold_convert (long_integer_type_node, index),
2360 fold_convert (long_integer_type_node, tmp_lo),
2361 fold_convert (long_integer_type_node, tmp_up));
2362 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2363 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2364 fold_convert (long_integer_type_node, index),
2365 fold_convert (long_integer_type_node, tmp_lo),
2366 fold_convert (long_integer_type_node, tmp_up));
2371 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2374 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2375 "below lower bound of %%ld", n+1, name);
2377 asprintf (&msg, "Index '%%ld' of dimension %d "
2378 "below lower bound of %%ld", n+1);
2380 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2381 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2382 fold_convert (long_integer_type_node, index),
2383 fold_convert (long_integer_type_node, tmp_lo));
2391 /* Return the offset for an index. Performs bound checking for elemental
2392 dimensions. Single element references are processed separately. */
2395 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2396 gfc_array_ref * ar, tree stride)
2402 /* Get the index into the array for this dimension. */
2405 gcc_assert (ar->type != AR_ELEMENT);
2406 switch (ar->dimen_type[dim])
2409 /* Elemental dimension. */
2410 gcc_assert (info->subscript[dim]
2411 && info->subscript[dim]->type == GFC_SS_SCALAR);
2412 /* We've already translated this value outside the loop. */
2413 index = info->subscript[dim]->data.scalar.expr;
2415 index = gfc_trans_array_bound_check (se, info->descriptor,
2416 index, dim, &ar->where,
2417 ar->as->type != AS_ASSUMED_SIZE
2418 || dim < ar->dimen - 1);
2422 gcc_assert (info && se->loop);
2423 gcc_assert (info->subscript[dim]
2424 && info->subscript[dim]->type == GFC_SS_VECTOR);
2425 desc = info->subscript[dim]->data.info.descriptor;
2427 /* Get a zero-based index into the vector. */
2428 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2429 se->loop->loopvar[i], se->loop->from[i]);
2431 /* Multiply the index by the stride. */
2432 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2433 index, gfc_conv_array_stride (desc, 0));
2435 /* Read the vector to get an index into info->descriptor. */
2436 data = build_fold_indirect_ref_loc (input_location,
2437 gfc_conv_array_data (desc));
2438 index = gfc_build_array_ref (data, index, NULL);
2439 index = gfc_evaluate_now (index, &se->pre);
2440 index = fold_convert (gfc_array_index_type, index);
2442 /* Do any bounds checking on the final info->descriptor index. */
2443 index = gfc_trans_array_bound_check (se, info->descriptor,
2444 index, dim, &ar->where,
2445 ar->as->type != AS_ASSUMED_SIZE
2446 || dim < ar->dimen - 1);
2450 /* Scalarized dimension. */
2451 gcc_assert (info && se->loop);
2453 /* Multiply the loop variable by the stride and delta. */
2454 index = se->loop->loopvar[i];
2455 if (!integer_onep (info->stride[i]))
2456 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2458 if (!integer_zerop (info->delta[i]))
2459 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2469 /* Temporary array or derived type component. */
2470 gcc_assert (se->loop);
2471 index = se->loop->loopvar[se->loop->order[i]];
2472 if (!integer_zerop (info->delta[i]))
2473 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2474 index, info->delta[i]);
2477 /* Multiply by the stride. */
2478 if (!integer_onep (stride))
2479 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2485 /* Build a scalarized reference to an array. */
2488 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2491 tree decl = NULL_TREE;
2496 info = &se->ss->data.info;
2498 n = se->loop->order[0];
2502 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2504 /* Add the offset for this dimension to the stored offset for all other
2506 if (!integer_zerop (info->offset))
2507 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2509 if (se->ss->expr && is_subref_array (se->ss->expr))
2510 decl = se->ss->expr->symtree->n.sym->backend_decl;
2512 tmp = build_fold_indirect_ref_loc (input_location,
2514 se->expr = gfc_build_array_ref (tmp, index, decl);
2518 /* Translate access of temporary array. */
2521 gfc_conv_tmp_array_ref (gfc_se * se)
2523 se->string_length = se->ss->string_length;
2524 gfc_conv_scalarized_array_ref (se, NULL);
2528 /* Build an array reference. se->expr already holds the array descriptor.
2529 This should be either a variable, indirect variable reference or component
2530 reference. For arrays which do not have a descriptor, se->expr will be
2532 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2535 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2548 /* Handle scalarized references separately. */
2549 if (ar->type != AR_ELEMENT)
2551 gfc_conv_scalarized_array_ref (se, ar);
2552 gfc_advance_se_ss_chain (se);
2556 index = gfc_index_zero_node;
2558 /* Calculate the offsets from all the dimensions. */
2559 for (n = 0; n < ar->dimen; n++)
2561 /* Calculate the index for this dimension. */
2562 gfc_init_se (&indexse, se);
2563 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2564 gfc_add_block_to_block (&se->pre, &indexse.pre);
2566 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2568 /* Check array bounds. */
2572 /* Evaluate the indexse.expr only once. */
2573 indexse.expr = save_expr (indexse.expr);
2576 tmp = gfc_conv_array_lbound (se->expr, n);
2577 if (sym->attr.temporary)
2579 gfc_init_se (&tmpse, se);
2580 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2581 gfc_array_index_type);
2582 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2586 cond = fold_build2 (LT_EXPR, boolean_type_node,
2588 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2589 "below lower bound of %%ld", n+1, sym->name);
2590 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2591 fold_convert (long_integer_type_node,
2593 fold_convert (long_integer_type_node, tmp));
2596 /* Upper bound, but not for the last dimension of assumed-size
2598 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2600 tmp = gfc_conv_array_ubound (se->expr, n);
2601 if (sym->attr.temporary)
2603 gfc_init_se (&tmpse, se);
2604 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2605 gfc_array_index_type);
2606 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2610 cond = fold_build2 (GT_EXPR, boolean_type_node,
2612 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2613 "above upper bound of %%ld", n+1, sym->name);
2614 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2615 fold_convert (long_integer_type_node,
2617 fold_convert (long_integer_type_node, tmp));
2622 /* Multiply the index by the stride. */
2623 stride = gfc_conv_array_stride (se->expr, n);
2624 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2627 /* And add it to the total. */
2628 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2631 tmp = gfc_conv_array_offset (se->expr);
2632 if (!integer_zerop (tmp))
2633 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2635 /* Access the calculated element. */
2636 tmp = gfc_conv_array_data (se->expr);
2637 tmp = build_fold_indirect_ref (tmp);
2638 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2642 /* Generate the code to be executed immediately before entering a
2643 scalarization loop. */
2646 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2647 stmtblock_t * pblock)
2656 /* This code will be executed before entering the scalarization loop
2657 for this dimension. */
2658 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2660 if ((ss->useflags & flag) == 0)
2663 if (ss->type != GFC_SS_SECTION
2664 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2665 && ss->type != GFC_SS_COMPONENT)
2668 info = &ss->data.info;
2670 if (dim >= info->dimen)
2673 if (dim == info->dimen - 1)
2675 /* For the outermost loop calculate the offset due to any
2676 elemental dimensions. It will have been initialized with the
2677 base offset of the array. */
2680 for (i = 0; i < info->ref->u.ar.dimen; i++)
2682 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2685 gfc_init_se (&se, NULL);
2687 se.expr = info->descriptor;
2688 stride = gfc_conv_array_stride (info->descriptor, i);
2689 index = gfc_conv_array_index_offset (&se, info, i, -1,
2692 gfc_add_block_to_block (pblock, &se.pre);
2694 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2695 info->offset, index);
2696 info->offset = gfc_evaluate_now (info->offset, pblock);
2700 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2703 stride = gfc_conv_array_stride (info->descriptor, 0);
2705 /* Calculate the stride of the innermost loop. Hopefully this will
2706 allow the backend optimizers to do their stuff more effectively.
2708 info->stride0 = gfc_evaluate_now (stride, pblock);
2712 /* Add the offset for the previous loop dimension. */
2717 ar = &info->ref->u.ar;
2718 i = loop->order[dim + 1];
2726 gfc_init_se (&se, NULL);
2728 se.expr = info->descriptor;
2729 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2730 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2732 gfc_add_block_to_block (pblock, &se.pre);
2733 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2734 info->offset, index);
2735 info->offset = gfc_evaluate_now (info->offset, pblock);
2738 /* Remember this offset for the second loop. */
2739 if (dim == loop->temp_dim - 1)
2740 info->saved_offset = info->offset;
2745 /* Start a scalarized expression. Creates a scope and declares loop
2749 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2755 gcc_assert (!loop->array_parameter);
2757 for (dim = loop->dimen - 1; dim >= 0; dim--)
2759 n = loop->order[dim];
2761 gfc_start_block (&loop->code[n]);
2763 /* Create the loop variable. */
2764 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2766 if (dim < loop->temp_dim)
2770 /* Calculate values that will be constant within this loop. */
2771 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2773 gfc_start_block (pbody);
2777 /* Generates the actual loop code for a scalarization loop. */
2780 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2781 stmtblock_t * pbody)
2792 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2793 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2794 && n == loop->dimen - 1)
2796 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2797 init = make_tree_vec (1);
2798 cond = make_tree_vec (1);
2799 incr = make_tree_vec (1);
2801 /* Cycle statement is implemented with a goto. Exit statement must not
2802 be present for this loop. */
2803 exit_label = gfc_build_label_decl (NULL_TREE);
2804 TREE_USED (exit_label) = 1;
2806 /* Label for cycle statements (if needed). */
2807 tmp = build1_v (LABEL_EXPR, exit_label);
2808 gfc_add_expr_to_block (pbody, tmp);
2810 stmt = make_node (OMP_FOR);
2812 TREE_TYPE (stmt) = void_type_node;
2813 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2815 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2816 OMP_CLAUSE_SCHEDULE);
2817 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2818 = OMP_CLAUSE_SCHEDULE_STATIC;
2819 if (ompws_flags & OMPWS_NOWAIT)
2820 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2821 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2823 /* Initialize the loopvar. */
2824 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2826 OMP_FOR_INIT (stmt) = init;
2827 /* The exit condition. */
2828 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2829 loop->loopvar[n], loop->to[n]);
2830 OMP_FOR_COND (stmt) = cond;
2831 /* Increment the loopvar. */
2832 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2833 loop->loopvar[n], gfc_index_one_node);
2834 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2835 void_type_node, loop->loopvar[n], tmp);
2836 OMP_FOR_INCR (stmt) = incr;
2838 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2839 gfc_add_expr_to_block (&loop->code[n], stmt);
2843 loopbody = gfc_finish_block (pbody);
2845 /* Initialize the loopvar. */
2846 if (loop->loopvar[n] != loop->from[n])
2847 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2849 exit_label = gfc_build_label_decl (NULL_TREE);
2851 /* Generate the loop body. */
2852 gfc_init_block (&block);
2854 /* The exit condition. */
2855 cond = fold_build2 (GT_EXPR, boolean_type_node,
2856 loop->loopvar[n], loop->to[n]);
2857 tmp = build1_v (GOTO_EXPR, exit_label);
2858 TREE_USED (exit_label) = 1;
2859 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2860 gfc_add_expr_to_block (&block, tmp);
2862 /* The main body. */
2863 gfc_add_expr_to_block (&block, loopbody);
2865 /* Increment the loopvar. */
2866 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2867 loop->loopvar[n], gfc_index_one_node);
2868 gfc_add_modify (&block, loop->loopvar[n], tmp);
2870 /* Build the loop. */
2871 tmp = gfc_finish_block (&block);
2872 tmp = build1_v (LOOP_EXPR, tmp);
2873 gfc_add_expr_to_block (&loop->code[n], tmp);
2875 /* Add the exit label. */
2876 tmp = build1_v (LABEL_EXPR, exit_label);
2877 gfc_add_expr_to_block (&loop->code[n], tmp);
2883 /* Finishes and generates the loops for a scalarized expression. */
2886 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2891 stmtblock_t *pblock;
2895 /* Generate the loops. */
2896 for (dim = 0; dim < loop->dimen; dim++)
2898 n = loop->order[dim];
2899 gfc_trans_scalarized_loop_end (loop, n, pblock);
2900 loop->loopvar[n] = NULL_TREE;
2901 pblock = &loop->code[n];
2904 tmp = gfc_finish_block (pblock);
2905 gfc_add_expr_to_block (&loop->pre, tmp);
2907 /* Clear all the used flags. */
2908 for (ss = loop->ss; ss; ss = ss->loop_chain)
2913 /* Finish the main body of a scalarized expression, and start the secondary
2917 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2921 stmtblock_t *pblock;
2925 /* We finish as many loops as are used by the temporary. */
2926 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2928 n = loop->order[dim];
2929 gfc_trans_scalarized_loop_end (loop, n, pblock);
2930 loop->loopvar[n] = NULL_TREE;
2931 pblock = &loop->code[n];
2934 /* We don't want to finish the outermost loop entirely. */
2935 n = loop->order[loop->temp_dim - 1];
2936 gfc_trans_scalarized_loop_end (loop, n, pblock);
2938 /* Restore the initial offsets. */
2939 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2941 if ((ss->useflags & 2) == 0)
2944 if (ss->type != GFC_SS_SECTION
2945 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2946 && ss->type != GFC_SS_COMPONENT)
2949 ss->data.info.offset = ss->data.info.saved_offset;
2952 /* Restart all the inner loops we just finished. */
2953 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2955 n = loop->order[dim];
2957 gfc_start_block (&loop->code[n]);
2959 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2961 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2964 /* Start a block for the secondary copying code. */
2965 gfc_start_block (body);
2969 /* Calculate the upper bound of an array section. */
2972 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2981 gcc_assert (ss->type == GFC_SS_SECTION);
2983 info = &ss->data.info;
2986 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2987 /* We'll calculate the upper bound once we have access to the
2988 vector's descriptor. */
2991 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2992 desc = info->descriptor;
2993 end = info->ref->u.ar.end[dim];
2997 /* The upper bound was specified. */
2998 gfc_init_se (&se, NULL);
2999 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3000 gfc_add_block_to_block (pblock, &se.pre);
3005 /* No upper bound was specified, so use the bound of the array. */
3006 bound = gfc_conv_array_ubound (desc, dim);
3013 /* Calculate the lower bound of an array section. */
3016 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3026 gcc_assert (ss->type == GFC_SS_SECTION);
3028 info = &ss->data.info;
3031 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3033 /* We use a zero-based index to access the vector. */
3034 info->start[n] = gfc_index_zero_node;
3035 info->end[n] = gfc_index_zero_node;
3036 info->stride[n] = gfc_index_one_node;
3040 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3041 desc = info->descriptor;
3042 start = info->ref->u.ar.start[dim];
3043 end = info->ref->u.ar.end[dim];
3044 stride = info->ref->u.ar.stride[dim];
3046 /* Calculate the start of the range. For vector subscripts this will
3047 be the range of the vector. */
3050 /* Specified section start. */
3051 gfc_init_se (&se, NULL);
3052 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3053 gfc_add_block_to_block (&loop->pre, &se.pre);
3054 info->start[n] = se.expr;
3058 /* No lower bound specified so use the bound of the array. */
3059 info->start[n] = gfc_conv_array_lbound (desc, dim);
3061 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3063 /* Similarly calculate the end. Although this is not used in the
3064 scalarizer, it is needed when checking bounds and where the end
3065 is an expression with side-effects. */
3068 /* Specified section start. */
3069 gfc_init_se (&se, NULL);
3070 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3071 gfc_add_block_to_block (&loop->pre, &se.pre);
3072 info->end[n] = se.expr;
3076 /* No upper bound specified so use the bound of the array. */
3077 info->end[n] = gfc_conv_array_ubound (desc, dim);
3079 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3081 /* Calculate the stride. */
3083 info->stride[n] = gfc_index_one_node;
3086 gfc_init_se (&se, NULL);
3087 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3088 gfc_add_block_to_block (&loop->pre, &se.pre);
3089 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3094 /* Calculates the range start and stride for a SS chain. Also gets the
3095 descriptor and data pointer. The range of vector subscripts is the size
3096 of the vector. Array bounds are also checked. */
3099 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3107 /* Determine the rank of the loop. */
3109 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3113 case GFC_SS_SECTION:
3114 case GFC_SS_CONSTRUCTOR:
3115 case GFC_SS_FUNCTION:
3116 case GFC_SS_COMPONENT:
3117 loop->dimen = ss->data.info.dimen;
3120 /* As usual, lbound and ubound are exceptions!. */
3121 case GFC_SS_INTRINSIC:
3122 switch (ss->expr->value.function.isym->id)
3124 case GFC_ISYM_LBOUND:
3125 case GFC_ISYM_UBOUND:
3126 loop->dimen = ss->data.info.dimen;
3137 /* We should have determined the rank of the expression by now. If
3138 not, that's bad news. */
3139 gcc_assert (loop->dimen != 0);
3141 /* Loop over all the SS in the chain. */
3142 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3144 if (ss->expr && ss->expr->shape && !ss->shape)
3145 ss->shape = ss->expr->shape;
3149 case GFC_SS_SECTION:
3150 /* Get the descriptor for the array. */
3151 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3153 for (n = 0; n < ss->data.info.dimen; n++)
3154 gfc_conv_section_startstride (loop, ss, n);
3157 case GFC_SS_INTRINSIC:
3158 switch (ss->expr->value.function.isym->id)
3160 /* Fall through to supply start and stride. */
3161 case GFC_ISYM_LBOUND:
3162 case GFC_ISYM_UBOUND:
3168 case GFC_SS_CONSTRUCTOR:
3169 case GFC_SS_FUNCTION:
3170 for (n = 0; n < ss->data.info.dimen; n++)
3172 ss->data.info.start[n] = gfc_index_zero_node;
3173 ss->data.info.end[n] = gfc_index_zero_node;
3174 ss->data.info.stride[n] = gfc_index_one_node;
3183 /* The rest is just runtime bound checking. */
3184 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3187 tree lbound, ubound;
3189 tree size[GFC_MAX_DIMENSIONS];
3190 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3195 gfc_start_block (&block);
3197 for (n = 0; n < loop->dimen; n++)
3198 size[n] = NULL_TREE;
3200 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3204 if (ss->type != GFC_SS_SECTION)
3207 gfc_start_block (&inner);
3209 /* TODO: range checking for mapped dimensions. */
3210 info = &ss->data.info;
3212 /* This code only checks ranges. Elemental and vector
3213 dimensions are checked later. */
3214 for (n = 0; n < loop->dimen; n++)
3219 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3222 if (dim == info->ref->u.ar.dimen - 1
3223 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3224 check_upper = false;
3228 /* Zero stride is not allowed. */
3229 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3230 gfc_index_zero_node);
3231 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3232 "of array '%s'", info->dim[n]+1,
3233 ss->expr->symtree->name);
3234 gfc_trans_runtime_check (true, false, tmp, &inner,
3235 &ss->expr->where, msg);
3238 desc = ss->data.info.descriptor;
3240 /* This is the run-time equivalent of resolve.c's
3241 check_dimension(). The logical is more readable there
3242 than it is here, with all the trees. */
3243 lbound = gfc_conv_array_lbound (desc, dim);
3246 ubound = gfc_conv_array_ubound (desc, dim);
3250 /* non_zerosized is true when the selected range is not
3252 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3253 info->stride[n], gfc_index_zero_node);
3254 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3256 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3259 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3260 info->stride[n], gfc_index_zero_node);
3261 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3263 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3265 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3266 stride_pos, stride_neg);
3268 /* Check the start of the range against the lower and upper
3269 bounds of the array, if the range is not empty.
3270 If upper bound is present, include both bounds in the
3274 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3275 info->start[n], lbound);
3276 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3277 non_zerosized, tmp);
3278 tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3279 info->start[n], ubound);
3280 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3281 non_zerosized, tmp2);
3282 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3283 "outside of expected range (%%ld:%%ld)",
3284 info->dim[n]+1, ss->expr->symtree->name);
3285 gfc_trans_runtime_check (true, false, tmp, &inner,
3286 &ss->expr->where, msg,
3287 fold_convert (long_integer_type_node, info->start[n]),
3288 fold_convert (long_integer_type_node, lbound),
3289 fold_convert (long_integer_type_node, ubound));
3290 gfc_trans_runtime_check (true, false, tmp2, &inner,
3291 &ss->expr->where, msg,
3292 fold_convert (long_integer_type_node, info->start[n]),
3293 fold_convert (long_integer_type_node, lbound),
3294 fold_convert (long_integer_type_node, ubound));
3299 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3300 info->start[n], lbound);
3301 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3302 non_zerosized, tmp);
3303 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3304 "below lower bound of %%ld",
3305 info->dim[n]+1, ss->expr->symtree->name);
3306 gfc_trans_runtime_check (true, false, tmp, &inner,
3307 &ss->expr->where, msg,
3308 fold_convert (long_integer_type_node, info->start[n]),
3309 fold_convert (long_integer_type_node, lbound));
3313 /* Compute the last element of the range, which is not
3314 necessarily "end" (think 0:5:3, which doesn't contain 5)
3315 and check it against both lower and upper bounds. */
3317 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3319 tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3321 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3323 tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3324 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3325 non_zerosized, tmp2);
3328 tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3329 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3330 non_zerosized, tmp3);
3331 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3332 "outside of expected range (%%ld:%%ld)",
3333 info->dim[n]+1, ss->expr->symtree->name);
3334 gfc_trans_runtime_check (true, false, tmp2, &inner,
3335 &ss->expr->where, msg,
3336 fold_convert (long_integer_type_node, tmp),
3337 fold_convert (long_integer_type_node, ubound),
3338 fold_convert (long_integer_type_node, lbound));
3339 gfc_trans_runtime_check (true, false, tmp3, &inner,
3340 &ss->expr->where, msg,
3341 fold_convert (long_integer_type_node, tmp),
3342 fold_convert (long_integer_type_node, ubound),
3343 fold_convert (long_integer_type_node, lbound));
3348 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3349 "below lower bound of %%ld",
3350 info->dim[n]+1, ss->expr->symtree->name);
3351 gfc_trans_runtime_check (true, false, tmp2, &inner,
3352 &ss->expr->where, msg,
3353 fold_convert (long_integer_type_node, tmp),
3354 fold_convert (long_integer_type_node, lbound));
3358 /* Check the section sizes match. */
3359 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3361 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3363 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3364 gfc_index_one_node, tmp);
3365 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3366 build_int_cst (gfc_array_index_type, 0));
3367 /* We remember the size of the first section, and check all the
3368 others against this. */
3371 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3372 asprintf (&msg, "Array bound mismatch for dimension %d "
3373 "of array '%s' (%%ld/%%ld)",
3374 info->dim[n]+1, ss->expr->symtree->name);
3376 gfc_trans_runtime_check (true, false, tmp3, &inner,
3377 &ss->expr->where, msg,
3378 fold_convert (long_integer_type_node, tmp),
3379 fold_convert (long_integer_type_node, size[n]));
3384 size[n] = gfc_evaluate_now (tmp, &inner);
3387 tmp = gfc_finish_block (&inner);
3389 /* For optional arguments, only check bounds if the argument is
3391 if (ss->expr->symtree->n.sym->attr.optional
3392 || ss->expr->symtree->n.sym->attr.not_always_present)
3393 tmp = build3_v (COND_EXPR,
3394 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3395 tmp, build_empty_stmt (input_location));
3397 gfc_add_expr_to_block (&block, tmp);
3401 tmp = gfc_finish_block (&block);
3402 gfc_add_expr_to_block (&loop->pre, tmp);
3407 /* Return true if the two SS could be aliased, i.e. both point to the same data
3409 /* TODO: resolve aliases based on frontend expressions. */
3412 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3419 lsym = lss->expr->symtree->n.sym;
3420 rsym = rss->expr->symtree->n.sym;
3421 if (gfc_symbols_could_alias (lsym, rsym))
3424 if (rsym->ts.type != BT_DERIVED
3425 && lsym->ts.type != BT_DERIVED)
3428 /* For derived types we must check all the component types. We can ignore
3429 array references as these will have the same base type as the previous
3431 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3433 if (lref->type != REF_COMPONENT)
3436 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3439 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3442 if (rref->type != REF_COMPONENT)
3445 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3450 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3452 if (rref->type != REF_COMPONENT)
3455 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3463 /* Resolve array data dependencies. Creates a temporary if required. */
3464 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3468 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3476 loop->temp_ss = NULL;
3478 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3480 if (ss->type != GFC_SS_SECTION)
3483 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3485 if (gfc_could_be_alias (dest, ss)
3486 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3494 lref = dest->expr->ref;
3495 rref = ss->expr->ref;
3497 nDepend = gfc_dep_resolver (lref, rref);
3501 /* TODO : loop shifting. */
3504 /* Mark the dimensions for LOOP SHIFTING */
3505 for (n = 0; n < loop->dimen; n++)
3507 int dim = dest->data.info.dim[n];
3509 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3511 else if (! gfc_is_same_range (&lref->u.ar,
3512 &rref->u.ar, dim, 0))
3516 /* Put all the dimensions with dependencies in the
3519 for (n = 0; n < loop->dimen; n++)
3521 gcc_assert (loop->order[n] == n);
3523 loop->order[dim++] = n;
3525 for (n = 0; n < loop->dimen; n++)
3528 loop->order[dim++] = n;
3531 gcc_assert (dim == loop->dimen);
3540 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3541 if (GFC_ARRAY_TYPE_P (base_type)
3542 || GFC_DESCRIPTOR_TYPE_P (base_type))
3543 base_type = gfc_get_element_type (base_type);
3544 loop->temp_ss = gfc_get_ss ();
3545 loop->temp_ss->type = GFC_SS_TEMP;
3546 loop->temp_ss->data.temp.type = base_type;
3547 loop->temp_ss->string_length = dest->string_length;
3548 loop->temp_ss->data.temp.dimen = loop->dimen;
3549 loop->temp_ss->next = gfc_ss_terminator;
3550 gfc_add_ss_to_loop (loop, loop->temp_ss);
3553 loop->temp_ss = NULL;
3557 /* Initialize the scalarization loop. Creates the loop variables. Determines
3558 the range of the loop variables. Creates a temporary if required.
3559 Calculates how to transform from loop variables to array indices for each
3560 expression. Also generates code for scalar expressions which have been
3561 moved outside the loop. */
3564 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3568 gfc_ss_info *specinfo;
3571 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3572 bool dynamic[GFC_MAX_DIMENSIONS];
3577 for (n = 0; n < loop->dimen; n++)
3581 /* We use one SS term, and use that to determine the bounds of the
3582 loop for this dimension. We try to pick the simplest term. */
3583 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3587 /* The frontend has worked out the size for us. */
3588 if (!loopspec[n] || !loopspec[n]->shape
3589 || !integer_zerop (loopspec[n]->data.info.start[n]))
3590 /* Prefer zero-based descriptors if possible. */
3595 if (ss->type == GFC_SS_CONSTRUCTOR)
3597 gfc_constructor_base base;
3598 /* An unknown size constructor will always be rank one.
3599 Higher rank constructors will either have known shape,
3600 or still be wrapped in a call to reshape. */
3601 gcc_assert (loop->dimen == 1);
3603 /* Always prefer to use the constructor bounds if the size
3604 can be determined at compile time. Prefer not to otherwise,
3605 since the general case involves realloc, and it's better to
3606 avoid that overhead if possible. */
3607 base = ss->expr->value.constructor;
3608 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3609 if (!dynamic[n] || !loopspec[n])
3614 /* TODO: Pick the best bound if we have a choice between a
3615 function and something else. */
3616 if (ss->type == GFC_SS_FUNCTION)
3622 if (ss->type != GFC_SS_SECTION)
3626 specinfo = &loopspec[n]->data.info;
3629 info = &ss->data.info;
3633 /* Criteria for choosing a loop specifier (most important first):
3634 doesn't need realloc
3640 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3642 else if (integer_onep (info->stride[n])
3643 && !integer_onep (specinfo->stride[n]))
3645 else if (INTEGER_CST_P (info->stride[n])
3646 && !INTEGER_CST_P (specinfo->stride[n]))
3648 else if (INTEGER_CST_P (info->start[n])
3649 && !INTEGER_CST_P (specinfo->start[n]))
3651 /* We don't work out the upper bound.
3652 else if (INTEGER_CST_P (info->finish[n])
3653 && ! INTEGER_CST_P (specinfo->finish[n]))
3654 loopspec[n] = ss; */
3657 /* We should have found the scalarization loop specifier. If not,
3659 gcc_assert (loopspec[n]);
3661 info = &loopspec[n]->data.info;
3663 /* Set the extents of this range. */
3664 cshape = loopspec[n]->shape;
3665 if (cshape && INTEGER_CST_P (info->start[n])
3666 && INTEGER_CST_P (info->stride[n]))
3668 loop->from[n] = info->start[n];
3669 mpz_set (i, cshape[n]);
3670 mpz_sub_ui (i, i, 1);
3671 /* To = from + (size - 1) * stride. */
3672 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3673 if (!integer_onep (info->stride[n]))
3674 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3675 tmp, info->stride[n]);
3676 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3677 loop->from[n], tmp);
3681 loop->from[n] = info->start[n];
3682 switch (loopspec[n]->type)
3684 case GFC_SS_CONSTRUCTOR:
3685 /* The upper bound is calculated when we expand the
3687 gcc_assert (loop->to[n] == NULL_TREE);
3690 case GFC_SS_SECTION:
3691 /* Use the end expression if it exists and is not constant,
3692 so that it is only evaluated once. */
3693 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3694 loop->to[n] = info->end[n];
3696 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3700 case GFC_SS_FUNCTION:
3701 /* The loop bound will be set when we generate the call. */
3702 gcc_assert (loop->to[n] == NULL_TREE);
3710 /* Transform everything so we have a simple incrementing variable. */
3711 if (integer_onep (info->stride[n]))
3712 info->delta[n] = gfc_index_zero_node;
3715 /* Set the delta for this section. */
3716 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3717 /* Number of iterations is (end - start + step) / step.
3718 with start = 0, this simplifies to
3720 for (i = 0; i<=last; i++){...}; */
3721 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3722 loop->to[n], loop->from[n]);
3723 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3724 tmp, info->stride[n]);
3725 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3726 build_int_cst (gfc_array_index_type, -1));
3727 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3728 /* Make the loop variable start at 0. */
3729 loop->from[n] = gfc_index_zero_node;
3733 /* Add all the scalar code that can be taken out of the loops.
3734 This may include calculating the loop bounds, so do it before
3735 allocating the temporary. */
3736 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3738 /* If we want a temporary then create it. */
3739 if (loop->temp_ss != NULL)
3741 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3743 /* Make absolutely sure that this is a complete type. */
3744 if (loop->temp_ss->string_length)
3745 loop->temp_ss->data.temp.type
3746 = gfc_get_character_type_len_for_eltype
3747 (TREE_TYPE (loop->temp_ss->data.temp.type),
3748 loop->temp_ss->string_length);
3750 tmp = loop->temp_ss->data.temp.type;
3751 n = loop->temp_ss->data.temp.dimen;
3752 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3753 loop->temp_ss->type = GFC_SS_SECTION;
3754 loop->temp_ss->data.info.dimen = n;
3755 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3756 &loop->temp_ss->data.info, tmp, NULL_TREE,
3757 false, true, false, where);
3760 for (n = 0; n < loop->temp_dim; n++)
3761 loopspec[loop->order[n]] = NULL;
3765 /* For array parameters we don't have loop variables, so don't calculate the
3767 if (loop->array_parameter)
3770 /* Calculate the translation from loop variables to array indices. */
3771 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3773 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3774 && ss->type != GFC_SS_CONSTRUCTOR)
3778 info = &ss->data.info;
3780 for (n = 0; n < info->dimen; n++)
3782 /* If we are specifying the range the delta is already set. */
3783 if (loopspec[n] != ss)
3785 /* Calculate the offset relative to the loop variable.
3786 First multiply by the stride. */
3787 tmp = loop->from[n];
3788 if (!integer_onep (info->stride[n]))
3789 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3790 tmp, info->stride[n]);
3792 /* Then subtract this from our starting value. */
3793 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3794 info->start[n], tmp);
3796 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3803 /* Fills in an array descriptor, and returns the size of the array. The size
3804 will be a simple_val, ie a variable or a constant. Also calculates the
3805 offset of the base. Returns the size of the array.
3809 for (n = 0; n < rank; n++)
3811 a.lbound[n] = specified_lower_bound;
3812 offset = offset + a.lbond[n] * stride;
3814 a.ubound[n] = specified_upper_bound;
3815 a.stride[n] = stride;
3816 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3817 stride = stride * size;
3824 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
3825 gfc_expr ** lower, gfc_expr ** upper,
3826 stmtblock_t * pblock)
3838 stmtblock_t thenblock;
3839 stmtblock_t elseblock;
3844 type = TREE_TYPE (descriptor);
3846 stride = gfc_index_one_node;
3847 offset = gfc_index_zero_node;
3849 /* Set the dtype. */
3850 tmp = gfc_conv_descriptor_dtype (descriptor);
3851 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3853 or_expr = NULL_TREE;
3855 for (n = 0; n < rank; n++)
3857 /* We have 3 possibilities for determining the size of the array:
3858 lower == NULL => lbound = 1, ubound = upper[n]
3859 upper[n] = NULL => lbound = 1, ubound = lower[n]
3860 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3863 /* Set lower bound. */
3864 gfc_init_se (&se, NULL);
3866 se.expr = gfc_index_one_node;
3869 gcc_assert (lower[n]);
3872 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3873 gfc_add_block_to_block (pblock, &se.pre);
3877 se.expr = gfc_index_one_node;
3881 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3884 /* Work out the offset for this component. */
3885 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3886 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3888 /* Start the calculation for the size of this dimension. */
3889 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3890 gfc_index_one_node, se.expr);
3892 /* Set upper bound. */
3893 gfc_init_se (&se, NULL);
3894 gcc_assert (ubound);
3895 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3896 gfc_add_block_to_block (pblock, &se.pre);
3898 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3900 /* Store the stride. */
3901 gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3903 /* Calculate the size of this dimension. */
3904 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3906 /* Check whether the size for this dimension is negative. */
3907 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3908 gfc_index_zero_node);
3912 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3914 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3915 gfc_index_zero_node, size);
3917 /* Multiply the stride by the number of elements in this dimension. */
3918 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3919 stride = gfc_evaluate_now (stride, pblock);
3922 for (n = rank; n < rank + corank; n++)
3926 /* Set lower bound. */
3927 gfc_init_se (&se, NULL);
3928 if (lower == NULL || lower[n] == NULL)
3930 gcc_assert (n == rank + corank - 1);
3931 se.expr = gfc_index_one_node;
3935 if (ubound || n == rank + corank - 1)
3937 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3938 gfc_add_block_to_block (pblock, &se.pre);
3942 se.expr = gfc_index_one_node;
3946 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3949 if (n < rank + corank - 1)
3951 gfc_init_se (&se, NULL);
3952 gcc_assert (ubound);
3953 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3954 gfc_add_block_to_block (pblock, &se.pre);
3955 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3959 /* The stride is the number of elements in the array, so multiply by the
3960 size of an element to get the total size. */
3961 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3962 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3963 fold_convert (gfc_array_index_type, tmp));
3965 if (poffset != NULL)
3967 offset = gfc_evaluate_now (offset, pblock);
3971 if (integer_zerop (or_expr))
3973 if (integer_onep (or_expr))
3974 return gfc_index_zero_node;
3976 var = gfc_create_var (TREE_TYPE (size), "size");
3977 gfc_start_block (&thenblock);
3978 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3979 thencase = gfc_finish_block (&thenblock);
3981 gfc_start_block (&elseblock);
3982 gfc_add_modify (&elseblock, var, size);
3983 elsecase = gfc_finish_block (&elseblock);
3985 tmp = gfc_evaluate_now (or_expr, pblock);
3986 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3987 gfc_add_expr_to_block (pblock, tmp);
3993 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3994 the work for an ALLOCATE statement. */
3998 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4006 gfc_ref *ref, *prev_ref = NULL;
4007 bool allocatable_array, coarray;
4011 /* Find the last reference in the chain. */
4012 while (ref && ref->next != NULL)
4014 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4015 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4020 if (ref == NULL || ref->type != REF_ARRAY)
4023 /* Return if this is a scalar coarray. */
4024 if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
4026 gcc_assert (expr->symtree->n.sym->attr.codimension);
4029 else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
4031 gcc_assert (prev_ref->u.c.component->attr.codimension);
4037 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4038 coarray = expr->symtree->n.sym->attr.codimension;
4042 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4043 coarray = prev_ref->u.c.component->attr.codimension;
4046 /* Return if this is a scalar coarray. */
4047 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4048 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4050 gcc_assert (coarray);
4054 /* Figure out the size of the array. */
4055 switch (ref->u.ar.type)
4061 upper = ref->u.ar.start;
4067 lower = ref->u.ar.start;
4068 upper = ref->u.ar.end;
4072 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4074 lower = ref->u.ar.as->lower;
4075 upper = ref->u.ar.as->upper;
4083 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4084 ref->u.ar.as->corank, &offset, lower, upper,
4087 /* Allocate memory to store the data. */
4088 pointer = gfc_conv_descriptor_data_get (se->expr);
4089 STRIP_NOPS (pointer);
4091 /* The allocate_array variants take the old pointer as first argument. */
4092 if (allocatable_array)
4093 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4095 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4096 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
4097 gfc_add_expr_to_block (&se->pre, tmp);
4099 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4101 if (expr->ts.type == BT_DERIVED
4102 && expr->ts.u.derived->attr.alloc_comp)
4104 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4105 ref->u.ar.as->rank);
4106 gfc_add_expr_to_block (&se->pre, tmp);
4113 /* Deallocate an array variable. Also used when an allocated variable goes
4118 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4124 gfc_start_block (&block);
4125 /* Get a pointer to the data. */
4126 var = gfc_conv_descriptor_data_get (descriptor);
4129 /* Parameter is the address of the data component. */
4130 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4131 gfc_add_expr_to_block (&block, tmp);
4133 /* Zero the data pointer. */
4134 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4135 var, build_int_cst (TREE_TYPE (var), 0));
4136 gfc_add_expr_to_block (&block, tmp);
4138 return gfc_finish_block (&block);
4142 /* Create an array constructor from an initialization expression.
4143 We assume the frontend already did any expansions and conversions. */
4146 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4152 unsigned HOST_WIDE_INT lo;
4154 VEC(constructor_elt,gc) *v = NULL;
4156 switch (expr->expr_type)
4159 case EXPR_STRUCTURE:
4160 /* A single scalar or derived type value. Create an array with all
4161 elements equal to that value. */
4162 gfc_init_se (&se, NULL);
4164 if (expr->expr_type == EXPR_CONSTANT)
4165 gfc_conv_constant (&se, expr);
4167 gfc_conv_structure (&se, expr, 1);
4169 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4170 gcc_assert (tmp && INTEGER_CST_P (tmp));
4171 hi = TREE_INT_CST_HIGH (tmp);
4172 lo = TREE_INT_CST_LOW (tmp);
4176 /* This will probably eat buckets of memory for large arrays. */
4177 while (hi != 0 || lo != 0)
4179 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4187 /* Create a vector of all the elements. */
4188 for (c = gfc_constructor_first (expr->value.constructor);
4189 c; c = gfc_constructor_next (c))
4193 /* Problems occur when we get something like
4194 integer :: a(lots) = (/(i, i=1, lots)/) */
4195 gfc_fatal_error ("The number of elements in the array constructor "
4196 "at %L requires an increase of the allowed %d "
4197 "upper limit. See -fmax-array-constructor "
4198 "option", &expr->where,
4199 gfc_option.flag_max_array_constructor);
4202 if (mpz_cmp_si (c->offset, 0) != 0)
4203 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4207 if (mpz_cmp_si (c->repeat, 0) != 0)
4211 mpz_set (maxval, c->repeat);
4212 mpz_add (maxval, c->offset, maxval);
4213 mpz_sub_ui (maxval, maxval, 1);
4214 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4215 if (mpz_cmp_si (c->offset, 0) != 0)
4217 mpz_add_ui (maxval, c->offset, 1);
4218 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4221 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4223 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
4229 gfc_init_se (&se, NULL);
4230 switch (c->expr->expr_type)
4233 gfc_conv_constant (&se, c->expr);
4234 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4237 case EXPR_STRUCTURE:
4238 gfc_conv_structure (&se, c->expr, 1);
4239 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4244 /* Catch those occasional beasts that do not simplify
4245 for one reason or another, assuming that if they are
4246 standard defying the frontend will catch them. */
4247 gfc_conv_expr (&se, c->expr);
4248 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4255 return gfc_build_null_descriptor (type);
4261 /* Create a constructor from the list of elements. */
4262 tmp = build_constructor (type, v);
4263 TREE_CONSTANT (tmp) = 1;
4268 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4269 returns the size (in elements) of the array. */
4272 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4273 stmtblock_t * pblock)
4288 size = gfc_index_one_node;
4289 offset = gfc_index_zero_node;
4290 for (dim = 0; dim < as->rank; dim++)
4292 /* Evaluate non-constant array bound expressions. */
4293 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4294 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4296 gfc_init_se (&se, NULL);
4297 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4298 gfc_add_block_to_block (pblock, &se.pre);
4299 gfc_add_modify (pblock, lbound, se.expr);
4301 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4302 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4304 gfc_init_se (&se, NULL);
4305 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4306 gfc_add_block_to_block (pblock, &se.pre);
4307 gfc_add_modify (pblock, ubound, se.expr);
4309 /* The offset of this dimension. offset = offset - lbound * stride. */
4310 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4311 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4313 /* The size of this dimension, and the stride of the next. */
4314 if (dim + 1 < as->rank)
4315 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4317 stride = GFC_TYPE_ARRAY_SIZE (type);
4319 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4321 /* Calculate stride = size * (ubound + 1 - lbound). */
4322 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4323 gfc_index_one_node, lbound);
4324 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4325 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4327 gfc_add_modify (pblock, stride, tmp);
4329 stride = gfc_evaluate_now (tmp, pblock);
4331 /* Make sure that negative size arrays are translated
4332 to being zero size. */
4333 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4334 stride, gfc_index_zero_node);
4335 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4336 stride, gfc_index_zero_node);
4337 gfc_add_modify (pblock, stride, tmp);
4343 gfc_trans_vla_type_sizes (sym, pblock);
4350 /* Generate code to initialize/allocate an array variable. */
4353 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4362 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4364 /* Do nothing for USEd variables. */
4365 if (sym->attr.use_assoc)
4368 type = TREE_TYPE (decl);
4369 gcc_assert (GFC_ARRAY_TYPE_P (type));
4370 onstack = TREE_CODE (type) != POINTER_TYPE;
4372 gfc_start_block (&block);
4374 /* Evaluate character string length. */
4375 if (sym->ts.type == BT_CHARACTER
4376 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4378 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4380 gfc_trans_vla_type_sizes (sym, &block);
4382 /* Emit a DECL_EXPR for this variable, which will cause the
4383 gimplifier to allocate storage, and all that good stuff. */
4384 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4385 gfc_add_expr_to_block (&block, tmp);
4390 gfc_add_expr_to_block (&block, fnbody);
4391 return gfc_finish_block (&block);
4394 type = TREE_TYPE (type);
4396 gcc_assert (!sym->attr.use_assoc);
4397 gcc_assert (!TREE_STATIC (decl));
4398 gcc_assert (!sym->module);
4400 if (sym->ts.type == BT_CHARACTER
4401 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4402 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4404 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4406 /* Don't actually allocate space for Cray Pointees. */
4407 if (sym->attr.cray_pointee)
4409 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4410 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4411 gfc_add_expr_to_block (&block, fnbody);
4412 return gfc_finish_block (&block);
4415 /* The size is the number of elements in the array, so multiply by the
4416 size of an element to get the total size. */
4417 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4418 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4419 fold_convert (gfc_array_index_type, tmp));
4421 /* Allocate memory to hold the data. */
4422 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4423 gfc_add_modify (&block, decl, tmp);
4425 /* Set offset of the array. */
4426 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4427 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4430 /* Automatic arrays should not have initializers. */
4431 gcc_assert (!sym->value);
4433 gfc_add_expr_to_block (&block, fnbody);
4435 /* Free the temporary. */
4436 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4437 gfc_add_expr_to_block (&block, tmp);
4439 return gfc_finish_block (&block);
4443 /* Generate entry and exit code for g77 calling convention arrays. */
4446 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4456 gfc_get_backend_locus (&loc);
4457 gfc_set_backend_locus (&sym->declared_at);
4459 /* Descriptor type. */
4460 parm = sym->backend_decl;
4461 type = TREE_TYPE (parm);
4462 gcc_assert (GFC_ARRAY_TYPE_P (type));
4464 gfc_start_block (&block);
4466 if (sym->ts.type == BT_CHARACTER
4467 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4468 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4470 /* Evaluate the bounds of the array. */
4471 gfc_trans_array_bounds (type, sym, &offset, &block);
4473 /* Set the offset. */
4474 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4475 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4477 /* Set the pointer itself if we aren't using the parameter directly. */
4478 if (TREE_CODE (parm) != PARM_DECL)
4480 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4481 gfc_add_modify (&block, parm, tmp);
4483 stmt = gfc_finish_block (&block);
4485 gfc_set_backend_locus (&loc);
4487 gfc_start_block (&block);
4489 /* Add the initialization code to the start of the function. */
4491 if (sym->attr.optional || sym->attr.not_always_present)
4493 tmp = gfc_conv_expr_present (sym);
4494 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4497 gfc_add_expr_to_block (&block, stmt);
4498 gfc_add_expr_to_block (&block, body);
4500 return gfc_finish_block (&block);
4504 /* Modify the descriptor of an array parameter so that it has the
4505 correct lower bound. Also move the upper bound accordingly.
4506 If the array is not packed, it will be copied into a temporary.
4507 For each dimension we set the new lower and upper bounds. Then we copy the
4508 stride and calculate the offset for this dimension. We also work out
4509 what the stride of a packed array would be, and see it the two match.
4510 If the array need repacking, we set the stride to the values we just
4511 calculated, recalculate the offset and copy the array data.
4512 Code is also added to copy the data back at the end of the function.
4516 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4523 stmtblock_t cleanup;
4531 tree stride, stride2;
4541 /* Do nothing for pointer and allocatable arrays. */
4542 if (sym->attr.pointer || sym->attr.allocatable)
4545 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4546 return gfc_trans_g77_array (sym, body);
4548 gfc_get_backend_locus (&loc);
4549 gfc_set_backend_locus (&sym->declared_at);
4551 /* Descriptor type. */
4552 type = TREE_TYPE (tmpdesc);
4553 gcc_assert (GFC_ARRAY_TYPE_P (type));
4554 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4555 dumdesc = build_fold_indirect_ref_loc (input_location,
4557 gfc_start_block (&block);
4559 if (sym->ts.type == BT_CHARACTER
4560 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4561 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4563 checkparm = (sym->as->type == AS_EXPLICIT
4564 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4566 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4567 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4569 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4571 /* For non-constant shape arrays we only check if the first dimension
4572 is contiguous. Repacking higher dimensions wouldn't gain us
4573 anything as we still don't know the array stride. */
4574 partial = gfc_create_var (boolean_type_node, "partial");
4575 TREE_USED (partial) = 1;
4576 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4577 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4578 gfc_add_modify (&block, partial, tmp);
4582 partial = NULL_TREE;
4585 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4586 here, however I think it does the right thing. */
4589 /* Set the first stride. */
4590 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4591 stride = gfc_evaluate_now (stride, &block);
4593 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4594 stride, gfc_index_zero_node);
4595 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4596 gfc_index_one_node, stride);
4597 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4598 gfc_add_modify (&block, stride, tmp);
4600 /* Allow the user to disable array repacking. */
4601 stmt_unpacked = NULL_TREE;
4605 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4606 /* A library call to repack the array if necessary. */
4607 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4608 stmt_unpacked = build_call_expr_loc (input_location,
4609 gfor_fndecl_in_pack, 1, tmp);
4611 stride = gfc_index_one_node;
4613 if (gfc_option.warn_array_temp)
4614 gfc_warning ("Creating array temporary at %L", &loc);
4617 /* This is for the case where the array data is used directly without
4618 calling the repack function. */
4619 if (no_repack || partial != NULL_TREE)
4620 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4622 stmt_packed = NULL_TREE;
4624 /* Assign the data pointer. */
4625 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4627 /* Don't repack unknown shape arrays when the first stride is 1. */
4628 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4629 partial, stmt_packed, stmt_unpacked);
4632 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4633 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4635 offset = gfc_index_zero_node;
4636 size = gfc_index_one_node;
4638 /* Evaluate the bounds of the array. */
4639 for (n = 0; n < sym->as->rank; n++)
4641 if (checkparm || !sym->as->upper[n])
4643 /* Get the bounds of the actual parameter. */
4644 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4645 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4649 dubound = NULL_TREE;
4650 dlbound = NULL_TREE;
4653 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4654 if (!INTEGER_CST_P (lbound))
4656 gfc_init_se (&se, NULL);
4657 gfc_conv_expr_type (&se, sym->as->lower[n],
4658 gfc_array_index_type);
4659 gfc_add_block_to_block (&block, &se.pre);
4660 gfc_add_modify (&block, lbound, se.expr);
4663 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4664 /* Set the desired upper bound. */
4665 if (sym->as->upper[n])
4667 /* We know what we want the upper bound to be. */
4668 if (!INTEGER_CST_P (ubound))
4670 gfc_init_se (&se, NULL);
4671 gfc_conv_expr_type (&se, sym->as->upper[n],
4672 gfc_array_index_type);
4673 gfc_add_block_to_block (&block, &se.pre);
4674 gfc_add_modify (&block, ubound, se.expr);
4677 /* Check the sizes match. */
4680 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4684 temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4686 temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4687 gfc_index_one_node, temp);
4689 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4691 stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4692 gfc_index_one_node, stride2);
4694 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
4695 asprintf (&msg, "Dimension %d of array '%s' has extent "
4696 "%%ld instead of %%ld", n+1, sym->name);
4698 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg,
4699 fold_convert (long_integer_type_node, temp),
4700 fold_convert (long_integer_type_node, stride2));
4707 /* For assumed shape arrays move the upper bound by the same amount
4708 as the lower bound. */
4709 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4711 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4712 gfc_add_modify (&block, ubound, tmp);
4714 /* The offset of this dimension. offset = offset - lbound * stride. */
4715 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4716 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4718 /* The size of this dimension, and the stride of the next. */
4719 if (n + 1 < sym->as->rank)
4721 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4723 if (no_repack || partial != NULL_TREE)
4726 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4729 /* Figure out the stride if not a known constant. */
4730 if (!INTEGER_CST_P (stride))
4733 stmt_packed = NULL_TREE;
4736 /* Calculate stride = size * (ubound + 1 - lbound). */
4737 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4738 gfc_index_one_node, lbound);
4739 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4741 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4746 /* Assign the stride. */
4747 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4748 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4749 stmt_unpacked, stmt_packed);
4751 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4752 gfc_add_modify (&block, stride, tmp);
4757 stride = GFC_TYPE_ARRAY_SIZE (type);
4759 if (stride && !INTEGER_CST_P (stride))
4761 /* Calculate size = stride * (ubound + 1 - lbound). */
4762 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4763 gfc_index_one_node, lbound);
4764 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4766 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4767 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4768 gfc_add_modify (&block, stride, tmp);
4773 /* Set the offset. */
4774 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4775 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4777 gfc_trans_vla_type_sizes (sym, &block);
4779 stmt = gfc_finish_block (&block);
4781 gfc_start_block (&block);
4783 /* Only do the entry/initialization code if the arg is present. */
4784 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4785 optional_arg = (sym->attr.optional
4786 || (sym->ns->proc_name->attr.entry_master
4787 && sym->attr.dummy));
4790 tmp = gfc_conv_expr_present (sym);
4791 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4793 gfc_add_expr_to_block (&block, stmt);
4795 /* Add the main function body. */
4796 gfc_add_expr_to_block (&block, body);
4801 gfc_start_block (&cleanup);
4803 if (sym->attr.intent != INTENT_IN)
4805 /* Copy the data back. */
4806 tmp = build_call_expr_loc (input_location,
4807 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4808 gfc_add_expr_to_block (&cleanup, tmp);
4811 /* Free the temporary. */
4812 tmp = gfc_call_free (tmpdesc);
4813 gfc_add_expr_to_block (&cleanup, tmp);
4815 stmt = gfc_finish_block (&cleanup);
4817 /* Only do the cleanup if the array was repacked. */
4818 tmp = build_fold_indirect_ref_loc (input_location,
4820 tmp = gfc_conv_descriptor_data_get (tmp);
4821 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4822 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4826 tmp = gfc_conv_expr_present (sym);
4827 stmt = build3_v (COND_EXPR, tmp, stmt,
4828 build_empty_stmt (input_location));
4830 gfc_add_expr_to_block (&block, stmt);
4832 /* We don't need to free any memory allocated by internal_pack as it will
4833 be freed at the end of the function by pop_context. */
4834 return gfc_finish_block (&block);
4838 /* Calculate the overall offset, including subreferences. */
4840 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4841 bool subref, gfc_expr *expr)
4851 /* If offset is NULL and this is not a subreferenced array, there is
4853 if (offset == NULL_TREE)
4856 offset = gfc_index_zero_node;
4861 tmp = gfc_conv_array_data (desc);
4862 tmp = build_fold_indirect_ref_loc (input_location,
4864 tmp = gfc_build_array_ref (tmp, offset, NULL);
4866 /* Offset the data pointer for pointer assignments from arrays with
4867 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4870 /* Go past the array reference. */
4871 for (ref = expr->ref; ref; ref = ref->next)
4872 if (ref->type == REF_ARRAY &&
4873 ref->u.ar.type != AR_ELEMENT)
4879 /* Calculate the offset for each subsequent subreference. */
4880 for (; ref; ref = ref->next)
4885 field = ref->u.c.component->backend_decl;
4886 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4887 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4888 tmp, field, NULL_TREE);
4892 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4893 gfc_init_se (&start, NULL);
4894 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4895 gfc_add_block_to_block (block, &start.pre);
4896 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4900 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4901 && ref->u.ar.type == AR_ELEMENT);
4903 /* TODO - Add bounds checking. */
4904 stride = gfc_index_one_node;
4905 index = gfc_index_zero_node;
4906 for (n = 0; n < ref->u.ar.dimen; n++)
4911 /* Update the index. */
4912 gfc_init_se (&start, NULL);
4913 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4914 itmp = gfc_evaluate_now (start.expr, block);
4915 gfc_init_se (&start, NULL);
4916 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4917 jtmp = gfc_evaluate_now (start.expr, block);
4918 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4919 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4920 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4921 index = gfc_evaluate_now (index, block);
4923 /* Update the stride. */
4924 gfc_init_se (&start, NULL);
4925 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4926 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4927 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4928 gfc_index_one_node, itmp);
4929 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4930 stride = gfc_evaluate_now (stride, block);
4933 /* Apply the index to obtain the array element. */
4934 tmp = gfc_build_array_ref (tmp, index, NULL);
4944 /* Set the target data pointer. */
4945 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4946 gfc_conv_descriptor_data_set (block, parm, offset);
4950 /* gfc_conv_expr_descriptor needs the string length an expression
4951 so that the size of the temporary can be obtained. This is done
4952 by adding up the string lengths of all the elements in the
4953 expression. Function with non-constant expressions have their
4954 string lengths mapped onto the actual arguments using the
4955 interface mapping machinery in trans-expr.c. */
4957 get_array_charlen (gfc_expr *expr, gfc_se *se)
4959 gfc_interface_mapping mapping;
4960 gfc_formal_arglist *formal;
4961 gfc_actual_arglist *arg;
4964 if (expr->ts.u.cl->length
4965 && gfc_is_constant_expr (expr->ts.u.cl->length))
4967 if (!expr->ts.u.cl->backend_decl)
4968 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4972 switch (expr->expr_type)
4975 get_array_charlen (expr->value.op.op1, se);
4977 /* For parentheses the expression ts.u.cl is identical. */
4978 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4981 expr->ts.u.cl->backend_decl =
4982 gfc_create_var (gfc_charlen_type_node, "sln");
4984 if (expr->value.op.op2)
4986 get_array_charlen (expr->value.op.op2, se);
4988 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4990 /* Add the string lengths and assign them to the expression
4991 string length backend declaration. */
4992 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4993 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4994 expr->value.op.op1->ts.u.cl->backend_decl,
4995 expr->value.op.op2->ts.u.cl->backend_decl));
4998 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4999 expr->value.op.op1->ts.u.cl->backend_decl);
5003 if (expr->value.function.esym == NULL
5004 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5006 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5010 /* Map expressions involving the dummy arguments onto the actual
5011 argument expressions. */
5012 gfc_init_interface_mapping (&mapping);
5013 formal = expr->symtree->n.sym->formal;
5014 arg = expr->value.function.actual;
5016 /* Set se = NULL in the calls to the interface mapping, to suppress any
5018 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5023 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5026 gfc_init_se (&tse, NULL);
5028 /* Build the expression for the character length and convert it. */
5029 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5031 gfc_add_block_to_block (&se->pre, &tse.pre);
5032 gfc_add_block_to_block (&se->post, &tse.post);
5033 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5034 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
5035 build_int_cst (gfc_charlen_type_node, 0));
5036 expr->ts.u.cl->backend_decl = tse.expr;
5037 gfc_free_interface_mapping (&mapping);
5041 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5048 /* Convert an array for passing as an actual argument. Expressions and
5049 vector subscripts are evaluated and stored in a temporary, which is then
5050 passed. For whole arrays the descriptor is passed. For array sections
5051 a modified copy of the descriptor is passed, but using the original data.
5053 This function is also used for array pointer assignments, and there
5056 - se->want_pointer && !se->direct_byref
5057 EXPR is an actual argument. On exit, se->expr contains a
5058 pointer to the array descriptor.
5060 - !se->want_pointer && !se->direct_byref
5061 EXPR is an actual argument to an intrinsic function or the
5062 left-hand side of a pointer assignment. On exit, se->expr
5063 contains the descriptor for EXPR.
5065 - !se->want_pointer && se->direct_byref
5066 EXPR is the right-hand side of a pointer assignment and
5067 se->expr is the descriptor for the previously-evaluated
5068 left-hand side. The function creates an assignment from
5069 EXPR to se->expr. */
5072 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5085 bool subref_array_target = false;
5087 gcc_assert (ss != gfc_ss_terminator);
5089 /* Special case things we know we can pass easily. */
5090 switch (expr->expr_type)
5093 /* If we have a linear array section, we can pass it directly.
5094 Otherwise we need to copy it into a temporary. */
5096 /* Find the SS for the array section. */
5098 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5099 secss = secss->next;
5101 gcc_assert (secss != gfc_ss_terminator);
5102 info = &secss->data.info;
5104 /* Get the descriptor for the array. */
5105 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5106 desc = info->descriptor;
5108 subref_array_target = se->direct_byref && is_subref_array (expr);
5109 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5110 && !subref_array_target;
5114 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5116 /* Create a new descriptor if the array doesn't have one. */
5119 else if (info->ref->u.ar.type == AR_FULL)
5121 else if (se->direct_byref)
5124 full = gfc_full_array_ref_p (info->ref, NULL);
5128 if (se->direct_byref)
5130 /* Copy the descriptor for pointer assignments. */
5131 gfc_add_modify (&se->pre, se->expr, desc);
5133 /* Add any offsets from subreferences. */
5134 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5135 subref_array_target, expr);
5137 else if (se->want_pointer)
5139 /* We pass full arrays directly. This means that pointers and
5140 allocatable arrays should also work. */
5141 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5148 if (expr->ts.type == BT_CHARACTER)
5149 se->string_length = gfc_get_expr_charlen (expr);
5156 /* A transformational function return value will be a temporary
5157 array descriptor. We still need to go through the scalarizer
5158 to create the descriptor. Elemental functions ar handled as
5159 arbitrary expressions, i.e. copy to a temporary. */
5161 /* Look for the SS for this function. */
5162 while (secss != gfc_ss_terminator
5163 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5164 secss = secss->next;
5166 if (se->direct_byref)
5168 gcc_assert (secss != gfc_ss_terminator);
5170 /* For pointer assignments pass the descriptor directly. */
5172 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5173 gfc_conv_expr (se, expr);
5177 if (secss == gfc_ss_terminator)
5179 /* Elemental function. */
5181 if (expr->ts.type == BT_CHARACTER
5182 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5183 get_array_charlen (expr, se);
5189 /* Transformational function. */
5190 info = &secss->data.info;
5196 /* Constant array constructors don't need a temporary. */
5197 if (ss->type == GFC_SS_CONSTRUCTOR
5198 && expr->ts.type != BT_CHARACTER
5199 && gfc_constant_array_constructor_p (expr->value.constructor))
5202 info = &ss->data.info;
5214 /* Something complicated. Copy it into a temporary. */
5221 gfc_init_loopinfo (&loop);
5223 /* Associate the SS with the loop. */
5224 gfc_add_ss_to_loop (&loop, ss);
5226 /* Tell the scalarizer not to bother creating loop variables, etc. */
5228 loop.array_parameter = 1;
5230 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5231 gcc_assert (!se->direct_byref);
5233 /* Setup the scalarizing loops and bounds. */
5234 gfc_conv_ss_startstride (&loop);
5238 /* Tell the scalarizer to make a temporary. */
5239 loop.temp_ss = gfc_get_ss ();
5240 loop.temp_ss->type = GFC_SS_TEMP;
5241 loop.temp_ss->next = gfc_ss_terminator;
5243 if (expr->ts.type == BT_CHARACTER
5244 && !expr->ts.u.cl->backend_decl)
5245 get_array_charlen (expr, se);
5247 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5249 if (expr->ts.type == BT_CHARACTER)
5250 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5252 loop.temp_ss->string_length = NULL;
5254 se->string_length = loop.temp_ss->string_length;
5255 loop.temp_ss->data.temp.dimen = loop.dimen;
5256 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5259 gfc_conv_loop_setup (&loop, & expr->where);
5263 /* Copy into a temporary and pass that. We don't need to copy the data
5264 back because expressions and vector subscripts must be INTENT_IN. */
5265 /* TODO: Optimize passing function return values. */
5269 /* Start the copying loops. */
5270 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5271 gfc_mark_ss_chain_used (ss, 1);
5272 gfc_start_scalarized_body (&loop, &block);
5274 /* Copy each data element. */
5275 gfc_init_se (&lse, NULL);
5276 gfc_copy_loopinfo_to_se (&lse, &loop);
5277 gfc_init_se (&rse, NULL);
5278 gfc_copy_loopinfo_to_se (&rse, &loop);
5280 lse.ss = loop.temp_ss;
5283 gfc_conv_scalarized_array_ref (&lse, NULL);
5284 if (expr->ts.type == BT_CHARACTER)
5286 gfc_conv_expr (&rse, expr);
5287 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5288 rse.expr = build_fold_indirect_ref_loc (input_location,
5292 gfc_conv_expr_val (&rse, expr);
5294 gfc_add_block_to_block (&block, &rse.pre);
5295 gfc_add_block_to_block (&block, &lse.pre);
5297 lse.string_length = rse.string_length;
5298 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5299 expr->expr_type == EXPR_VARIABLE, true);
5300 gfc_add_expr_to_block (&block, tmp);
5302 /* Finish the copying loops. */
5303 gfc_trans_scalarizing_loops (&loop, &block);
5305 desc = loop.temp_ss->data.info.descriptor;
5307 gcc_assert (is_gimple_lvalue (desc));
5309 else if (expr->expr_type == EXPR_FUNCTION)
5311 desc = info->descriptor;
5312 se->string_length = ss->string_length;
5316 /* We pass sections without copying to a temporary. Make a new
5317 descriptor and point it at the section we want. The loop variable
5318 limits will be the limits of the section.
5319 A function may decide to repack the array to speed up access, but
5320 we're not bothered about that here. */
5329 /* Set the string_length for a character array. */
5330 if (expr->ts.type == BT_CHARACTER)
5331 se->string_length = gfc_get_expr_charlen (expr);
5333 desc = info->descriptor;
5334 gcc_assert (secss && secss != gfc_ss_terminator);
5335 if (se->direct_byref)
5337 /* For pointer assignments we fill in the destination. */
5339 parmtype = TREE_TYPE (parm);
5343 /* Otherwise make a new one. */
5344 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5345 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5346 loop.from, loop.to, 0,
5347 GFC_ARRAY_UNKNOWN, false);
5348 parm = gfc_create_var (parmtype, "parm");
5351 offset = gfc_index_zero_node;
5354 /* The following can be somewhat confusing. We have two
5355 descriptors, a new one and the original array.
5356 {parm, parmtype, dim} refer to the new one.
5357 {desc, type, n, secss, loop} refer to the original, which maybe
5358 a descriptorless array.
5359 The bounds of the scalarization are the bounds of the section.
5360 We don't have to worry about numeric overflows when calculating
5361 the offsets because all elements are within the array data. */
5363 /* Set the dtype. */
5364 tmp = gfc_conv_descriptor_dtype (parm);
5365 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5367 /* Set offset for assignments to pointer only to zero if it is not
5369 if (se->direct_byref
5370 && info->ref && info->ref->u.ar.type != AR_FULL)
5371 base = gfc_index_zero_node;
5372 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5373 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5377 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5378 for (n = 0; n < ndim; n++)
5380 stride = gfc_conv_array_stride (desc, n);
5382 /* Work out the offset. */
5384 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5386 gcc_assert (info->subscript[n]
5387 && info->subscript[n]->type == GFC_SS_SCALAR);
5388 start = info->subscript[n]->data.scalar.expr;
5392 /* Check we haven't somehow got out of sync. */
5393 gcc_assert (info->dim[dim] == n);
5395 /* Evaluate and remember the start of the section. */
5396 start = info->start[dim];
5397 stride = gfc_evaluate_now (stride, &loop.pre);
5400 tmp = gfc_conv_array_lbound (desc, n);
5401 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5403 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5404 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5407 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5409 /* For elemental dimensions, we only need the offset. */
5413 /* Vector subscripts need copying and are handled elsewhere. */
5415 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5417 /* Set the new lower bound. */
5418 from = loop.from[dim];
5421 /* If we have an array section or are assigning make sure that
5422 the lower bound is 1. References to the full
5423 array should otherwise keep the original bounds. */
5425 || info->ref->u.ar.type != AR_FULL)
5426 && !integer_onep (from))
5428 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5429 gfc_index_one_node, from);
5430 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5431 from = gfc_index_one_node;
5433 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5434 gfc_rank_cst[dim], from);
5436 /* Set the new upper bound. */
5437 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5438 gfc_rank_cst[dim], to);
5440 /* Multiply the stride by the section stride to get the
5442 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5443 stride, info->stride[dim]);
5445 if (se->direct_byref
5447 && info->ref->u.ar.type != AR_FULL)
5449 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5452 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5454 tmp = gfc_conv_array_lbound (desc, n);
5455 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5456 tmp, loop.from[dim]);
5457 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5458 tmp, gfc_conv_array_stride (desc, n));
5459 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5463 /* Store the new stride. */
5464 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5465 gfc_rank_cst[dim], stride);
5470 if (se->data_not_needed)
5471 gfc_conv_descriptor_data_set (&loop.pre, parm,
5472 gfc_index_zero_node);
5474 /* Point the data pointer at the 1st element in the section. */
5475 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5476 subref_array_target, expr);
5478 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5479 && !se->data_not_needed)
5481 /* Set the offset. */
5482 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5486 /* Only the callee knows what the correct offset it, so just set
5488 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5493 if (!se->direct_byref)
5495 /* Get a pointer to the new descriptor. */
5496 if (se->want_pointer)
5497 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5502 gfc_add_block_to_block (&se->pre, &loop.pre);
5503 gfc_add_block_to_block (&se->post, &loop.post);
5505 /* Cleanup the scalarizer. */
5506 gfc_cleanup_loop (&loop);
5509 /* Helper function for gfc_conv_array_parameter if array size needs to be
5513 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5516 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5517 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5518 else if (expr->rank > 1)
5519 *size = build_call_expr_loc (input_location,
5520 gfor_fndecl_size0, 1,
5521 gfc_build_addr_expr (NULL, desc));
5524 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5525 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5527 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5528 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5529 gfc_index_one_node);
5530 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5531 gfc_index_zero_node);
5533 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5534 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5535 fold_convert (gfc_array_index_type, elem));
5538 /* Convert an array for passing as an actual parameter. */
5539 /* TODO: Optimize passing g77 arrays. */
5542 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5543 const gfc_symbol *fsym, const char *proc_name,
5548 tree tmp = NULL_TREE;
5550 tree parent = DECL_CONTEXT (current_function_decl);
5551 bool full_array_var;
5552 bool this_array_result;
5555 bool array_constructor;
5556 bool good_allocatable;
5557 bool ultimate_ptr_comp;
5558 bool ultimate_alloc_comp;
5563 ultimate_ptr_comp = false;
5564 ultimate_alloc_comp = false;
5565 for (ref = expr->ref; ref; ref = ref->next)
5567 if (ref->next == NULL)
5570 if (ref->type == REF_COMPONENT)
5572 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5573 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5577 full_array_var = false;
5580 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5581 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5583 sym = full_array_var ? expr->symtree->n.sym : NULL;
5585 /* The symbol should have an array specification. */
5586 gcc_assert (!sym || sym->as || ref->u.ar.as);
5588 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5590 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5591 expr->ts.u.cl->backend_decl = tmp;
5592 se->string_length = tmp;
5595 /* Is this the result of the enclosing procedure? */
5596 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5597 if (this_array_result
5598 && (sym->backend_decl != current_function_decl)
5599 && (sym->backend_decl != parent))
5600 this_array_result = false;
5602 /* Passing address of the array if it is not pointer or assumed-shape. */
5603 if (full_array_var && g77 && !this_array_result)
5605 tmp = gfc_get_symbol_decl (sym);
5607 if (sym->ts.type == BT_CHARACTER)
5608 se->string_length = sym->ts.u.cl->backend_decl;
5610 if (sym->ts.type == BT_DERIVED)
5612 gfc_conv_expr_descriptor (se, expr, ss);
5613 se->expr = gfc_conv_array_data (se->expr);
5617 if (!sym->attr.pointer
5619 && sym->as->type != AS_ASSUMED_SHAPE
5620 && !sym->attr.allocatable)
5622 /* Some variables are declared directly, others are declared as
5623 pointers and allocated on the heap. */
5624 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5627 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5629 array_parameter_size (tmp, expr, size);
5633 if (sym->attr.allocatable)
5635 if (sym->attr.dummy || sym->attr.result)
5637 gfc_conv_expr_descriptor (se, expr, ss);
5641 array_parameter_size (tmp, expr, size);
5642 se->expr = gfc_conv_array_data (tmp);
5647 /* A convenient reduction in scope. */
5648 contiguous = g77 && !this_array_result && contiguous;
5650 /* There is no need to pack and unpack the array, if it is contiguous
5651 and not deferred or assumed shape. */
5652 no_pack = ((sym && sym->as
5653 && !sym->attr.pointer
5654 && sym->as->type != AS_DEFERRED
5655 && sym->as->type != AS_ASSUMED_SHAPE)
5657 (ref && ref->u.ar.as
5658 && ref->u.ar.as->type != AS_DEFERRED
5659 && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
5661 no_pack = contiguous && no_pack;
5663 /* Array constructors are always contiguous and do not need packing. */
5664 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5666 /* Same is true of contiguous sections from allocatable variables. */
5667 good_allocatable = contiguous
5669 && expr->symtree->n.sym->attr.allocatable;
5671 /* Or ultimate allocatable components. */
5672 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5674 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5676 gfc_conv_expr_descriptor (se, expr, ss);
5677 if (expr->ts.type == BT_CHARACTER)
5678 se->string_length = expr->ts.u.cl->backend_decl;
5680 array_parameter_size (se->expr, expr, size);
5681 se->expr = gfc_conv_array_data (se->expr);
5685 if (this_array_result)
5687 /* Result of the enclosing function. */
5688 gfc_conv_expr_descriptor (se, expr, ss);
5690 array_parameter_size (se->expr, expr, size);
5691 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5693 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5694 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5695 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5702 /* Every other type of array. */
5703 se->want_pointer = 1;
5704 gfc_conv_expr_descriptor (se, expr, ss);
5706 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5711 /* Deallocate the allocatable components of structures that are
5713 if (expr->ts.type == BT_DERIVED
5714 && expr->ts.u.derived->attr.alloc_comp
5715 && expr->expr_type != EXPR_VARIABLE)
5717 tmp = build_fold_indirect_ref_loc (input_location,
5719 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5720 gfc_add_expr_to_block (&se->post, tmp);
5726 /* Repack the array. */
5727 if (gfc_option.warn_array_temp)
5730 gfc_warning ("Creating array temporary at %L for argument '%s'",
5731 &expr->where, fsym->name);
5733 gfc_warning ("Creating array temporary at %L", &expr->where);
5736 ptr = build_call_expr_loc (input_location,
5737 gfor_fndecl_in_pack, 1, desc);
5739 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5741 tmp = gfc_conv_expr_present (sym);
5742 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5743 fold_convert (TREE_TYPE (se->expr), ptr),
5744 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5747 ptr = gfc_evaluate_now (ptr, &se->pre);
5751 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5755 if (fsym && proc_name)
5756 asprintf (&msg, "An array temporary was created for argument "
5757 "'%s' of procedure '%s'", fsym->name, proc_name);
5759 asprintf (&msg, "An array temporary was created");
5761 tmp = build_fold_indirect_ref_loc (input_location,
5763 tmp = gfc_conv_array_data (tmp);
5764 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5765 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5767 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5768 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5769 gfc_conv_expr_present (sym), tmp);
5771 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5776 gfc_start_block (&block);
5778 /* Copy the data back. */
5779 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5781 tmp = build_call_expr_loc (input_location,
5782 gfor_fndecl_in_unpack, 2, desc, ptr);
5783 gfc_add_expr_to_block (&block, tmp);
5786 /* Free the temporary. */
5787 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5788 gfc_add_expr_to_block (&block, tmp);
5790 stmt = gfc_finish_block (&block);
5792 gfc_init_block (&block);
5793 /* Only if it was repacked. This code needs to be executed before the
5794 loop cleanup code. */
5795 tmp = build_fold_indirect_ref_loc (input_location,
5797 tmp = gfc_conv_array_data (tmp);
5798 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5799 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5801 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5802 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5803 gfc_conv_expr_present (sym), tmp);
5805 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5807 gfc_add_expr_to_block (&block, tmp);
5808 gfc_add_block_to_block (&block, &se->post);
5810 gfc_init_block (&se->post);
5811 gfc_add_block_to_block (&se->post, &block);
5816 /* Generate code to deallocate an array, if it is allocated. */
5819 gfc_trans_dealloc_allocated (tree descriptor)
5825 gfc_start_block (&block);
5827 var = gfc_conv_descriptor_data_get (descriptor);
5830 /* Call array_deallocate with an int * present in the second argument.
5831 Although it is ignored here, it's presence ensures that arrays that
5832 are already deallocated are ignored. */
5833 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5834 gfc_add_expr_to_block (&block, tmp);
5836 /* Zero the data pointer. */
5837 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5838 var, build_int_cst (TREE_TYPE (var), 0));
5839 gfc_add_expr_to_block (&block, tmp);
5841 return gfc_finish_block (&block);
5845 /* This helper function calculates the size in words of a full array. */
5848 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5853 idx = gfc_rank_cst[rank - 1];
5854 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5855 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5856 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5857 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5858 tmp, gfc_index_one_node);
5859 tmp = gfc_evaluate_now (tmp, block);
5861 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5862 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5863 return gfc_evaluate_now (tmp, block);
5867 /* Allocate dest to the same size as src, and copy src -> dest.
5868 If no_malloc is set, only the copy is done. */
5871 duplicate_allocatable(tree dest, tree src, tree type, int rank,
5881 /* If the source is null, set the destination to null. Then,
5882 allocate memory to the destination. */
5883 gfc_init_block (&block);
5887 tmp = null_pointer_node;
5888 tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
5889 gfc_add_expr_to_block (&block, tmp);
5890 null_data = gfc_finish_block (&block);
5892 gfc_init_block (&block);
5893 size = TYPE_SIZE_UNIT (type);
5896 tmp = gfc_call_malloc (&block, type, size);
5897 tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
5898 fold_convert (type, tmp));
5899 gfc_add_expr_to_block (&block, tmp);
5902 tmp = built_in_decls[BUILT_IN_MEMCPY];
5903 tmp = build_call_expr_loc (input_location, tmp, 3,
5908 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5909 null_data = gfc_finish_block (&block);
5911 gfc_init_block (&block);
5912 nelems = get_full_array_size (&block, src, rank);
5913 tmp = fold_convert (gfc_array_index_type,
5914 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
5915 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5918 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
5919 tmp = gfc_call_malloc (&block, tmp, size);
5920 gfc_conv_descriptor_data_set (&block, dest, tmp);
5923 /* We know the temporary and the value will be the same length,
5924 so can use memcpy. */
5925 tmp = built_in_decls[BUILT_IN_MEMCPY];
5926 tmp = build_call_expr_loc (input_location,
5927 tmp, 3, gfc_conv_descriptor_data_get (dest),
5928 gfc_conv_descriptor_data_get (src), size);
5931 gfc_add_expr_to_block (&block, tmp);
5932 tmp = gfc_finish_block (&block);
5934 /* Null the destination if the source is null; otherwise do
5935 the allocate and copy. */
5939 null_cond = gfc_conv_descriptor_data_get (src);
5941 null_cond = convert (pvoid_type_node, null_cond);
5942 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5943 null_cond, null_pointer_node);
5944 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5948 /* Allocate dest to the same size as src, and copy data src -> dest. */
5951 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
5953 return duplicate_allocatable(dest, src, type, rank, false);
5957 /* Copy data src -> dest. */
5960 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
5962 return duplicate_allocatable(dest, src, type, rank, true);
5966 /* Recursively traverse an object of derived type, generating code to
5967 deallocate, nullify or copy allocatable components. This is the work horse
5968 function for the functions named in this enum. */
5970 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
5971 COPY_ONLY_ALLOC_COMP};
5974 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5975 tree dest, int rank, int purpose)
5979 stmtblock_t fnblock;
5980 stmtblock_t loopbody;
5990 tree null_cond = NULL_TREE;
5992 gfc_init_block (&fnblock);
5994 if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
5995 decl = build_fold_indirect_ref_loc (input_location,
5998 /* If this an array of derived types with allocatable components
5999 build a loop and recursively call this function. */
6000 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
6001 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
6003 tmp = gfc_conv_array_data (decl);
6004 var = build_fold_indirect_ref_loc (input_location,
6007 /* Get the number of elements - 1 and set the counter. */
6008 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
6010 /* Use the descriptor for an allocatable array. Since this
6011 is a full array reference, we only need the descriptor
6012 information from dimension = rank. */
6013 tmp = get_full_array_size (&fnblock, decl, rank);
6014 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
6015 tmp, gfc_index_one_node);
6017 null_cond = gfc_conv_descriptor_data_get (decl);
6018 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
6019 build_int_cst (TREE_TYPE (null_cond), 0));
6023 /* Otherwise use the TYPE_DOMAIN information. */
6024 tmp = array_type_nelts (TREE_TYPE (decl));
6025 tmp = fold_convert (gfc_array_index_type, tmp);
6028 /* Remember that this is, in fact, the no. of elements - 1. */
6029 nelems = gfc_evaluate_now (tmp, &fnblock);
6030 index = gfc_create_var (gfc_array_index_type, "S");
6032 /* Build the body of the loop. */
6033 gfc_init_block (&loopbody);
6035 vref = gfc_build_array_ref (var, index, NULL);
6037 if (purpose == COPY_ALLOC_COMP)
6039 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6041 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
6042 gfc_add_expr_to_block (&fnblock, tmp);
6044 tmp = build_fold_indirect_ref_loc (input_location,
6045 gfc_conv_array_data (dest));
6046 dref = gfc_build_array_ref (tmp, index, NULL);
6047 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6049 else if (purpose == COPY_ONLY_ALLOC_COMP)
6051 tmp = build_fold_indirect_ref_loc (input_location,
6052 gfc_conv_array_data (dest));
6053 dref = gfc_build_array_ref (tmp, index, NULL);
6054 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6058 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6060 gfc_add_expr_to_block (&loopbody, tmp);
6062 /* Build the loop and return. */
6063 gfc_init_loopinfo (&loop);
6065 loop.from[0] = gfc_index_zero_node;
6066 loop.loopvar[0] = index;
6067 loop.to[0] = nelems;
6068 gfc_trans_scalarizing_loops (&loop, &loopbody);
6069 gfc_add_block_to_block (&fnblock, &loop.pre);
6071 tmp = gfc_finish_block (&fnblock);
6072 if (null_cond != NULL_TREE)
6073 tmp = build3_v (COND_EXPR, null_cond, tmp,
6074 build_empty_stmt (input_location));
6079 /* Otherwise, act on the components or recursively call self to
6080 act on a chain of components. */
6081 for (c = der_type->components; c; c = c->next)
6083 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6084 && c->ts.u.derived->attr.alloc_comp;
6085 cdecl = c->backend_decl;
6086 ctype = TREE_TYPE (cdecl);
6090 case DEALLOCATE_ALLOC_COMP:
6091 /* Do not deallocate the components of ultimate pointer
6093 if (cmp_has_alloc_comps && !c->attr.pointer)
6095 comp = fold_build3 (COMPONENT_REF, ctype,
6096 decl, cdecl, NULL_TREE);
6097 rank = c->as ? c->as->rank : 0;
6098 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6100 gfc_add_expr_to_block (&fnblock, tmp);
6103 if (c->attr.allocatable && c->attr.dimension)
6105 comp = fold_build3 (COMPONENT_REF, ctype,
6106 decl, cdecl, NULL_TREE);
6107 tmp = gfc_trans_dealloc_allocated (comp);
6108 gfc_add_expr_to_block (&fnblock, tmp);
6110 else if (c->attr.allocatable)
6112 /* Allocatable scalar components. */
6113 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6115 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6116 gfc_add_expr_to_block (&fnblock, tmp);
6118 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6119 build_int_cst (TREE_TYPE (comp), 0));
6120 gfc_add_expr_to_block (&fnblock, tmp);
6122 else if (c->ts.type == BT_CLASS
6123 && c->ts.u.derived->components->attr.allocatable)
6125 /* Allocatable scalar CLASS components. */
6126 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6128 /* Add reference to '$data' component. */
6129 tmp = c->ts.u.derived->components->backend_decl;
6130 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6131 comp, tmp, NULL_TREE);
6133 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6134 gfc_add_expr_to_block (&fnblock, tmp);
6136 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6137 build_int_cst (TREE_TYPE (comp), 0));
6138 gfc_add_expr_to_block (&fnblock, tmp);
6142 case NULLIFY_ALLOC_COMP:
6143 if (c->attr.pointer)
6145 else if (c->attr.allocatable && c->attr.dimension)
6147 comp = fold_build3 (COMPONENT_REF, ctype,
6148 decl, cdecl, NULL_TREE);
6149 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6151 else if (c->attr.allocatable)
6153 /* Allocatable scalar components. */
6154 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6155 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6156 build_int_cst (TREE_TYPE (comp), 0));
6157 gfc_add_expr_to_block (&fnblock, tmp);
6159 else if (c->ts.type == BT_CLASS
6160 && c->ts.u.derived->components->attr.allocatable)
6162 /* Allocatable scalar CLASS components. */
6163 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6164 /* Add reference to '$data' component. */
6165 tmp = c->ts.u.derived->components->backend_decl;
6166 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6167 comp, tmp, NULL_TREE);
6168 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6169 build_int_cst (TREE_TYPE (comp), 0));
6170 gfc_add_expr_to_block (&fnblock, tmp);
6172 else if (cmp_has_alloc_comps)
6174 comp = fold_build3 (COMPONENT_REF, ctype,
6175 decl, cdecl, NULL_TREE);
6176 rank = c->as ? c->as->rank : 0;
6177 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6179 gfc_add_expr_to_block (&fnblock, tmp);
6183 case COPY_ALLOC_COMP:
6184 if (c->attr.pointer)
6187 /* We need source and destination components. */
6188 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6189 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
6190 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6192 if (c->attr.allocatable && !cmp_has_alloc_comps)
6194 rank = c->as ? c->as->rank : 0;
6195 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
6196 gfc_add_expr_to_block (&fnblock, tmp);
6199 if (cmp_has_alloc_comps)
6201 rank = c->as ? c->as->rank : 0;
6202 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6203 gfc_add_modify (&fnblock, dcmp, tmp);
6204 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6206 gfc_add_expr_to_block (&fnblock, tmp);
6216 return gfc_finish_block (&fnblock);
6219 /* Recursively traverse an object of derived type, generating code to
6220 nullify allocatable components. */
6223 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6225 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6226 NULLIFY_ALLOC_COMP);
6230 /* Recursively traverse an object of derived type, generating code to
6231 deallocate allocatable components. */
6234 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6236 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6237 DEALLOCATE_ALLOC_COMP);
6241 /* Recursively traverse an object of derived type, generating code to
6242 copy it and its allocatable components. */
6245 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6247 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6251 /* Recursively traverse an object of derived type, generating code to
6252 copy only its allocatable components. */
6255 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6257 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6261 /* Check for default initializer; sym->value is not enough as it is also
6262 set for EXPR_NULL of allocatables. */
6265 has_default_initializer (gfc_symbol *der)
6269 gcc_assert (der->attr.flavor == FL_DERIVED);
6270 for (c = der->components; c; c = c->next)
6271 if ((c->ts.type != BT_DERIVED && c->initializer)
6272 || (c->ts.type == BT_DERIVED
6273 && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
6280 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6281 Do likewise, recursively if necessary, with the allocatable components of
6285 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
6290 stmtblock_t fnblock;
6293 bool sym_has_alloc_comp;
6295 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6296 && sym->ts.u.derived->attr.alloc_comp;
6298 /* Make sure the frontend gets these right. */
6299 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6300 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6301 "allocatable attribute or derived type without allocatable "
6304 gfc_init_block (&fnblock);
6306 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6307 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6309 if (sym->ts.type == BT_CHARACTER
6310 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6312 gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
6313 gfc_trans_vla_type_sizes (sym, &fnblock);
6316 /* Dummy, use associated and result variables don't need anything special. */
6317 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6319 gfc_add_expr_to_block (&fnblock, body);
6321 return gfc_finish_block (&fnblock);
6324 gfc_get_backend_locus (&loc);
6325 gfc_set_backend_locus (&sym->declared_at);
6326 descriptor = sym->backend_decl;
6328 /* Although static, derived types with default initializers and
6329 allocatable components must not be nulled wholesale; instead they
6330 are treated component by component. */
6331 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6333 /* SAVEd variables are not freed on exit. */
6334 gfc_trans_static_array_pointer (sym);
6338 /* Get the descriptor type. */
6339 type = TREE_TYPE (sym->backend_decl);
6341 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6344 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6346 if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived))
6348 rank = sym->as ? sym->as->rank : 0;
6349 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
6350 gfc_add_expr_to_block (&fnblock, tmp);
6354 tmp = gfc_init_default_dt (sym, NULL, false);
6355 gfc_add_expr_to_block (&fnblock, tmp);
6359 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6361 /* If the backend_decl is not a descriptor, we must have a pointer
6363 descriptor = build_fold_indirect_ref_loc (input_location,
6365 type = TREE_TYPE (descriptor);
6368 /* NULLIFY the data pointer. */
6369 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6370 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
6372 gfc_add_expr_to_block (&fnblock, body);
6374 gfc_set_backend_locus (&loc);
6376 /* Allocatable arrays need to be freed when they go out of scope.
6377 The allocatable components of pointers must not be touched. */
6378 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6379 && !sym->attr.pointer && !sym->attr.save)
6382 rank = sym->as ? sym->as->rank : 0;
6383 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6384 gfc_add_expr_to_block (&fnblock, tmp);
6387 if (sym->attr.allocatable && sym->attr.dimension
6388 && !sym->attr.save && !sym->attr.result)
6390 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6391 gfc_add_expr_to_block (&fnblock, tmp);
6394 return gfc_finish_block (&fnblock);
6397 /************ Expression Walking Functions ******************/
6399 /* Walk a variable reference.
6401 Possible extension - multiple component subscripts.
6402 x(:,:) = foo%a(:)%b(:)
6404 forall (i=..., j=...)
6405 x(i,j) = foo%a(j)%b(i)
6407 This adds a fair amount of complexity because you need to deal with more
6408 than one ref. Maybe handle in a similar manner to vector subscripts.
6409 Maybe not worth the effort. */
6413 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6420 for (ref = expr->ref; ref; ref = ref->next)
6421 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6424 for (; ref; ref = ref->next)
6426 if (ref->type == REF_SUBSTRING)
6428 newss = gfc_get_ss ();
6429 newss->type = GFC_SS_SCALAR;
6430 newss->expr = ref->u.ss.start;
6434 newss = gfc_get_ss ();
6435 newss->type = GFC_SS_SCALAR;
6436 newss->expr = ref->u.ss.end;
6441 /* We're only interested in array sections from now on. */
6442 if (ref->type != REF_ARRAY)
6447 if (ar->as->rank == 0)
6449 /* Scalar coarray. */
6456 for (n = 0; n < ar->dimen; n++)
6458 newss = gfc_get_ss ();
6459 newss->type = GFC_SS_SCALAR;
6460 newss->expr = ar->start[n];
6467 newss = gfc_get_ss ();
6468 newss->type = GFC_SS_SECTION;
6471 newss->data.info.dimen = ar->as->rank;
6472 newss->data.info.ref = ref;
6474 /* Make sure array is the same as array(:,:), this way
6475 we don't need to special case all the time. */
6476 ar->dimen = ar->as->rank;
6477 for (n = 0; n < ar->dimen; n++)
6479 newss->data.info.dim[n] = n;
6480 ar->dimen_type[n] = DIMEN_RANGE;
6482 gcc_assert (ar->start[n] == NULL);
6483 gcc_assert (ar->end[n] == NULL);
6484 gcc_assert (ar->stride[n] == NULL);
6490 newss = gfc_get_ss ();
6491 newss->type = GFC_SS_SECTION;
6494 newss->data.info.dimen = 0;
6495 newss->data.info.ref = ref;
6497 /* We add SS chains for all the subscripts in the section. */
6498 for (n = 0; n < ar->dimen; n++)
6502 switch (ar->dimen_type[n])
6505 /* Add SS for elemental (scalar) subscripts. */
6506 gcc_assert (ar->start[n]);
6507 indexss = gfc_get_ss ();
6508 indexss->type = GFC_SS_SCALAR;
6509 indexss->expr = ar->start[n];
6510 indexss->next = gfc_ss_terminator;
6511 indexss->loop_chain = gfc_ss_terminator;
6512 newss->data.info.subscript[n] = indexss;
6516 /* We don't add anything for sections, just remember this
6517 dimension for later. */
6518 newss->data.info.dim[newss->data.info.dimen] = n;
6519 newss->data.info.dimen++;
6523 /* Create a GFC_SS_VECTOR index in which we can store
6524 the vector's descriptor. */
6525 indexss = gfc_get_ss ();
6526 indexss->type = GFC_SS_VECTOR;
6527 indexss->expr = ar->start[n];
6528 indexss->next = gfc_ss_terminator;
6529 indexss->loop_chain = gfc_ss_terminator;
6530 newss->data.info.subscript[n] = indexss;
6531 newss->data.info.dim[newss->data.info.dimen] = n;
6532 newss->data.info.dimen++;
6536 /* We should know what sort of section it is by now. */
6540 /* We should have at least one non-elemental dimension. */
6541 gcc_assert (newss->data.info.dimen > 0);
6546 /* We should know what sort of section it is by now. */
6555 /* Walk an expression operator. If only one operand of a binary expression is
6556 scalar, we must also add the scalar term to the SS chain. */
6559 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6565 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6566 if (expr->value.op.op2 == NULL)
6569 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6571 /* All operands are scalar. Pass back and let the caller deal with it. */
6575 /* All operands require scalarization. */
6576 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6579 /* One of the operands needs scalarization, the other is scalar.
6580 Create a gfc_ss for the scalar expression. */
6581 newss = gfc_get_ss ();
6582 newss->type = GFC_SS_SCALAR;
6585 /* First operand is scalar. We build the chain in reverse order, so
6586 add the scalar SS after the second operand. */
6588 while (head && head->next != ss)
6590 /* Check we haven't somehow broken the chain. */
6594 newss->expr = expr->value.op.op1;
6596 else /* head2 == head */
6598 gcc_assert (head2 == head);
6599 /* Second operand is scalar. */
6600 newss->next = head2;
6602 newss->expr = expr->value.op.op2;
6609 /* Reverse a SS chain. */
6612 gfc_reverse_ss (gfc_ss * ss)
6617 gcc_assert (ss != NULL);
6619 head = gfc_ss_terminator;
6620 while (ss != gfc_ss_terminator)
6623 /* Check we didn't somehow break the chain. */
6624 gcc_assert (next != NULL);
6634 /* Walk the arguments of an elemental function. */
6637 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6645 head = gfc_ss_terminator;
6648 for (; arg; arg = arg->next)
6653 newss = gfc_walk_subexpr (head, arg->expr);
6656 /* Scalar argument. */
6657 newss = gfc_get_ss ();
6659 newss->expr = arg->expr;
6669 while (tail->next != gfc_ss_terminator)
6676 /* If all the arguments are scalar we don't need the argument SS. */
6677 gfc_free_ss_chain (head);
6682 /* Add it onto the existing chain. */
6688 /* Walk a function call. Scalar functions are passed back, and taken out of
6689 scalarization loops. For elemental functions we walk their arguments.
6690 The result of functions returning arrays is stored in a temporary outside
6691 the loop, so that the function is only called once. Hence we do not need
6692 to walk their arguments. */
6695 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6698 gfc_intrinsic_sym *isym;
6700 gfc_component *comp = NULL;
6702 isym = expr->value.function.isym;
6704 /* Handle intrinsic functions separately. */
6706 return gfc_walk_intrinsic_function (ss, expr, isym);
6708 sym = expr->value.function.esym;
6710 sym = expr->symtree->n.sym;
6712 /* A function that returns arrays. */
6713 gfc_is_proc_ptr_comp (expr, &comp);
6714 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6715 || (comp && comp->attr.dimension))
6717 newss = gfc_get_ss ();
6718 newss->type = GFC_SS_FUNCTION;
6721 newss->data.info.dimen = expr->rank;
6725 /* Walk the parameters of an elemental function. For now we always pass
6727 if (sym->attr.elemental)
6728 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6731 /* Scalar functions are OK as these are evaluated outside the scalarization
6732 loop. Pass back and let the caller deal with it. */
6737 /* An array temporary is constructed for array constructors. */
6740 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6745 newss = gfc_get_ss ();
6746 newss->type = GFC_SS_CONSTRUCTOR;
6749 newss->data.info.dimen = expr->rank;
6750 for (n = 0; n < expr->rank; n++)
6751 newss->data.info.dim[n] = n;
6757 /* Walk an expression. Add walked expressions to the head of the SS chain.
6758 A wholly scalar expression will not be added. */
6761 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6765 switch (expr->expr_type)
6768 head = gfc_walk_variable_expr (ss, expr);
6772 head = gfc_walk_op_expr (ss, expr);
6776 head = gfc_walk_function_expr (ss, expr);
6781 case EXPR_STRUCTURE:
6782 /* Pass back and let the caller deal with it. */
6786 head = gfc_walk_array_constructor (ss, expr);
6789 case EXPR_SUBSTRING:
6790 /* Pass back and let the caller deal with it. */
6794 internal_error ("bad expression type during walk (%d)",
6801 /* Entry point for expression walking.
6802 A return value equal to the passed chain means this is
6803 a scalar expression. It is up to the caller to take whatever action is
6804 necessary to translate these. */
6807 gfc_walk_expr (gfc_expr * expr)
6811 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6812 return gfc_reverse_ss (res);