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"
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
95 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
97 /* The contents of this structure aren't actually used, just the address. */
98 static gfc_ss gfc_ss_terminator_var;
99 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
103 gfc_array_dataptr_type (tree desc)
105 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
109 /* Build expressions to access the members of an array descriptor.
110 It's surprisingly easy to mess up here, so never access
111 an array descriptor by "brute force", always use these
112 functions. This also avoids problems if we change the format
113 of an array descriptor.
115 To understand these magic numbers, look at the comments
116 before gfc_build_array_type() in trans-types.c.
118 The code within these defines should be the only code which knows the format
119 of an array descriptor.
121 Any code just needing to read obtain the bounds of an array should use
122 gfc_conv_array_* rather than the following functions as these will return
123 know constant values, and work with arrays which do not have descriptors.
125 Don't forget to #undef these! */
128 #define OFFSET_FIELD 1
129 #define DTYPE_FIELD 2
130 #define DIMENSION_FIELD 3
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc)
144 type = TREE_TYPE (desc);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
147 field = TYPE_FIELDS (type);
148 gcc_assert (DATA_FIELD == 0);
150 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
151 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
169 type = TREE_TYPE (desc);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172 field = TYPE_FIELDS (type);
173 gcc_assert (DATA_FIELD == 0);
175 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
176 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
180 /* This provides address access to the data field. This should only be
181 used by array allocation, passing this on to the runtime. */
184 gfc_conv_descriptor_data_addr (tree desc)
188 type = TREE_TYPE (desc);
189 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
191 field = TYPE_FIELDS (type);
192 gcc_assert (DATA_FIELD == 0);
194 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
195 return gfc_build_addr_expr (NULL_TREE, t);
199 gfc_conv_descriptor_offset (tree desc)
204 type = TREE_TYPE (desc);
205 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
207 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
208 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
210 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
211 desc, field, NULL_TREE);
215 gfc_conv_descriptor_offset_get (tree desc)
217 return gfc_conv_descriptor_offset (desc);
221 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
224 tree t = gfc_conv_descriptor_offset (desc);
225 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
230 gfc_conv_descriptor_dtype (tree desc)
235 type = TREE_TYPE (desc);
236 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
238 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
239 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
241 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
242 desc, field, NULL_TREE);
246 gfc_conv_descriptor_dimension (tree desc, tree dim)
252 type = TREE_TYPE (desc);
253 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
255 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
256 gcc_assert (field != NULL_TREE
257 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
258 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
260 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
261 desc, field, NULL_TREE);
262 tmp = gfc_build_array_ref (tmp, dim, NULL);
267 gfc_conv_descriptor_stride (tree desc, tree dim)
272 tmp = gfc_conv_descriptor_dimension (desc, dim);
273 field = TYPE_FIELDS (TREE_TYPE (tmp));
274 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
275 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
277 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
278 tmp, field, NULL_TREE);
283 gfc_conv_descriptor_stride_get (tree desc, tree dim)
285 tree type = TREE_TYPE (desc);
286 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
287 if (integer_zerop (dim)
288 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
289 return gfc_index_one_node;
291 return gfc_conv_descriptor_stride (desc, dim);
295 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
296 tree dim, tree value)
298 tree t = gfc_conv_descriptor_stride (desc, dim);
299 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 gfc_conv_descriptor_lbound (tree desc, tree dim)
308 tmp = gfc_conv_descriptor_dimension (desc, dim);
309 field = TYPE_FIELDS (TREE_TYPE (tmp));
310 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
311 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
313 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
314 tmp, field, NULL_TREE);
319 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
321 return gfc_conv_descriptor_lbound (desc, dim);
325 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
326 tree dim, tree value)
328 tree t = gfc_conv_descriptor_lbound (desc, dim);
329 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
333 gfc_conv_descriptor_ubound (tree desc, tree dim)
338 tmp = gfc_conv_descriptor_dimension (desc, dim);
339 field = TYPE_FIELDS (TREE_TYPE (tmp));
340 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
341 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
343 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
344 tmp, field, NULL_TREE);
349 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
351 return gfc_conv_descriptor_ubound (desc, dim);
355 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
356 tree dim, tree value)
358 tree t = gfc_conv_descriptor_ubound (desc, dim);
359 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
362 /* Build a null array descriptor constructor. */
365 gfc_build_null_descriptor (tree type)
370 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
371 gcc_assert (DATA_FIELD == 0);
372 field = TYPE_FIELDS (type);
374 /* Set a NULL data pointer. */
375 tmp = build_constructor_single (type, field, null_pointer_node);
376 TREE_CONSTANT (tmp) = 1;
377 /* All other fields are ignored. */
383 /* Cleanup those #defines. */
388 #undef DIMENSION_FIELD
389 #undef STRIDE_SUBFIELD
390 #undef LBOUND_SUBFIELD
391 #undef UBOUND_SUBFIELD
394 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
395 flags & 1 = Main loop body.
396 flags & 2 = temp copy loop. */
399 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
401 for (; ss != gfc_ss_terminator; ss = ss->next)
402 ss->useflags = flags;
405 static void gfc_free_ss (gfc_ss *);
408 /* Free a gfc_ss chain. */
411 gfc_free_ss_chain (gfc_ss * ss)
415 while (ss != gfc_ss_terminator)
417 gcc_assert (ss != NULL);
428 gfc_free_ss (gfc_ss * ss)
435 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
437 if (ss->data.info.subscript[n])
438 gfc_free_ss_chain (ss->data.info.subscript[n]);
450 /* Free all the SS associated with a loop. */
453 gfc_cleanup_loop (gfc_loopinfo * loop)
459 while (ss != gfc_ss_terminator)
461 gcc_assert (ss != NULL);
462 next = ss->loop_chain;
469 /* Associate a SS chain with a loop. */
472 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
476 if (head == gfc_ss_terminator)
480 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
482 if (ss->next == gfc_ss_terminator)
483 ss->loop_chain = loop->ss;
485 ss->loop_chain = ss->next;
487 gcc_assert (ss == gfc_ss_terminator);
492 /* Generate an initializer for a static pointer or allocatable array. */
495 gfc_trans_static_array_pointer (gfc_symbol * sym)
499 gcc_assert (TREE_STATIC (sym->backend_decl));
500 /* Just zero the data member. */
501 type = TREE_TYPE (sym->backend_decl);
502 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
506 /* If the bounds of SE's loop have not yet been set, see if they can be
507 determined from array spec AS, which is the array spec of a called
508 function. MAPPING maps the callee's dummy arguments to the values
509 that the caller is passing. Add any initialization and finalization
513 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
514 gfc_se * se, gfc_array_spec * as)
522 if (as && as->type == AS_EXPLICIT)
523 for (dim = 0; dim < se->loop->dimen; dim++)
525 n = se->loop->order[dim];
526 if (se->loop->to[n] == NULL_TREE)
528 /* Evaluate the lower bound. */
529 gfc_init_se (&tmpse, NULL);
530 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
531 gfc_add_block_to_block (&se->pre, &tmpse.pre);
532 gfc_add_block_to_block (&se->post, &tmpse.post);
533 lower = fold_convert (gfc_array_index_type, tmpse.expr);
535 /* ...and the upper bound. */
536 gfc_init_se (&tmpse, NULL);
537 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
538 gfc_add_block_to_block (&se->pre, &tmpse.pre);
539 gfc_add_block_to_block (&se->post, &tmpse.post);
540 upper = fold_convert (gfc_array_index_type, tmpse.expr);
542 /* Set the upper bound of the loop to UPPER - LOWER. */
543 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
544 tmp = gfc_evaluate_now (tmp, &se->pre);
545 se->loop->to[n] = tmp;
551 /* Generate code to allocate an array temporary, or create a variable to
552 hold the data. If size is NULL, zero the descriptor so that the
553 callee will allocate the array. If DEALLOC is true, also generate code to
554 free the array afterwards.
556 If INITIAL is not NULL, it is packed using internal_pack and the result used
557 as data instead of allocating a fresh, unitialized area of memory.
559 Initialization code is added to PRE and finalization code to POST.
560 DYNAMIC is true if the caller may want to extend the array later
561 using realloc. This prevents us from putting the array on the stack. */
564 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
565 gfc_ss_info * info, tree size, tree nelem,
566 tree initial, bool dynamic, bool dealloc)
572 desc = info->descriptor;
573 info->offset = gfc_index_zero_node;
574 if (size == NULL_TREE || integer_zerop (size))
576 /* A callee allocated array. */
577 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
582 /* Allocate the temporary. */
583 onstack = !dynamic && initial == NULL_TREE
584 && gfc_can_put_var_on_stack (size);
588 /* Make a temporary variable to hold the data. */
589 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
591 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
593 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
595 tmp = gfc_create_var (tmp, "A");
596 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
597 gfc_conv_descriptor_data_set (pre, desc, tmp);
601 /* Allocate memory to hold the data or call internal_pack. */
602 if (initial == NULL_TREE)
604 tmp = gfc_call_malloc (pre, NULL, size);
605 tmp = gfc_evaluate_now (tmp, pre);
612 stmtblock_t do_copying;
614 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
615 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
616 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
617 tmp = gfc_get_element_type (tmp);
618 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
619 packed = gfc_create_var (build_pointer_type (tmp), "data");
621 tmp = build_call_expr_loc (input_location,
622 gfor_fndecl_in_pack, 1, initial);
623 tmp = fold_convert (TREE_TYPE (packed), tmp);
624 gfc_add_modify (pre, packed, tmp);
626 tmp = build_fold_indirect_ref_loc (input_location,
628 source_data = gfc_conv_descriptor_data_get (tmp);
630 /* internal_pack may return source->data without any allocation
631 or copying if it is already packed. If that's the case, we
632 need to allocate and copy manually. */
634 gfc_start_block (&do_copying);
635 tmp = gfc_call_malloc (&do_copying, NULL, size);
636 tmp = fold_convert (TREE_TYPE (packed), tmp);
637 gfc_add_modify (&do_copying, packed, tmp);
638 tmp = gfc_build_memcpy_call (packed, source_data, size);
639 gfc_add_expr_to_block (&do_copying, tmp);
641 was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
642 packed, source_data);
643 tmp = gfc_finish_block (&do_copying);
644 tmp = build3_v (COND_EXPR, was_packed, tmp,
645 build_empty_stmt (input_location));
646 gfc_add_expr_to_block (pre, tmp);
648 tmp = fold_convert (pvoid_type_node, packed);
651 gfc_conv_descriptor_data_set (pre, desc, tmp);
654 info->data = gfc_conv_descriptor_data_get (desc);
656 /* The offset is zero because we create temporaries with a zero
658 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
660 if (dealloc && !onstack)
662 /* Free the temporary. */
663 tmp = gfc_conv_descriptor_data_get (desc);
664 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
665 gfc_add_expr_to_block (post, tmp);
670 /* Generate code to create and initialize the descriptor for a temporary
671 array. This is used for both temporaries needed by the scalarizer, and
672 functions returning arrays. Adjusts the loop variables to be
673 zero-based, and calculates the loop bounds for callee allocated arrays.
674 Allocate the array unless it's callee allocated (we have a callee
675 allocated array if 'callee_alloc' is true, or if loop->to[n] is
676 NULL_TREE for any n). Also fills in the descriptor, data and offset
677 fields of info if known. Returns the size of the array, or NULL for a
678 callee allocated array.
680 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
681 gfc_trans_allocate_array_storage.
685 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
686 gfc_loopinfo * loop, gfc_ss_info * info,
687 tree eltype, tree initial, bool dynamic,
688 bool dealloc, bool callee_alloc, locus * where)
700 gcc_assert (info->dimen > 0);
702 if (gfc_option.warn_array_temp && where)
703 gfc_warning ("Creating array temporary at %L", where);
705 /* Set the lower bound to zero. */
706 for (dim = 0; dim < info->dimen; dim++)
708 n = loop->order[dim];
709 /* Callee allocated arrays may not have a known bound yet. */
711 loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
712 gfc_array_index_type,
713 loop->to[n], loop->from[n]), pre);
714 loop->from[n] = gfc_index_zero_node;
716 info->delta[dim] = gfc_index_zero_node;
717 info->start[dim] = gfc_index_zero_node;
718 info->end[dim] = gfc_index_zero_node;
719 info->stride[dim] = gfc_index_one_node;
720 info->dim[dim] = dim;
723 /* Initialize the descriptor. */
725 gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
726 GFC_ARRAY_UNKNOWN, true);
727 desc = gfc_create_var (type, "atmp");
728 GFC_DECL_PACKED_ARRAY (desc) = 1;
730 info->descriptor = desc;
731 size = gfc_index_one_node;
733 /* Fill in the array dtype. */
734 tmp = gfc_conv_descriptor_dtype (desc);
735 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
738 Fill in the bounds and stride. This is a packed array, so:
741 for (n = 0; n < rank; n++)
744 delta = ubound[n] + 1 - lbound[n];
747 size = size * sizeof(element);
752 /* If there is at least one null loop->to[n], it is a callee allocated
754 for (n = 0; n < info->dimen; n++)
755 if (loop->to[n] == NULL_TREE)
761 for (n = 0; n < info->dimen; n++)
763 if (size == NULL_TREE)
765 /* For a callee allocated array express the loop bounds in terms
766 of the descriptor fields. */
768 fold_build2 (MINUS_EXPR, gfc_array_index_type,
769 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
770 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
775 /* Store the stride and bound components in the descriptor. */
776 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
778 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
779 gfc_index_zero_node);
781 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
783 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
784 loop->to[n], gfc_index_one_node);
786 /* Check whether the size for this dimension is negative. */
787 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
788 gfc_index_zero_node);
789 cond = gfc_evaluate_now (cond, pre);
794 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
796 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
797 size = gfc_evaluate_now (size, pre);
800 /* Get the size of the array. */
802 if (size && !callee_alloc)
804 /* If or_expr is true, then the extent in at least one
805 dimension is zero and the size is set to zero. */
806 size = fold_build3 (COND_EXPR, gfc_array_index_type,
807 or_expr, gfc_index_zero_node, size);
810 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
811 fold_convert (gfc_array_index_type,
812 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
820 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
823 if (info->dimen > loop->temp_dim)
824 loop->temp_dim = info->dimen;
830 /* Generate code to transpose array EXPR by creating a new descriptor
831 in which the dimension specifications have been reversed. */
834 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
836 tree dest, src, dest_index, src_index;
838 gfc_ss_info *dest_info;
839 gfc_ss *dest_ss, *src_ss;
845 src_ss = gfc_walk_expr (expr);
848 dest_info = &dest_ss->data.info;
849 gcc_assert (dest_info->dimen == 2);
851 /* Get a descriptor for EXPR. */
852 gfc_init_se (&src_se, NULL);
853 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
854 gfc_add_block_to_block (&se->pre, &src_se.pre);
855 gfc_add_block_to_block (&se->post, &src_se.post);
858 /* Allocate a new descriptor for the return value. */
859 dest = gfc_create_var (TREE_TYPE (src), "atmp");
860 dest_info->descriptor = dest;
863 /* Copy across the dtype field. */
864 gfc_add_modify (&se->pre,
865 gfc_conv_descriptor_dtype (dest),
866 gfc_conv_descriptor_dtype (src));
868 /* Copy the dimension information, renumbering dimension 1 to 0 and
870 for (n = 0; n < 2; n++)
872 dest_info->delta[n] = gfc_index_zero_node;
873 dest_info->start[n] = gfc_index_zero_node;
874 dest_info->end[n] = gfc_index_zero_node;
875 dest_info->stride[n] = gfc_index_one_node;
876 dest_info->dim[n] = n;
878 dest_index = gfc_rank_cst[n];
879 src_index = gfc_rank_cst[1 - n];
881 gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
882 gfc_conv_descriptor_stride_get (src, src_index));
884 gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
885 gfc_conv_descriptor_lbound_get (src, src_index));
887 gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
888 gfc_conv_descriptor_ubound_get (src, src_index));
892 gcc_assert (integer_zerop (loop->from[n]));
894 fold_build2 (MINUS_EXPR, gfc_array_index_type,
895 gfc_conv_descriptor_ubound_get (dest, dest_index),
896 gfc_conv_descriptor_lbound_get (dest, dest_index));
900 /* Copy the data pointer. */
901 dest_info->data = gfc_conv_descriptor_data_get (src);
902 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
904 /* Copy the offset. This is not changed by transposition; the top-left
905 element is still at the same offset as before, except where the loop
907 if (!integer_zerop (loop->from[0]))
908 dest_info->offset = gfc_conv_descriptor_offset_get (src);
910 dest_info->offset = gfc_index_zero_node;
912 gfc_conv_descriptor_offset_set (&se->pre, dest,
915 if (dest_info->dimen > loop->temp_dim)
916 loop->temp_dim = dest_info->dimen;
920 /* Return the number of iterations in a loop that starts at START,
921 ends at END, and has step STEP. */
924 gfc_get_iteration_count (tree start, tree end, tree step)
929 type = TREE_TYPE (step);
930 tmp = fold_build2 (MINUS_EXPR, type, end, start);
931 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
932 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
933 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
934 return fold_convert (gfc_array_index_type, tmp);
938 /* Extend the data in array DESC by EXTRA elements. */
941 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
948 if (integer_zerop (extra))
951 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
953 /* Add EXTRA to the upper bound. */
954 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
955 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
957 /* Get the value of the current data pointer. */
958 arg0 = gfc_conv_descriptor_data_get (desc);
960 /* Calculate the new array size. */
961 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
962 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
963 ubound, gfc_index_one_node);
964 arg1 = fold_build2 (MULT_EXPR, size_type_node,
965 fold_convert (size_type_node, tmp),
966 fold_convert (size_type_node, size));
968 /* Call the realloc() function. */
969 tmp = gfc_call_realloc (pblock, arg0, arg1);
970 gfc_conv_descriptor_data_set (pblock, desc, tmp);
974 /* Return true if the bounds of iterator I can only be determined
978 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
980 return (i->start->expr_type != EXPR_CONSTANT
981 || i->end->expr_type != EXPR_CONSTANT
982 || i->step->expr_type != EXPR_CONSTANT);
986 /* Split the size of constructor element EXPR into the sum of two terms,
987 one of which can be determined at compile time and one of which must
988 be calculated at run time. Set *SIZE to the former and return true
989 if the latter might be nonzero. */
992 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
994 if (expr->expr_type == EXPR_ARRAY)
995 return gfc_get_array_constructor_size (size, expr->value.constructor);
996 else if (expr->rank > 0)
998 /* Calculate everything at run time. */
999 mpz_set_ui (*size, 0);
1004 /* A single element. */
1005 mpz_set_ui (*size, 1);
1011 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1012 of array constructor C. */
1015 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1023 mpz_set_ui (*size, 0);
1028 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1031 if (i && gfc_iterator_has_dynamic_bounds (i))
1035 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1038 /* Multiply the static part of the element size by the
1039 number of iterations. */
1040 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1041 mpz_fdiv_q (val, val, i->step->value.integer);
1042 mpz_add_ui (val, val, 1);
1043 if (mpz_sgn (val) > 0)
1044 mpz_mul (len, len, val);
1046 mpz_set_ui (len, 0);
1048 mpz_add (*size, *size, len);
1057 /* Make sure offset is a variable. */
1060 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1063 /* We should have already created the offset variable. We cannot
1064 create it here because we may be in an inner scope. */
1065 gcc_assert (*offsetvar != NULL_TREE);
1066 gfc_add_modify (pblock, *offsetvar, *poffset);
1067 *poffset = *offsetvar;
1068 TREE_USED (*offsetvar) = 1;
1072 /* Variables needed for bounds-checking. */
1073 static bool first_len;
1074 static tree first_len_val;
1075 static bool typespec_chararray_ctor;
1078 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1079 tree offset, gfc_se * se, gfc_expr * expr)
1083 gfc_conv_expr (se, expr);
1085 /* Store the value. */
1086 tmp = build_fold_indirect_ref_loc (input_location,
1087 gfc_conv_descriptor_data_get (desc));
1088 tmp = gfc_build_array_ref (tmp, offset, NULL);
1090 if (expr->ts.type == BT_CHARACTER)
1092 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1095 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1096 esize = fold_convert (gfc_charlen_type_node, esize);
1097 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1098 build_int_cst (gfc_charlen_type_node,
1099 gfc_character_kinds[i].bit_size / 8));
1101 gfc_conv_string_parameter (se);
1102 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1104 /* The temporary is an array of pointers. */
1105 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1106 gfc_add_modify (&se->pre, tmp, se->expr);
1110 /* The temporary is an array of string values. */
1111 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1112 /* We know the temporary and the value will be the same length,
1113 so can use memcpy. */
1114 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1115 se->string_length, se->expr, expr->ts.kind);
1117 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1121 gfc_add_modify (&se->pre, first_len_val,
1127 /* Verify that all constructor elements are of the same
1129 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1130 first_len_val, se->string_length);
1131 gfc_trans_runtime_check
1132 (true, false, cond, &se->pre, &expr->where,
1133 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1134 fold_convert (long_integer_type_node, first_len_val),
1135 fold_convert (long_integer_type_node, se->string_length));
1141 /* TODO: Should the frontend already have done this conversion? */
1142 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1143 gfc_add_modify (&se->pre, tmp, se->expr);
1146 gfc_add_block_to_block (pblock, &se->pre);
1147 gfc_add_block_to_block (pblock, &se->post);
1151 /* Add the contents of an array to the constructor. DYNAMIC is as for
1152 gfc_trans_array_constructor_value. */
1155 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1156 tree type ATTRIBUTE_UNUSED,
1157 tree desc, gfc_expr * expr,
1158 tree * poffset, tree * offsetvar,
1169 /* We need this to be a variable so we can increment it. */
1170 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1172 gfc_init_se (&se, NULL);
1174 /* Walk the array expression. */
1175 ss = gfc_walk_expr (expr);
1176 gcc_assert (ss != gfc_ss_terminator);
1178 /* Initialize the scalarizer. */
1179 gfc_init_loopinfo (&loop);
1180 gfc_add_ss_to_loop (&loop, ss);
1182 /* Initialize the loop. */
1183 gfc_conv_ss_startstride (&loop);
1184 gfc_conv_loop_setup (&loop, &expr->where);
1186 /* Make sure the constructed array has room for the new data. */
1189 /* Set SIZE to the total number of elements in the subarray. */
1190 size = gfc_index_one_node;
1191 for (n = 0; n < loop.dimen; n++)
1193 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1194 gfc_index_one_node);
1195 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1198 /* Grow the constructed array by SIZE elements. */
1199 gfc_grow_array (&loop.pre, desc, size);
1202 /* Make the loop body. */
1203 gfc_mark_ss_chain_used (ss, 1);
1204 gfc_start_scalarized_body (&loop, &body);
1205 gfc_copy_loopinfo_to_se (&se, &loop);
1208 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1209 gcc_assert (se.ss == gfc_ss_terminator);
1211 /* Increment the offset. */
1212 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1213 *poffset, gfc_index_one_node);
1214 gfc_add_modify (&body, *poffset, tmp);
1216 /* Finish the loop. */
1217 gfc_trans_scalarizing_loops (&loop, &body);
1218 gfc_add_block_to_block (&loop.pre, &loop.post);
1219 tmp = gfc_finish_block (&loop.pre);
1220 gfc_add_expr_to_block (pblock, tmp);
1222 gfc_cleanup_loop (&loop);
1226 /* Assign the values to the elements of an array constructor. DYNAMIC
1227 is true if descriptor DESC only contains enough data for the static
1228 size calculated by gfc_get_array_constructor_size. When true, memory
1229 for the dynamic parts must be allocated using realloc. */
1232 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1233 tree desc, gfc_constructor_base base,
1234 tree * poffset, tree * offsetvar,
1243 tree shadow_loopvar = NULL_TREE;
1244 gfc_saved_var saved_loopvar;
1247 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1249 /* If this is an iterator or an array, the offset must be a variable. */
1250 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1251 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1253 /* Shadowing the iterator avoids changing its value and saves us from
1254 keeping track of it. Further, it makes sure that there's always a
1255 backend-decl for the symbol, even if there wasn't one before,
1256 e.g. in the case of an iterator that appears in a specification
1257 expression in an interface mapping. */
1260 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1261 tree type = gfc_typenode_for_spec (&sym->ts);
1263 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1264 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1267 gfc_start_block (&body);
1269 if (c->expr->expr_type == EXPR_ARRAY)
1271 /* Array constructors can be nested. */
1272 gfc_trans_array_constructor_value (&body, type, desc,
1273 c->expr->value.constructor,
1274 poffset, offsetvar, dynamic);
1276 else if (c->expr->rank > 0)
1278 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1279 poffset, offsetvar, dynamic);
1283 /* This code really upsets the gimplifier so don't bother for now. */
1290 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1292 p = gfc_constructor_next (p);
1297 /* Scalar values. */
1298 gfc_init_se (&se, NULL);
1299 gfc_trans_array_ctor_element (&body, desc, *poffset,
1302 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1303 *poffset, gfc_index_one_node);
1307 /* Collect multiple scalar constants into a constructor. */
1308 VEC(constructor_elt,gc) *v = NULL;
1312 HOST_WIDE_INT idx = 0;
1315 /* Count the number of consecutive scalar constants. */
1316 while (p && !(p->iterator
1317 || p->expr->expr_type != EXPR_CONSTANT))
1319 gfc_init_se (&se, NULL);
1320 gfc_conv_constant (&se, p->expr);
1322 if (c->expr->ts.type != BT_CHARACTER)
1323 se.expr = fold_convert (type, se.expr);
1324 /* For constant character array constructors we build
1325 an array of pointers. */
1326 else if (POINTER_TYPE_P (type))
1327 se.expr = gfc_build_addr_expr
1328 (gfc_get_pchar_type (p->expr->ts.kind),
1331 CONSTRUCTOR_APPEND_ELT (v,
1332 build_int_cst (gfc_array_index_type,
1336 p = gfc_constructor_next (p);
1339 bound = build_int_cst (NULL_TREE, n - 1);
1340 /* Create an array type to hold them. */
1341 tmptype = build_range_type (gfc_array_index_type,
1342 gfc_index_zero_node, bound);
1343 tmptype = build_array_type (type, tmptype);
1345 init = build_constructor (tmptype, v);
1346 TREE_CONSTANT (init) = 1;
1347 TREE_STATIC (init) = 1;
1348 /* Create a static variable to hold the data. */
1349 tmp = gfc_create_var (tmptype, "data");
1350 TREE_STATIC (tmp) = 1;
1351 TREE_CONSTANT (tmp) = 1;
1352 TREE_READONLY (tmp) = 1;
1353 DECL_INITIAL (tmp) = init;
1356 /* Use BUILTIN_MEMCPY to assign the values. */
1357 tmp = gfc_conv_descriptor_data_get (desc);
1358 tmp = build_fold_indirect_ref_loc (input_location,
1360 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1361 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1362 init = gfc_build_addr_expr (NULL_TREE, init);
1364 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1365 bound = build_int_cst (NULL_TREE, n * size);
1366 tmp = build_call_expr_loc (input_location,
1367 built_in_decls[BUILT_IN_MEMCPY], 3,
1369 gfc_add_expr_to_block (&body, tmp);
1371 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1373 build_int_cst (gfc_array_index_type, n));
1375 if (!INTEGER_CST_P (*poffset))
1377 gfc_add_modify (&body, *offsetvar, *poffset);
1378 *poffset = *offsetvar;
1382 /* The frontend should already have done any expansions
1386 /* Pass the code as is. */
1387 tmp = gfc_finish_block (&body);
1388 gfc_add_expr_to_block (pblock, tmp);
1392 /* Build the implied do-loop. */
1393 stmtblock_t implied_do_block;
1401 loopbody = gfc_finish_block (&body);
1403 /* Create a new block that holds the implied-do loop. A temporary
1404 loop-variable is used. */
1405 gfc_start_block(&implied_do_block);
1407 /* Initialize the loop. */
1408 gfc_init_se (&se, NULL);
1409 gfc_conv_expr_val (&se, c->iterator->start);
1410 gfc_add_block_to_block (&implied_do_block, &se.pre);
1411 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1413 gfc_init_se (&se, NULL);
1414 gfc_conv_expr_val (&se, c->iterator->end);
1415 gfc_add_block_to_block (&implied_do_block, &se.pre);
1416 end = gfc_evaluate_now (se.expr, &implied_do_block);
1418 gfc_init_se (&se, NULL);
1419 gfc_conv_expr_val (&se, c->iterator->step);
1420 gfc_add_block_to_block (&implied_do_block, &se.pre);
1421 step = gfc_evaluate_now (se.expr, &implied_do_block);
1423 /* If this array expands dynamically, and the number of iterations
1424 is not constant, we won't have allocated space for the static
1425 part of C->EXPR's size. Do that now. */
1426 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1428 /* Get the number of iterations. */
1429 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1431 /* Get the static part of C->EXPR's size. */
1432 gfc_get_array_constructor_element_size (&size, c->expr);
1433 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1435 /* Grow the array by TMP * TMP2 elements. */
1436 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1437 gfc_grow_array (&implied_do_block, desc, tmp);
1440 /* Generate the loop body. */
1441 exit_label = gfc_build_label_decl (NULL_TREE);
1442 gfc_start_block (&body);
1444 /* Generate the exit condition. Depending on the sign of
1445 the step variable we have to generate the correct
1447 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1448 build_int_cst (TREE_TYPE (step), 0));
1449 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1450 fold_build2 (GT_EXPR, boolean_type_node,
1451 shadow_loopvar, end),
1452 fold_build2 (LT_EXPR, boolean_type_node,
1453 shadow_loopvar, end));
1454 tmp = build1_v (GOTO_EXPR, exit_label);
1455 TREE_USED (exit_label) = 1;
1456 tmp = build3_v (COND_EXPR, cond, tmp,
1457 build_empty_stmt (input_location));
1458 gfc_add_expr_to_block (&body, tmp);
1460 /* The main loop body. */
1461 gfc_add_expr_to_block (&body, loopbody);
1463 /* Increase loop variable by step. */
1464 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1465 gfc_add_modify (&body, shadow_loopvar, tmp);
1467 /* Finish the loop. */
1468 tmp = gfc_finish_block (&body);
1469 tmp = build1_v (LOOP_EXPR, tmp);
1470 gfc_add_expr_to_block (&implied_do_block, tmp);
1472 /* Add the exit label. */
1473 tmp = build1_v (LABEL_EXPR, exit_label);
1474 gfc_add_expr_to_block (&implied_do_block, tmp);
1476 /* Finishe the implied-do loop. */
1477 tmp = gfc_finish_block(&implied_do_block);
1478 gfc_add_expr_to_block(pblock, tmp);
1480 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1487 /* Figure out the string length of a variable reference expression.
1488 Used by get_array_ctor_strlen. */
1491 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1497 /* Don't bother if we already know the length is a constant. */
1498 if (*len && INTEGER_CST_P (*len))
1501 ts = &expr->symtree->n.sym->ts;
1502 for (ref = expr->ref; ref; ref = ref->next)
1507 /* Array references don't change the string length. */
1511 /* Use the length of the component. */
1512 ts = &ref->u.c.component->ts;
1516 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1517 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1519 mpz_init_set_ui (char_len, 1);
1520 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1521 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1522 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1523 *len = convert (gfc_charlen_type_node, *len);
1524 mpz_clear (char_len);
1528 /* TODO: Substrings are tricky because we can't evaluate the
1529 expression more than once. For now we just give up, and hope
1530 we can figure it out elsewhere. */
1535 *len = ts->u.cl->backend_decl;
1539 /* A catch-all to obtain the string length for anything that is not a
1540 constant, array or variable. */
1542 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1547 /* Don't bother if we already know the length is a constant. */
1548 if (*len && INTEGER_CST_P (*len))
1551 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1552 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1555 gfc_conv_const_charlen (e->ts.u.cl);
1556 *len = e->ts.u.cl->backend_decl;
1560 /* Otherwise, be brutal even if inefficient. */
1561 ss = gfc_walk_expr (e);
1562 gfc_init_se (&se, NULL);
1564 /* No function call, in case of side effects. */
1565 se.no_function_call = 1;
1566 if (ss == gfc_ss_terminator)
1567 gfc_conv_expr (&se, e);
1569 gfc_conv_expr_descriptor (&se, e, ss);
1571 /* Fix the value. */
1572 *len = gfc_evaluate_now (se.string_length, &se.pre);
1574 gfc_add_block_to_block (block, &se.pre);
1575 gfc_add_block_to_block (block, &se.post);
1577 e->ts.u.cl->backend_decl = *len;
1582 /* Figure out the string length of a character array constructor.
1583 If len is NULL, don't calculate the length; this happens for recursive calls
1584 when a sub-array-constructor is an element but not at the first position,
1585 so when we're not interested in the length.
1586 Returns TRUE if all elements are character constants. */
1589 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1596 if (gfc_constructor_first (base) == NULL)
1599 *len = build_int_cstu (gfc_charlen_type_node, 0);
1603 /* Loop over all constructor elements to find out is_const, but in len we
1604 want to store the length of the first, not the last, element. We can
1605 of course exit the loop as soon as is_const is found to be false. */
1606 for (c = gfc_constructor_first (base);
1607 c && is_const; c = gfc_constructor_next (c))
1609 switch (c->expr->expr_type)
1612 if (len && !(*len && INTEGER_CST_P (*len)))
1613 *len = build_int_cstu (gfc_charlen_type_node,
1614 c->expr->value.character.length);
1618 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1625 get_array_ctor_var_strlen (c->expr, len);
1631 get_array_ctor_all_strlen (block, c->expr, len);
1635 /* After the first iteration, we don't want the length modified. */
1642 /* Check whether the array constructor C consists entirely of constant
1643 elements, and if so returns the number of those elements, otherwise
1644 return zero. Note, an empty or NULL array constructor returns zero. */
1646 unsigned HOST_WIDE_INT
1647 gfc_constant_array_constructor_p (gfc_constructor_base base)
1649 unsigned HOST_WIDE_INT nelem = 0;
1651 gfc_constructor *c = gfc_constructor_first (base);
1655 || c->expr->rank > 0
1656 || c->expr->expr_type != EXPR_CONSTANT)
1658 c = gfc_constructor_next (c);
1665 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1666 and the tree type of it's elements, TYPE, return a static constant
1667 variable that is compile-time initialized. */
1670 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1672 tree tmptype, init, tmp;
1673 HOST_WIDE_INT nelem;
1678 VEC(constructor_elt,gc) *v = NULL;
1680 /* First traverse the constructor list, converting the constants
1681 to tree to build an initializer. */
1683 c = gfc_constructor_first (expr->value.constructor);
1686 gfc_init_se (&se, NULL);
1687 gfc_conv_constant (&se, c->expr);
1688 if (c->expr->ts.type != BT_CHARACTER)
1689 se.expr = fold_convert (type, se.expr);
1690 else if (POINTER_TYPE_P (type))
1691 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1693 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1695 c = gfc_constructor_next (c);
1699 /* Next determine the tree type for the array. We use the gfortran
1700 front-end's gfc_get_nodesc_array_type in order to create a suitable
1701 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1703 memset (&as, 0, sizeof (gfc_array_spec));
1705 as.rank = expr->rank;
1706 as.type = AS_EXPLICIT;
1709 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1710 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1714 for (i = 0; i < expr->rank; i++)
1716 int tmp = (int) mpz_get_si (expr->shape[i]);
1717 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1718 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1722 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1724 init = build_constructor (tmptype, v);
1726 TREE_CONSTANT (init) = 1;
1727 TREE_STATIC (init) = 1;
1729 tmp = gfc_create_var (tmptype, "A");
1730 TREE_STATIC (tmp) = 1;
1731 TREE_CONSTANT (tmp) = 1;
1732 TREE_READONLY (tmp) = 1;
1733 DECL_INITIAL (tmp) = init;
1739 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1740 This mostly initializes the scalarizer state info structure with the
1741 appropriate values to directly use the array created by the function
1742 gfc_build_constant_array_constructor. */
1745 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1746 gfc_ss * ss, tree type)
1752 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1754 info = &ss->data.info;
1756 info->descriptor = tmp;
1757 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1758 info->offset = gfc_index_zero_node;
1760 for (i = 0; i < info->dimen; i++)
1762 info->delta[i] = gfc_index_zero_node;
1763 info->start[i] = gfc_index_zero_node;
1764 info->end[i] = gfc_index_zero_node;
1765 info->stride[i] = gfc_index_one_node;
1769 if (info->dimen > loop->temp_dim)
1770 loop->temp_dim = info->dimen;
1773 /* Helper routine of gfc_trans_array_constructor to determine if the
1774 bounds of the loop specified by LOOP are constant and simple enough
1775 to use with gfc_trans_constant_array_constructor. Returns the
1776 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1779 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1781 tree size = gfc_index_one_node;
1785 for (i = 0; i < loop->dimen; i++)
1787 /* If the bounds aren't constant, return NULL_TREE. */
1788 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1790 if (!integer_zerop (loop->from[i]))
1792 /* Only allow nonzero "from" in one-dimensional arrays. */
1793 if (loop->dimen != 1)
1795 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1796 loop->to[i], loop->from[i]);
1800 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1801 tmp, gfc_index_one_node);
1802 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1809 /* Array constructors are handled by constructing a temporary, then using that
1810 within the scalarization loop. This is not optimal, but seems by far the
1814 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1816 gfc_constructor_base c;
1822 bool old_first_len, old_typespec_chararray_ctor;
1823 tree old_first_len_val;
1825 /* Save the old values for nested checking. */
1826 old_first_len = first_len;
1827 old_first_len_val = first_len_val;
1828 old_typespec_chararray_ctor = typespec_chararray_ctor;
1830 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1831 typespec was given for the array constructor. */
1832 typespec_chararray_ctor = (ss->expr->ts.u.cl
1833 && ss->expr->ts.u.cl->length_from_typespec);
1835 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1836 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1838 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1842 ss->data.info.dimen = loop->dimen;
1844 c = ss->expr->value.constructor;
1845 if (ss->expr->ts.type == BT_CHARACTER)
1849 /* get_array_ctor_strlen walks the elements of the constructor, if a
1850 typespec was given, we already know the string length and want the one
1852 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1853 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1857 const_string = false;
1858 gfc_init_se (&length_se, NULL);
1859 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1860 gfc_charlen_type_node);
1861 ss->string_length = length_se.expr;
1862 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1863 gfc_add_block_to_block (&loop->post, &length_se.post);
1866 const_string = get_array_ctor_strlen (&loop->pre, c,
1867 &ss->string_length);
1869 /* Complex character array constructors should have been taken care of
1870 and not end up here. */
1871 gcc_assert (ss->string_length);
1873 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1875 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1877 type = build_pointer_type (type);
1880 type = gfc_typenode_for_spec (&ss->expr->ts);
1882 /* See if the constructor determines the loop bounds. */
1885 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1887 /* We have a multidimensional parameter. */
1889 for (n = 0; n < ss->expr->rank; n++)
1891 loop->from[n] = gfc_index_zero_node;
1892 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1893 gfc_index_integer_kind);
1894 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1895 loop->to[n], gfc_index_one_node);
1899 if (loop->to[0] == NULL_TREE)
1903 /* We should have a 1-dimensional, zero-based loop. */
1904 gcc_assert (loop->dimen == 1);
1905 gcc_assert (integer_zerop (loop->from[0]));
1907 /* Split the constructor size into a static part and a dynamic part.
1908 Allocate the static size up-front and record whether the dynamic
1909 size might be nonzero. */
1911 dynamic = gfc_get_array_constructor_size (&size, c);
1912 mpz_sub_ui (size, size, 1);
1913 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1917 /* Special case constant array constructors. */
1920 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1923 tree size = constant_array_constructor_loop_size (loop);
1924 if (size && compare_tree_int (size, nelem) == 0)
1926 gfc_trans_constant_array_constructor (loop, ss, type);
1932 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1933 type, NULL_TREE, dynamic, true, false, where);
1935 desc = ss->data.info.descriptor;
1936 offset = gfc_index_zero_node;
1937 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1938 TREE_NO_WARNING (offsetvar) = 1;
1939 TREE_USED (offsetvar) = 0;
1940 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1941 &offset, &offsetvar, dynamic);
1943 /* If the array grows dynamically, the upper bound of the loop variable
1944 is determined by the array's final upper bound. */
1946 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1948 if (TREE_USED (offsetvar))
1949 pushdecl (offsetvar);
1951 gcc_assert (INTEGER_CST_P (offset));
1953 /* Disable bound checking for now because it's probably broken. */
1954 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1961 /* Restore old values of globals. */
1962 first_len = old_first_len;
1963 first_len_val = old_first_len_val;
1964 typespec_chararray_ctor = old_typespec_chararray_ctor;
1968 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1969 called after evaluating all of INFO's vector dimensions. Go through
1970 each such vector dimension and see if we can now fill in any missing
1974 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1983 for (n = 0; n < loop->dimen; n++)
1986 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1987 && loop->to[n] == NULL)
1989 /* Loop variable N indexes vector dimension DIM, and we don't
1990 yet know the upper bound of loop variable N. Set it to the
1991 difference between the vector's upper and lower bounds. */
1992 gcc_assert (loop->from[n] == gfc_index_zero_node);
1993 gcc_assert (info->subscript[dim]
1994 && info->subscript[dim]->type == GFC_SS_VECTOR);
1996 gfc_init_se (&se, NULL);
1997 desc = info->subscript[dim]->data.info.descriptor;
1998 zero = gfc_rank_cst[0];
1999 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2000 gfc_conv_descriptor_ubound_get (desc, zero),
2001 gfc_conv_descriptor_lbound_get (desc, zero));
2002 tmp = gfc_evaluate_now (tmp, &loop->pre);
2009 /* Add the pre and post chains for all the scalar expressions in a SS chain
2010 to loop. This is called after the loop parameters have been calculated,
2011 but before the actual scalarizing loops. */
2014 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2020 /* TODO: This can generate bad code if there are ordering dependencies,
2021 e.g., a callee allocated function and an unknown size constructor. */
2022 gcc_assert (ss != NULL);
2024 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2031 /* Scalar expression. Evaluate this now. This includes elemental
2032 dimension indices, but not array section bounds. */
2033 gfc_init_se (&se, NULL);
2034 gfc_conv_expr (&se, ss->expr);
2035 gfc_add_block_to_block (&loop->pre, &se.pre);
2037 if (ss->expr->ts.type != BT_CHARACTER)
2039 /* Move the evaluation of scalar expressions outside the
2040 scalarization loop, except for WHERE assignments. */
2042 se.expr = convert(gfc_array_index_type, se.expr);
2044 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2045 gfc_add_block_to_block (&loop->pre, &se.post);
2048 gfc_add_block_to_block (&loop->post, &se.post);
2050 ss->data.scalar.expr = se.expr;
2051 ss->string_length = se.string_length;
2054 case GFC_SS_REFERENCE:
2055 /* Scalar argument to elemental procedure. Evaluate this
2057 gfc_init_se (&se, NULL);
2058 gfc_conv_expr (&se, ss->expr);
2059 gfc_add_block_to_block (&loop->pre, &se.pre);
2060 gfc_add_block_to_block (&loop->post, &se.post);
2062 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2063 ss->string_length = se.string_length;
2066 case GFC_SS_SECTION:
2067 /* Add the expressions for scalar and vector subscripts. */
2068 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2069 if (ss->data.info.subscript[n])
2070 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2073 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2077 /* Get the vector's descriptor and store it in SS. */
2078 gfc_init_se (&se, NULL);
2079 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2080 gfc_add_block_to_block (&loop->pre, &se.pre);
2081 gfc_add_block_to_block (&loop->post, &se.post);
2082 ss->data.info.descriptor = se.expr;
2085 case GFC_SS_INTRINSIC:
2086 gfc_add_intrinsic_ss_code (loop, ss);
2089 case GFC_SS_FUNCTION:
2090 /* Array function return value. We call the function and save its
2091 result in a temporary for use inside the loop. */
2092 gfc_init_se (&se, NULL);
2095 gfc_conv_expr (&se, ss->expr);
2096 gfc_add_block_to_block (&loop->pre, &se.pre);
2097 gfc_add_block_to_block (&loop->post, &se.post);
2098 ss->string_length = se.string_length;
2101 case GFC_SS_CONSTRUCTOR:
2102 if (ss->expr->ts.type == BT_CHARACTER
2103 && ss->string_length == NULL
2104 && ss->expr->ts.u.cl
2105 && ss->expr->ts.u.cl->length)
2107 gfc_init_se (&se, NULL);
2108 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2109 gfc_charlen_type_node);
2110 ss->string_length = se.expr;
2111 gfc_add_block_to_block (&loop->pre, &se.pre);
2112 gfc_add_block_to_block (&loop->post, &se.post);
2114 gfc_trans_array_constructor (loop, ss, where);
2118 case GFC_SS_COMPONENT:
2119 /* Do nothing. These are handled elsewhere. */
2129 /* Translate expressions for the descriptor and data pointer of a SS. */
2133 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2138 /* Get the descriptor for the array to be scalarized. */
2139 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2140 gfc_init_se (&se, NULL);
2141 se.descriptor_only = 1;
2142 gfc_conv_expr_lhs (&se, ss->expr);
2143 gfc_add_block_to_block (block, &se.pre);
2144 ss->data.info.descriptor = se.expr;
2145 ss->string_length = se.string_length;
2149 /* Also the data pointer. */
2150 tmp = gfc_conv_array_data (se.expr);
2151 /* If this is a variable or address of a variable we use it directly.
2152 Otherwise we must evaluate it now to avoid breaking dependency
2153 analysis by pulling the expressions for elemental array indices
2156 || (TREE_CODE (tmp) == ADDR_EXPR
2157 && DECL_P (TREE_OPERAND (tmp, 0)))))
2158 tmp = gfc_evaluate_now (tmp, block);
2159 ss->data.info.data = tmp;
2161 tmp = gfc_conv_array_offset (se.expr);
2162 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2167 /* Initialize a gfc_loopinfo structure. */
2170 gfc_init_loopinfo (gfc_loopinfo * loop)
2174 memset (loop, 0, sizeof (gfc_loopinfo));
2175 gfc_init_block (&loop->pre);
2176 gfc_init_block (&loop->post);
2178 /* Initially scalarize in order. */
2179 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2182 loop->ss = gfc_ss_terminator;
2186 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2190 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2196 /* Return an expression for the data pointer of an array. */
2199 gfc_conv_array_data (tree descriptor)
2203 type = TREE_TYPE (descriptor);
2204 if (GFC_ARRAY_TYPE_P (type))
2206 if (TREE_CODE (type) == POINTER_TYPE)
2210 /* Descriptorless arrays. */
2211 return gfc_build_addr_expr (NULL_TREE, descriptor);
2215 return gfc_conv_descriptor_data_get (descriptor);
2219 /* Return an expression for the base offset of an array. */
2222 gfc_conv_array_offset (tree descriptor)
2226 type = TREE_TYPE (descriptor);
2227 if (GFC_ARRAY_TYPE_P (type))
2228 return GFC_TYPE_ARRAY_OFFSET (type);
2230 return gfc_conv_descriptor_offset_get (descriptor);
2234 /* Get an expression for the array stride. */
2237 gfc_conv_array_stride (tree descriptor, int dim)
2242 type = TREE_TYPE (descriptor);
2244 /* For descriptorless arrays use the array size. */
2245 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2246 if (tmp != NULL_TREE)
2249 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2254 /* Like gfc_conv_array_stride, but for the lower bound. */
2257 gfc_conv_array_lbound (tree descriptor, int dim)
2262 type = TREE_TYPE (descriptor);
2264 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2265 if (tmp != NULL_TREE)
2268 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2273 /* Like gfc_conv_array_stride, but for the upper bound. */
2276 gfc_conv_array_ubound (tree descriptor, int dim)
2281 type = TREE_TYPE (descriptor);
2283 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2284 if (tmp != NULL_TREE)
2287 /* This should only ever happen when passing an assumed shape array
2288 as an actual parameter. The value will never be used. */
2289 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2290 return gfc_index_zero_node;
2292 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2297 /* Generate code to perform an array index bound check. */
2300 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2301 locus * where, bool check_upper)
2304 tree tmp_lo, tmp_up;
2306 const char * name = NULL;
2308 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2311 index = gfc_evaluate_now (index, &se->pre);
2313 /* We find a name for the error message. */
2315 name = se->ss->expr->symtree->name;
2317 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2318 && se->loop->ss->expr->symtree)
2319 name = se->loop->ss->expr->symtree->name;
2321 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2322 && se->loop->ss->loop_chain->expr
2323 && se->loop->ss->loop_chain->expr->symtree)
2324 name = se->loop->ss->loop_chain->expr->symtree->name;
2326 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2328 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2329 && se->loop->ss->expr->value.function.name)
2330 name = se->loop->ss->expr->value.function.name;
2332 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2333 || se->loop->ss->type == GFC_SS_SCALAR)
2334 name = "unnamed constant";
2337 if (TREE_CODE (descriptor) == VAR_DECL)
2338 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2340 /* If upper bound is present, include both bounds in the error message. */
2343 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2344 tmp_up = gfc_conv_array_ubound (descriptor, n);
2347 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2348 "outside of expected range (%%ld:%%ld)", n+1, name);
2350 asprintf (&msg, "Index '%%ld' of dimension %d "
2351 "outside of expected range (%%ld:%%ld)", n+1);
2353 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2354 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2355 fold_convert (long_integer_type_node, index),
2356 fold_convert (long_integer_type_node, tmp_lo),
2357 fold_convert (long_integer_type_node, tmp_up));
2358 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2359 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2360 fold_convert (long_integer_type_node, index),
2361 fold_convert (long_integer_type_node, tmp_lo),
2362 fold_convert (long_integer_type_node, tmp_up));
2367 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2370 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2371 "below lower bound of %%ld", n+1, name);
2373 asprintf (&msg, "Index '%%ld' of dimension %d "
2374 "below lower bound of %%ld", n+1);
2376 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2377 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2378 fold_convert (long_integer_type_node, index),
2379 fold_convert (long_integer_type_node, tmp_lo));
2387 /* Return the offset for an index. Performs bound checking for elemental
2388 dimensions. Single element references are processed separately. */
2391 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2392 gfc_array_ref * ar, tree stride)
2398 /* Get the index into the array for this dimension. */
2401 gcc_assert (ar->type != AR_ELEMENT);
2402 switch (ar->dimen_type[dim])
2405 /* Elemental dimension. */
2406 gcc_assert (info->subscript[dim]
2407 && info->subscript[dim]->type == GFC_SS_SCALAR);
2408 /* We've already translated this value outside the loop. */
2409 index = info->subscript[dim]->data.scalar.expr;
2411 index = gfc_trans_array_bound_check (se, info->descriptor,
2412 index, dim, &ar->where,
2413 ar->as->type != AS_ASSUMED_SIZE
2414 || dim < ar->dimen - 1);
2418 gcc_assert (info && se->loop);
2419 gcc_assert (info->subscript[dim]
2420 && info->subscript[dim]->type == GFC_SS_VECTOR);
2421 desc = info->subscript[dim]->data.info.descriptor;
2423 /* Get a zero-based index into the vector. */
2424 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2425 se->loop->loopvar[i], se->loop->from[i]);
2427 /* Multiply the index by the stride. */
2428 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2429 index, gfc_conv_array_stride (desc, 0));
2431 /* Read the vector to get an index into info->descriptor. */
2432 data = build_fold_indirect_ref_loc (input_location,
2433 gfc_conv_array_data (desc));
2434 index = gfc_build_array_ref (data, index, NULL);
2435 index = gfc_evaluate_now (index, &se->pre);
2436 index = fold_convert (gfc_array_index_type, index);
2438 /* Do any bounds checking on the final info->descriptor index. */
2439 index = gfc_trans_array_bound_check (se, info->descriptor,
2440 index, dim, &ar->where,
2441 ar->as->type != AS_ASSUMED_SIZE
2442 || dim < ar->dimen - 1);
2446 /* Scalarized dimension. */
2447 gcc_assert (info && se->loop);
2449 /* Multiply the loop variable by the stride and delta. */
2450 index = se->loop->loopvar[i];
2451 if (!integer_onep (info->stride[i]))
2452 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2454 if (!integer_zerop (info->delta[i]))
2455 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2465 /* Temporary array or derived type component. */
2466 gcc_assert (se->loop);
2467 index = se->loop->loopvar[se->loop->order[i]];
2468 if (!integer_zerop (info->delta[i]))
2469 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2470 index, info->delta[i]);
2473 /* Multiply by the stride. */
2474 if (!integer_onep (stride))
2475 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2481 /* Build a scalarized reference to an array. */
2484 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2487 tree decl = NULL_TREE;
2492 info = &se->ss->data.info;
2494 n = se->loop->order[0];
2498 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2500 /* Add the offset for this dimension to the stored offset for all other
2502 if (!integer_zerop (info->offset))
2503 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2505 if (se->ss->expr && is_subref_array (se->ss->expr))
2506 decl = se->ss->expr->symtree->n.sym->backend_decl;
2508 tmp = build_fold_indirect_ref_loc (input_location,
2510 se->expr = gfc_build_array_ref (tmp, index, decl);
2514 /* Translate access of temporary array. */
2517 gfc_conv_tmp_array_ref (gfc_se * se)
2519 se->string_length = se->ss->string_length;
2520 gfc_conv_scalarized_array_ref (se, NULL);
2524 /* Build an array reference. se->expr already holds the array descriptor.
2525 This should be either a variable, indirect variable reference or component
2526 reference. For arrays which do not have a descriptor, se->expr will be
2528 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2531 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2544 /* Handle scalarized references separately. */
2545 if (ar->type != AR_ELEMENT)
2547 gfc_conv_scalarized_array_ref (se, ar);
2548 gfc_advance_se_ss_chain (se);
2552 index = gfc_index_zero_node;
2554 /* Calculate the offsets from all the dimensions. */
2555 for (n = 0; n < ar->dimen; n++)
2557 /* Calculate the index for this dimension. */
2558 gfc_init_se (&indexse, se);
2559 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2560 gfc_add_block_to_block (&se->pre, &indexse.pre);
2562 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2564 /* Check array bounds. */
2568 /* Evaluate the indexse.expr only once. */
2569 indexse.expr = save_expr (indexse.expr);
2572 tmp = gfc_conv_array_lbound (se->expr, n);
2573 if (sym->attr.temporary)
2575 gfc_init_se (&tmpse, se);
2576 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2577 gfc_array_index_type);
2578 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2582 cond = fold_build2 (LT_EXPR, boolean_type_node,
2584 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2585 "below lower bound of %%ld", n+1, sym->name);
2586 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2587 fold_convert (long_integer_type_node,
2589 fold_convert (long_integer_type_node, tmp));
2592 /* Upper bound, but not for the last dimension of assumed-size
2594 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2596 tmp = gfc_conv_array_ubound (se->expr, n);
2597 if (sym->attr.temporary)
2599 gfc_init_se (&tmpse, se);
2600 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2601 gfc_array_index_type);
2602 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2606 cond = fold_build2 (GT_EXPR, boolean_type_node,
2608 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2609 "above upper bound of %%ld", n+1, sym->name);
2610 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2611 fold_convert (long_integer_type_node,
2613 fold_convert (long_integer_type_node, tmp));
2618 /* Multiply the index by the stride. */
2619 stride = gfc_conv_array_stride (se->expr, n);
2620 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2623 /* And add it to the total. */
2624 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2627 tmp = gfc_conv_array_offset (se->expr);
2628 if (!integer_zerop (tmp))
2629 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2631 /* Access the calculated element. */
2632 tmp = gfc_conv_array_data (se->expr);
2633 tmp = build_fold_indirect_ref (tmp);
2634 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2638 /* Generate the code to be executed immediately before entering a
2639 scalarization loop. */
2642 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2643 stmtblock_t * pblock)
2652 /* This code will be executed before entering the scalarization loop
2653 for this dimension. */
2654 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2656 if ((ss->useflags & flag) == 0)
2659 if (ss->type != GFC_SS_SECTION
2660 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2661 && ss->type != GFC_SS_COMPONENT)
2664 info = &ss->data.info;
2666 if (dim >= info->dimen)
2669 if (dim == info->dimen - 1)
2671 /* For the outermost loop calculate the offset due to any
2672 elemental dimensions. It will have been initialized with the
2673 base offset of the array. */
2676 for (i = 0; i < info->ref->u.ar.dimen; i++)
2678 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2681 gfc_init_se (&se, NULL);
2683 se.expr = info->descriptor;
2684 stride = gfc_conv_array_stride (info->descriptor, i);
2685 index = gfc_conv_array_index_offset (&se, info, i, -1,
2688 gfc_add_block_to_block (pblock, &se.pre);
2690 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2691 info->offset, index);
2692 info->offset = gfc_evaluate_now (info->offset, pblock);
2696 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2699 stride = gfc_conv_array_stride (info->descriptor, 0);
2701 /* Calculate the stride of the innermost loop. Hopefully this will
2702 allow the backend optimizers to do their stuff more effectively.
2704 info->stride0 = gfc_evaluate_now (stride, pblock);
2708 /* Add the offset for the previous loop dimension. */
2713 ar = &info->ref->u.ar;
2714 i = loop->order[dim + 1];
2722 gfc_init_se (&se, NULL);
2724 se.expr = info->descriptor;
2725 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2726 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2728 gfc_add_block_to_block (pblock, &se.pre);
2729 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2730 info->offset, index);
2731 info->offset = gfc_evaluate_now (info->offset, pblock);
2734 /* Remember this offset for the second loop. */
2735 if (dim == loop->temp_dim - 1)
2736 info->saved_offset = info->offset;
2741 /* Start a scalarized expression. Creates a scope and declares loop
2745 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2751 gcc_assert (!loop->array_parameter);
2753 for (dim = loop->dimen - 1; dim >= 0; dim--)
2755 n = loop->order[dim];
2757 gfc_start_block (&loop->code[n]);
2759 /* Create the loop variable. */
2760 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2762 if (dim < loop->temp_dim)
2766 /* Calculate values that will be constant within this loop. */
2767 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2769 gfc_start_block (pbody);
2773 /* Generates the actual loop code for a scalarization loop. */
2776 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2777 stmtblock_t * pbody)
2788 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2789 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2790 && n == loop->dimen - 1)
2792 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2793 init = make_tree_vec (1);
2794 cond = make_tree_vec (1);
2795 incr = make_tree_vec (1);
2797 /* Cycle statement is implemented with a goto. Exit statement must not
2798 be present for this loop. */
2799 exit_label = gfc_build_label_decl (NULL_TREE);
2800 TREE_USED (exit_label) = 1;
2802 /* Label for cycle statements (if needed). */
2803 tmp = build1_v (LABEL_EXPR, exit_label);
2804 gfc_add_expr_to_block (pbody, tmp);
2806 stmt = make_node (OMP_FOR);
2808 TREE_TYPE (stmt) = void_type_node;
2809 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2811 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2812 OMP_CLAUSE_SCHEDULE);
2813 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2814 = OMP_CLAUSE_SCHEDULE_STATIC;
2815 if (ompws_flags & OMPWS_NOWAIT)
2816 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2817 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2819 /* Initialize the loopvar. */
2820 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2822 OMP_FOR_INIT (stmt) = init;
2823 /* The exit condition. */
2824 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2825 loop->loopvar[n], loop->to[n]);
2826 OMP_FOR_COND (stmt) = cond;
2827 /* Increment the loopvar. */
2828 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2829 loop->loopvar[n], gfc_index_one_node);
2830 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2831 void_type_node, loop->loopvar[n], tmp);
2832 OMP_FOR_INCR (stmt) = incr;
2834 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2835 gfc_add_expr_to_block (&loop->code[n], stmt);
2839 loopbody = gfc_finish_block (pbody);
2841 /* Initialize the loopvar. */
2842 if (loop->loopvar[n] != loop->from[n])
2843 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2845 exit_label = gfc_build_label_decl (NULL_TREE);
2847 /* Generate the loop body. */
2848 gfc_init_block (&block);
2850 /* The exit condition. */
2851 cond = fold_build2 (GT_EXPR, boolean_type_node,
2852 loop->loopvar[n], loop->to[n]);
2853 tmp = build1_v (GOTO_EXPR, exit_label);
2854 TREE_USED (exit_label) = 1;
2855 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2856 gfc_add_expr_to_block (&block, tmp);
2858 /* The main body. */
2859 gfc_add_expr_to_block (&block, loopbody);
2861 /* Increment the loopvar. */
2862 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2863 loop->loopvar[n], gfc_index_one_node);
2864 gfc_add_modify (&block, loop->loopvar[n], tmp);
2866 /* Build the loop. */
2867 tmp = gfc_finish_block (&block);
2868 tmp = build1_v (LOOP_EXPR, tmp);
2869 gfc_add_expr_to_block (&loop->code[n], tmp);
2871 /* Add the exit label. */
2872 tmp = build1_v (LABEL_EXPR, exit_label);
2873 gfc_add_expr_to_block (&loop->code[n], tmp);
2879 /* Finishes and generates the loops for a scalarized expression. */
2882 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2887 stmtblock_t *pblock;
2891 /* Generate the loops. */
2892 for (dim = 0; dim < loop->dimen; dim++)
2894 n = loop->order[dim];
2895 gfc_trans_scalarized_loop_end (loop, n, pblock);
2896 loop->loopvar[n] = NULL_TREE;
2897 pblock = &loop->code[n];
2900 tmp = gfc_finish_block (pblock);
2901 gfc_add_expr_to_block (&loop->pre, tmp);
2903 /* Clear all the used flags. */
2904 for (ss = loop->ss; ss; ss = ss->loop_chain)
2909 /* Finish the main body of a scalarized expression, and start the secondary
2913 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2917 stmtblock_t *pblock;
2921 /* We finish as many loops as are used by the temporary. */
2922 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2924 n = loop->order[dim];
2925 gfc_trans_scalarized_loop_end (loop, n, pblock);
2926 loop->loopvar[n] = NULL_TREE;
2927 pblock = &loop->code[n];
2930 /* We don't want to finish the outermost loop entirely. */
2931 n = loop->order[loop->temp_dim - 1];
2932 gfc_trans_scalarized_loop_end (loop, n, pblock);
2934 /* Restore the initial offsets. */
2935 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2937 if ((ss->useflags & 2) == 0)
2940 if (ss->type != GFC_SS_SECTION
2941 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2942 && ss->type != GFC_SS_COMPONENT)
2945 ss->data.info.offset = ss->data.info.saved_offset;
2948 /* Restart all the inner loops we just finished. */
2949 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2951 n = loop->order[dim];
2953 gfc_start_block (&loop->code[n]);
2955 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2957 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2960 /* Start a block for the secondary copying code. */
2961 gfc_start_block (body);
2965 /* Calculate the upper bound of an array section. */
2968 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2977 gcc_assert (ss->type == GFC_SS_SECTION);
2979 info = &ss->data.info;
2982 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2983 /* We'll calculate the upper bound once we have access to the
2984 vector's descriptor. */
2987 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2988 desc = info->descriptor;
2989 end = info->ref->u.ar.end[dim];
2993 /* The upper bound was specified. */
2994 gfc_init_se (&se, NULL);
2995 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2996 gfc_add_block_to_block (pblock, &se.pre);
3001 /* No upper bound was specified, so use the bound of the array. */
3002 bound = gfc_conv_array_ubound (desc, dim);
3009 /* Calculate the lower bound of an array section. */
3012 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3022 gcc_assert (ss->type == GFC_SS_SECTION);
3024 info = &ss->data.info;
3027 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3029 /* We use a zero-based index to access the vector. */
3030 info->start[n] = gfc_index_zero_node;
3031 info->end[n] = gfc_index_zero_node;
3032 info->stride[n] = gfc_index_one_node;
3036 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3037 desc = info->descriptor;
3038 start = info->ref->u.ar.start[dim];
3039 end = info->ref->u.ar.end[dim];
3040 stride = info->ref->u.ar.stride[dim];
3042 /* Calculate the start of the range. For vector subscripts this will
3043 be the range of the vector. */
3046 /* Specified section start. */
3047 gfc_init_se (&se, NULL);
3048 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3049 gfc_add_block_to_block (&loop->pre, &se.pre);
3050 info->start[n] = se.expr;
3054 /* No lower bound specified so use the bound of the array. */
3055 info->start[n] = gfc_conv_array_lbound (desc, dim);
3057 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3059 /* Similarly calculate the end. Although this is not used in the
3060 scalarizer, it is needed when checking bounds and where the end
3061 is an expression with side-effects. */
3064 /* Specified section start. */
3065 gfc_init_se (&se, NULL);
3066 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3067 gfc_add_block_to_block (&loop->pre, &se.pre);
3068 info->end[n] = se.expr;
3072 /* No upper bound specified so use the bound of the array. */
3073 info->end[n] = gfc_conv_array_ubound (desc, dim);
3075 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3077 /* Calculate the stride. */
3079 info->stride[n] = gfc_index_one_node;
3082 gfc_init_se (&se, NULL);
3083 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3084 gfc_add_block_to_block (&loop->pre, &se.pre);
3085 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3090 /* Calculates the range start and stride for a SS chain. Also gets the
3091 descriptor and data pointer. The range of vector subscripts is the size
3092 of the vector. Array bounds are also checked. */
3095 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3103 /* Determine the rank of the loop. */
3105 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3109 case GFC_SS_SECTION:
3110 case GFC_SS_CONSTRUCTOR:
3111 case GFC_SS_FUNCTION:
3112 case GFC_SS_COMPONENT:
3113 loop->dimen = ss->data.info.dimen;
3116 /* As usual, lbound and ubound are exceptions!. */
3117 case GFC_SS_INTRINSIC:
3118 switch (ss->expr->value.function.isym->id)
3120 case GFC_ISYM_LBOUND:
3121 case GFC_ISYM_UBOUND:
3122 loop->dimen = ss->data.info.dimen;
3133 /* We should have determined the rank of the expression by now. If
3134 not, that's bad news. */
3135 gcc_assert (loop->dimen != 0);
3137 /* Loop over all the SS in the chain. */
3138 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3140 if (ss->expr && ss->expr->shape && !ss->shape)
3141 ss->shape = ss->expr->shape;
3145 case GFC_SS_SECTION:
3146 /* Get the descriptor for the array. */
3147 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3149 for (n = 0; n < ss->data.info.dimen; n++)
3150 gfc_conv_section_startstride (loop, ss, n);
3153 case GFC_SS_INTRINSIC:
3154 switch (ss->expr->value.function.isym->id)
3156 /* Fall through to supply start and stride. */
3157 case GFC_ISYM_LBOUND:
3158 case GFC_ISYM_UBOUND:
3164 case GFC_SS_CONSTRUCTOR:
3165 case GFC_SS_FUNCTION:
3166 for (n = 0; n < ss->data.info.dimen; n++)
3168 ss->data.info.start[n] = gfc_index_zero_node;
3169 ss->data.info.end[n] = gfc_index_zero_node;
3170 ss->data.info.stride[n] = gfc_index_one_node;
3179 /* The rest is just runtime bound checking. */
3180 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3183 tree lbound, ubound;
3185 tree size[GFC_MAX_DIMENSIONS];
3186 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3191 gfc_start_block (&block);
3193 for (n = 0; n < loop->dimen; n++)
3194 size[n] = NULL_TREE;
3196 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3200 if (ss->type != GFC_SS_SECTION)
3203 gfc_start_block (&inner);
3205 /* TODO: range checking for mapped dimensions. */
3206 info = &ss->data.info;
3208 /* This code only checks ranges. Elemental and vector
3209 dimensions are checked later. */
3210 for (n = 0; n < loop->dimen; n++)
3215 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3218 if (dim == info->ref->u.ar.dimen - 1
3219 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3220 check_upper = false;
3224 /* Zero stride is not allowed. */
3225 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3226 gfc_index_zero_node);
3227 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3228 "of array '%s'", info->dim[n]+1,
3229 ss->expr->symtree->name);
3230 gfc_trans_runtime_check (true, false, tmp, &inner,
3231 &ss->expr->where, msg);
3234 desc = ss->data.info.descriptor;
3236 /* This is the run-time equivalent of resolve.c's
3237 check_dimension(). The logical is more readable there
3238 than it is here, with all the trees. */
3239 lbound = gfc_conv_array_lbound (desc, dim);
3242 ubound = gfc_conv_array_ubound (desc, dim);
3246 /* non_zerosized is true when the selected range is not
3248 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3249 info->stride[n], gfc_index_zero_node);
3250 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3252 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3255 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3256 info->stride[n], gfc_index_zero_node);
3257 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3259 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3261 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3262 stride_pos, stride_neg);
3264 /* Check the start of the range against the lower and upper
3265 bounds of the array, if the range is not empty.
3266 If upper bound is present, include both bounds in the
3270 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3271 info->start[n], lbound);
3272 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3273 non_zerosized, tmp);
3274 tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3275 info->start[n], ubound);
3276 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3277 non_zerosized, tmp2);
3278 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3279 "outside of expected range (%%ld:%%ld)",
3280 info->dim[n]+1, ss->expr->symtree->name);
3281 gfc_trans_runtime_check (true, false, tmp, &inner,
3282 &ss->expr->where, msg,
3283 fold_convert (long_integer_type_node, info->start[n]),
3284 fold_convert (long_integer_type_node, lbound),
3285 fold_convert (long_integer_type_node, ubound));
3286 gfc_trans_runtime_check (true, false, tmp2, &inner,
3287 &ss->expr->where, msg,
3288 fold_convert (long_integer_type_node, info->start[n]),
3289 fold_convert (long_integer_type_node, lbound),
3290 fold_convert (long_integer_type_node, ubound));
3295 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3296 info->start[n], lbound);
3297 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3298 non_zerosized, tmp);
3299 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3300 "below lower bound of %%ld",
3301 info->dim[n]+1, ss->expr->symtree->name);
3302 gfc_trans_runtime_check (true, false, tmp, &inner,
3303 &ss->expr->where, msg,
3304 fold_convert (long_integer_type_node, info->start[n]),
3305 fold_convert (long_integer_type_node, lbound));
3309 /* Compute the last element of the range, which is not
3310 necessarily "end" (think 0:5:3, which doesn't contain 5)
3311 and check it against both lower and upper bounds. */
3313 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3315 tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3317 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3319 tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3320 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3321 non_zerosized, tmp2);
3324 tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3325 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3326 non_zerosized, tmp3);
3327 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3328 "outside of expected range (%%ld:%%ld)",
3329 info->dim[n]+1, ss->expr->symtree->name);
3330 gfc_trans_runtime_check (true, false, tmp2, &inner,
3331 &ss->expr->where, msg,
3332 fold_convert (long_integer_type_node, tmp),
3333 fold_convert (long_integer_type_node, ubound),
3334 fold_convert (long_integer_type_node, lbound));
3335 gfc_trans_runtime_check (true, false, tmp3, &inner,
3336 &ss->expr->where, msg,
3337 fold_convert (long_integer_type_node, tmp),
3338 fold_convert (long_integer_type_node, ubound),
3339 fold_convert (long_integer_type_node, lbound));
3344 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3345 "below lower bound of %%ld",
3346 info->dim[n]+1, ss->expr->symtree->name);
3347 gfc_trans_runtime_check (true, false, tmp2, &inner,
3348 &ss->expr->where, msg,
3349 fold_convert (long_integer_type_node, tmp),
3350 fold_convert (long_integer_type_node, lbound));
3354 /* Check the section sizes match. */
3355 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3357 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3359 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3360 gfc_index_one_node, tmp);
3361 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3362 build_int_cst (gfc_array_index_type, 0));
3363 /* We remember the size of the first section, and check all the
3364 others against this. */
3367 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3368 asprintf (&msg, "Array bound mismatch for dimension %d "
3369 "of array '%s' (%%ld/%%ld)",
3370 info->dim[n]+1, ss->expr->symtree->name);
3372 gfc_trans_runtime_check (true, false, tmp3, &inner,
3373 &ss->expr->where, msg,
3374 fold_convert (long_integer_type_node, tmp),
3375 fold_convert (long_integer_type_node, size[n]));
3380 size[n] = gfc_evaluate_now (tmp, &inner);
3383 tmp = gfc_finish_block (&inner);
3385 /* For optional arguments, only check bounds if the argument is
3387 if (ss->expr->symtree->n.sym->attr.optional
3388 || ss->expr->symtree->n.sym->attr.not_always_present)
3389 tmp = build3_v (COND_EXPR,
3390 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3391 tmp, build_empty_stmt (input_location));
3393 gfc_add_expr_to_block (&block, tmp);
3397 tmp = gfc_finish_block (&block);
3398 gfc_add_expr_to_block (&loop->pre, tmp);
3403 /* Return true if the two SS could be aliased, i.e. both point to the same data
3405 /* TODO: resolve aliases based on frontend expressions. */
3408 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3415 lsym = lss->expr->symtree->n.sym;
3416 rsym = rss->expr->symtree->n.sym;
3417 if (gfc_symbols_could_alias (lsym, rsym))
3420 if (rsym->ts.type != BT_DERIVED
3421 && lsym->ts.type != BT_DERIVED)
3424 /* For derived types we must check all the component types. We can ignore
3425 array references as these will have the same base type as the previous
3427 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3429 if (lref->type != REF_COMPONENT)
3432 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3435 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3438 if (rref->type != REF_COMPONENT)
3441 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3446 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3448 if (rref->type != REF_COMPONENT)
3451 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3459 /* Resolve array data dependencies. Creates a temporary if required. */
3460 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3464 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3472 loop->temp_ss = NULL;
3474 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3476 if (ss->type != GFC_SS_SECTION)
3479 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3481 if (gfc_could_be_alias (dest, ss)
3482 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3490 lref = dest->expr->ref;
3491 rref = ss->expr->ref;
3493 nDepend = gfc_dep_resolver (lref, rref);
3497 /* TODO : loop shifting. */
3500 /* Mark the dimensions for LOOP SHIFTING */
3501 for (n = 0; n < loop->dimen; n++)
3503 int dim = dest->data.info.dim[n];
3505 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3507 else if (! gfc_is_same_range (&lref->u.ar,
3508 &rref->u.ar, dim, 0))
3512 /* Put all the dimensions with dependencies in the
3515 for (n = 0; n < loop->dimen; n++)
3517 gcc_assert (loop->order[n] == n);
3519 loop->order[dim++] = n;
3521 for (n = 0; n < loop->dimen; n++)
3524 loop->order[dim++] = n;
3527 gcc_assert (dim == loop->dimen);
3536 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3537 if (GFC_ARRAY_TYPE_P (base_type)
3538 || GFC_DESCRIPTOR_TYPE_P (base_type))
3539 base_type = gfc_get_element_type (base_type);
3540 loop->temp_ss = gfc_get_ss ();
3541 loop->temp_ss->type = GFC_SS_TEMP;
3542 loop->temp_ss->data.temp.type = base_type;
3543 loop->temp_ss->string_length = dest->string_length;
3544 loop->temp_ss->data.temp.dimen = loop->dimen;
3545 loop->temp_ss->next = gfc_ss_terminator;
3546 gfc_add_ss_to_loop (loop, loop->temp_ss);
3549 loop->temp_ss = NULL;
3553 /* Initialize the scalarization loop. Creates the loop variables. Determines
3554 the range of the loop variables. Creates a temporary if required.
3555 Calculates how to transform from loop variables to array indices for each
3556 expression. Also generates code for scalar expressions which have been
3557 moved outside the loop. */
3560 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3564 gfc_ss_info *specinfo;
3567 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3568 bool dynamic[GFC_MAX_DIMENSIONS];
3573 for (n = 0; n < loop->dimen; n++)
3577 /* We use one SS term, and use that to determine the bounds of the
3578 loop for this dimension. We try to pick the simplest term. */
3579 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3583 /* The frontend has worked out the size for us. */
3584 if (!loopspec[n] || !loopspec[n]->shape
3585 || !integer_zerop (loopspec[n]->data.info.start[n]))
3586 /* Prefer zero-based descriptors if possible. */
3591 if (ss->type == GFC_SS_CONSTRUCTOR)
3593 gfc_constructor_base base;
3594 /* An unknown size constructor will always be rank one.
3595 Higher rank constructors will either have known shape,
3596 or still be wrapped in a call to reshape. */
3597 gcc_assert (loop->dimen == 1);
3599 /* Always prefer to use the constructor bounds if the size
3600 can be determined at compile time. Prefer not to otherwise,
3601 since the general case involves realloc, and it's better to
3602 avoid that overhead if possible. */
3603 base = ss->expr->value.constructor;
3604 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3605 if (!dynamic[n] || !loopspec[n])
3610 /* TODO: Pick the best bound if we have a choice between a
3611 function and something else. */
3612 if (ss->type == GFC_SS_FUNCTION)
3618 if (ss->type != GFC_SS_SECTION)
3622 specinfo = &loopspec[n]->data.info;
3625 info = &ss->data.info;
3629 /* Criteria for choosing a loop specifier (most important first):
3630 doesn't need realloc
3636 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3638 else if (integer_onep (info->stride[n])
3639 && !integer_onep (specinfo->stride[n]))
3641 else if (INTEGER_CST_P (info->stride[n])
3642 && !INTEGER_CST_P (specinfo->stride[n]))
3644 else if (INTEGER_CST_P (info->start[n])
3645 && !INTEGER_CST_P (specinfo->start[n]))
3647 /* We don't work out the upper bound.
3648 else if (INTEGER_CST_P (info->finish[n])
3649 && ! INTEGER_CST_P (specinfo->finish[n]))
3650 loopspec[n] = ss; */
3653 /* We should have found the scalarization loop specifier. If not,
3655 gcc_assert (loopspec[n]);
3657 info = &loopspec[n]->data.info;
3659 /* Set the extents of this range. */
3660 cshape = loopspec[n]->shape;
3661 if (cshape && INTEGER_CST_P (info->start[n])
3662 && INTEGER_CST_P (info->stride[n]))
3664 loop->from[n] = info->start[n];
3665 mpz_set (i, cshape[n]);
3666 mpz_sub_ui (i, i, 1);
3667 /* To = from + (size - 1) * stride. */
3668 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3669 if (!integer_onep (info->stride[n]))
3670 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3671 tmp, info->stride[n]);
3672 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3673 loop->from[n], tmp);
3677 loop->from[n] = info->start[n];
3678 switch (loopspec[n]->type)
3680 case GFC_SS_CONSTRUCTOR:
3681 /* The upper bound is calculated when we expand the
3683 gcc_assert (loop->to[n] == NULL_TREE);
3686 case GFC_SS_SECTION:
3687 /* Use the end expression if it exists and is not constant,
3688 so that it is only evaluated once. */
3689 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3690 loop->to[n] = info->end[n];
3692 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3696 case GFC_SS_FUNCTION:
3697 /* The loop bound will be set when we generate the call. */
3698 gcc_assert (loop->to[n] == NULL_TREE);
3706 /* Transform everything so we have a simple incrementing variable. */
3707 if (integer_onep (info->stride[n]))
3708 info->delta[n] = gfc_index_zero_node;
3711 /* Set the delta for this section. */
3712 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3713 /* Number of iterations is (end - start + step) / step.
3714 with start = 0, this simplifies to
3716 for (i = 0; i<=last; i++){...}; */
3717 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3718 loop->to[n], loop->from[n]);
3719 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3720 tmp, info->stride[n]);
3721 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3722 build_int_cst (gfc_array_index_type, -1));
3723 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3724 /* Make the loop variable start at 0. */
3725 loop->from[n] = gfc_index_zero_node;
3729 /* Add all the scalar code that can be taken out of the loops.
3730 This may include calculating the loop bounds, so do it before
3731 allocating the temporary. */
3732 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3734 /* If we want a temporary then create it. */
3735 if (loop->temp_ss != NULL)
3737 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3739 /* Make absolutely sure that this is a complete type. */
3740 if (loop->temp_ss->string_length)
3741 loop->temp_ss->data.temp.type
3742 = gfc_get_character_type_len_for_eltype
3743 (TREE_TYPE (loop->temp_ss->data.temp.type),
3744 loop->temp_ss->string_length);
3746 tmp = loop->temp_ss->data.temp.type;
3747 n = loop->temp_ss->data.temp.dimen;
3748 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3749 loop->temp_ss->type = GFC_SS_SECTION;
3750 loop->temp_ss->data.info.dimen = n;
3751 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3752 &loop->temp_ss->data.info, tmp, NULL_TREE,
3753 false, true, false, where);
3756 for (n = 0; n < loop->temp_dim; n++)
3757 loopspec[loop->order[n]] = NULL;
3761 /* For array parameters we don't have loop variables, so don't calculate the
3763 if (loop->array_parameter)
3766 /* Calculate the translation from loop variables to array indices. */
3767 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3769 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3770 && ss->type != GFC_SS_CONSTRUCTOR)
3774 info = &ss->data.info;
3776 for (n = 0; n < info->dimen; n++)
3778 /* If we are specifying the range the delta is already set. */
3779 if (loopspec[n] != ss)
3781 /* Calculate the offset relative to the loop variable.
3782 First multiply by the stride. */
3783 tmp = loop->from[n];
3784 if (!integer_onep (info->stride[n]))
3785 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3786 tmp, info->stride[n]);
3788 /* Then subtract this from our starting value. */
3789 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3790 info->start[n], tmp);
3792 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3799 /* Fills in an array descriptor, and returns the size of the array. The size
3800 will be a simple_val, ie a variable or a constant. Also calculates the
3801 offset of the base. Returns the size of the array.
3805 for (n = 0; n < rank; n++)
3807 a.lbound[n] = specified_lower_bound;
3808 offset = offset + a.lbond[n] * stride;
3810 a.ubound[n] = specified_upper_bound;
3811 a.stride[n] = stride;
3812 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3813 stride = stride * size;
3820 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
3821 gfc_expr ** lower, gfc_expr ** upper,
3822 stmtblock_t * pblock)
3834 stmtblock_t thenblock;
3835 stmtblock_t elseblock;
3840 type = TREE_TYPE (descriptor);
3842 stride = gfc_index_one_node;
3843 offset = gfc_index_zero_node;
3845 /* Set the dtype. */
3846 tmp = gfc_conv_descriptor_dtype (descriptor);
3847 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3849 or_expr = NULL_TREE;
3851 for (n = 0; n < rank; n++)
3853 /* We have 3 possibilities for determining the size of the array:
3854 lower == NULL => lbound = 1, ubound = upper[n]
3855 upper[n] = NULL => lbound = 1, ubound = lower[n]
3856 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3859 /* Set lower bound. */
3860 gfc_init_se (&se, NULL);
3862 se.expr = gfc_index_one_node;
3865 gcc_assert (lower[n]);
3868 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3869 gfc_add_block_to_block (pblock, &se.pre);
3873 se.expr = gfc_index_one_node;
3877 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3880 /* Work out the offset for this component. */
3881 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3882 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3884 /* Start the calculation for the size of this dimension. */
3885 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3886 gfc_index_one_node, se.expr);
3888 /* Set upper bound. */
3889 gfc_init_se (&se, NULL);
3890 gcc_assert (ubound);
3891 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3892 gfc_add_block_to_block (pblock, &se.pre);
3894 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3896 /* Store the stride. */
3897 gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3899 /* Calculate the size of this dimension. */
3900 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3902 /* Check whether the size for this dimension is negative. */
3903 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3904 gfc_index_zero_node);
3908 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3910 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3911 gfc_index_zero_node, size);
3913 /* Multiply the stride by the number of elements in this dimension. */
3914 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3915 stride = gfc_evaluate_now (stride, pblock);
3918 for (n = rank; n < rank + corank; n++)
3922 /* Set lower bound. */
3923 gfc_init_se (&se, NULL);
3924 if (lower == NULL || lower[n] == NULL)
3926 gcc_assert (n == rank + corank - 1);
3927 se.expr = gfc_index_one_node;
3931 if (ubound || n == rank + corank - 1)
3933 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3934 gfc_add_block_to_block (pblock, &se.pre);
3938 se.expr = gfc_index_one_node;
3942 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3945 if (n < rank + corank - 1)
3947 gfc_init_se (&se, NULL);
3948 gcc_assert (ubound);
3949 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3950 gfc_add_block_to_block (pblock, &se.pre);
3951 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3955 /* The stride is the number of elements in the array, so multiply by the
3956 size of an element to get the total size. */
3957 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3958 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3959 fold_convert (gfc_array_index_type, tmp));
3961 if (poffset != NULL)
3963 offset = gfc_evaluate_now (offset, pblock);
3967 if (integer_zerop (or_expr))
3969 if (integer_onep (or_expr))
3970 return gfc_index_zero_node;
3972 var = gfc_create_var (TREE_TYPE (size), "size");
3973 gfc_start_block (&thenblock);
3974 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3975 thencase = gfc_finish_block (&thenblock);
3977 gfc_start_block (&elseblock);
3978 gfc_add_modify (&elseblock, var, size);
3979 elsecase = gfc_finish_block (&elseblock);
3981 tmp = gfc_evaluate_now (or_expr, pblock);
3982 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3983 gfc_add_expr_to_block (pblock, tmp);
3989 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3990 the work for an ALLOCATE statement. */
3994 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4002 gfc_ref *ref, *prev_ref = NULL;
4003 bool allocatable_array, coarray;
4007 /* Find the last reference in the chain. */
4008 while (ref && ref->next != NULL)
4010 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4011 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4016 if (ref == NULL || ref->type != REF_ARRAY)
4021 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4022 coarray = expr->symtree->n.sym->attr.codimension;
4026 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4027 coarray = prev_ref->u.c.component->attr.codimension;
4030 /* Return if this is a scalar coarray. */
4031 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4032 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4034 gcc_assert (coarray);
4038 /* Figure out the size of the array. */
4039 switch (ref->u.ar.type)
4045 upper = ref->u.ar.start;
4051 lower = ref->u.ar.start;
4052 upper = ref->u.ar.end;
4056 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4058 lower = ref->u.ar.as->lower;
4059 upper = ref->u.ar.as->upper;
4067 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4068 ref->u.ar.as->corank, &offset, lower, upper,
4071 /* Allocate memory to store the data. */
4072 pointer = gfc_conv_descriptor_data_get (se->expr);
4073 STRIP_NOPS (pointer);
4075 /* The allocate_array variants take the old pointer as first argument. */
4076 if (allocatable_array)
4077 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4079 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4080 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
4081 gfc_add_expr_to_block (&se->pre, tmp);
4083 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4085 if (expr->ts.type == BT_DERIVED
4086 && expr->ts.u.derived->attr.alloc_comp)
4088 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4089 ref->u.ar.as->rank);
4090 gfc_add_expr_to_block (&se->pre, tmp);
4097 /* Deallocate an array variable. Also used when an allocated variable goes
4102 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4108 gfc_start_block (&block);
4109 /* Get a pointer to the data. */
4110 var = gfc_conv_descriptor_data_get (descriptor);
4113 /* Parameter is the address of the data component. */
4114 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4115 gfc_add_expr_to_block (&block, tmp);
4117 /* Zero the data pointer. */
4118 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4119 var, build_int_cst (TREE_TYPE (var), 0));
4120 gfc_add_expr_to_block (&block, tmp);
4122 return gfc_finish_block (&block);
4126 /* Create an array constructor from an initialization expression.
4127 We assume the frontend already did any expansions and conversions. */
4130 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4136 unsigned HOST_WIDE_INT lo;
4138 VEC(constructor_elt,gc) *v = NULL;
4140 switch (expr->expr_type)
4143 case EXPR_STRUCTURE:
4144 /* A single scalar or derived type value. Create an array with all
4145 elements equal to that value. */
4146 gfc_init_se (&se, NULL);
4148 if (expr->expr_type == EXPR_CONSTANT)
4149 gfc_conv_constant (&se, expr);
4151 gfc_conv_structure (&se, expr, 1);
4153 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4154 gcc_assert (tmp && INTEGER_CST_P (tmp));
4155 hi = TREE_INT_CST_HIGH (tmp);
4156 lo = TREE_INT_CST_LOW (tmp);
4160 /* This will probably eat buckets of memory for large arrays. */
4161 while (hi != 0 || lo != 0)
4163 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4171 /* Create a vector of all the elements. */
4172 for (c = gfc_constructor_first (expr->value.constructor);
4173 c; c = gfc_constructor_next (c))
4177 /* Problems occur when we get something like
4178 integer :: a(lots) = (/(i, i=1, lots)/) */
4179 gfc_fatal_error ("The number of elements in the array constructor "
4180 "at %L requires an increase of the allowed %d "
4181 "upper limit. See -fmax-array-constructor "
4182 "option", &expr->where,
4183 gfc_option.flag_max_array_constructor);
4186 if (mpz_cmp_si (c->offset, 0) != 0)
4187 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4191 gfc_init_se (&se, NULL);
4192 switch (c->expr->expr_type)
4195 gfc_conv_constant (&se, c->expr);
4196 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4199 case EXPR_STRUCTURE:
4200 gfc_conv_structure (&se, c->expr, 1);
4201 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4206 /* Catch those occasional beasts that do not simplify
4207 for one reason or another, assuming that if they are
4208 standard defying the frontend will catch them. */
4209 gfc_conv_expr (&se, c->expr);
4210 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4217 return gfc_build_null_descriptor (type);
4223 /* Create a constructor from the list of elements. */
4224 tmp = build_constructor (type, v);
4225 TREE_CONSTANT (tmp) = 1;
4230 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4231 returns the size (in elements) of the array. */
4234 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4235 stmtblock_t * pblock)
4250 size = gfc_index_one_node;
4251 offset = gfc_index_zero_node;
4252 for (dim = 0; dim < as->rank; dim++)
4254 /* Evaluate non-constant array bound expressions. */
4255 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4256 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4258 gfc_init_se (&se, NULL);
4259 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4260 gfc_add_block_to_block (pblock, &se.pre);
4261 gfc_add_modify (pblock, lbound, se.expr);
4263 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4264 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4266 gfc_init_se (&se, NULL);
4267 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4268 gfc_add_block_to_block (pblock, &se.pre);
4269 gfc_add_modify (pblock, ubound, se.expr);
4271 /* The offset of this dimension. offset = offset - lbound * stride. */
4272 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4273 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4275 /* The size of this dimension, and the stride of the next. */
4276 if (dim + 1 < as->rank)
4277 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4279 stride = GFC_TYPE_ARRAY_SIZE (type);
4281 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4283 /* Calculate stride = size * (ubound + 1 - lbound). */
4284 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4285 gfc_index_one_node, lbound);
4286 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4287 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4289 gfc_add_modify (pblock, stride, tmp);
4291 stride = gfc_evaluate_now (tmp, pblock);
4293 /* Make sure that negative size arrays are translated
4294 to being zero size. */
4295 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4296 stride, gfc_index_zero_node);
4297 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4298 stride, gfc_index_zero_node);
4299 gfc_add_modify (pblock, stride, tmp);
4305 gfc_trans_vla_type_sizes (sym, pblock);
4312 /* Generate code to initialize/allocate an array variable. */
4315 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4324 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4326 /* Do nothing for USEd variables. */
4327 if (sym->attr.use_assoc)
4330 type = TREE_TYPE (decl);
4331 gcc_assert (GFC_ARRAY_TYPE_P (type));
4332 onstack = TREE_CODE (type) != POINTER_TYPE;
4334 gfc_start_block (&block);
4336 /* Evaluate character string length. */
4337 if (sym->ts.type == BT_CHARACTER
4338 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4340 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4342 gfc_trans_vla_type_sizes (sym, &block);
4344 /* Emit a DECL_EXPR for this variable, which will cause the
4345 gimplifier to allocate storage, and all that good stuff. */
4346 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4347 gfc_add_expr_to_block (&block, tmp);
4352 gfc_add_expr_to_block (&block, fnbody);
4353 return gfc_finish_block (&block);
4356 type = TREE_TYPE (type);
4358 gcc_assert (!sym->attr.use_assoc);
4359 gcc_assert (!TREE_STATIC (decl));
4360 gcc_assert (!sym->module);
4362 if (sym->ts.type == BT_CHARACTER
4363 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4364 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4366 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4368 /* Don't actually allocate space for Cray Pointees. */
4369 if (sym->attr.cray_pointee)
4371 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4372 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4373 gfc_add_expr_to_block (&block, fnbody);
4374 return gfc_finish_block (&block);
4377 /* The size is the number of elements in the array, so multiply by the
4378 size of an element to get the total size. */
4379 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4380 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4381 fold_convert (gfc_array_index_type, tmp));
4383 /* Allocate memory to hold the data. */
4384 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4385 gfc_add_modify (&block, decl, tmp);
4387 /* Set offset of the array. */
4388 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4389 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4392 /* Automatic arrays should not have initializers. */
4393 gcc_assert (!sym->value);
4395 gfc_add_expr_to_block (&block, fnbody);
4397 /* Free the temporary. */
4398 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4399 gfc_add_expr_to_block (&block, tmp);
4401 return gfc_finish_block (&block);
4405 /* Generate entry and exit code for g77 calling convention arrays. */
4408 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4418 gfc_get_backend_locus (&loc);
4419 gfc_set_backend_locus (&sym->declared_at);
4421 /* Descriptor type. */
4422 parm = sym->backend_decl;
4423 type = TREE_TYPE (parm);
4424 gcc_assert (GFC_ARRAY_TYPE_P (type));
4426 gfc_start_block (&block);
4428 if (sym->ts.type == BT_CHARACTER
4429 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4430 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4432 /* Evaluate the bounds of the array. */
4433 gfc_trans_array_bounds (type, sym, &offset, &block);
4435 /* Set the offset. */
4436 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4437 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4439 /* Set the pointer itself if we aren't using the parameter directly. */
4440 if (TREE_CODE (parm) != PARM_DECL)
4442 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4443 gfc_add_modify (&block, parm, tmp);
4445 stmt = gfc_finish_block (&block);
4447 gfc_set_backend_locus (&loc);
4449 gfc_start_block (&block);
4451 /* Add the initialization code to the start of the function. */
4453 if (sym->attr.optional || sym->attr.not_always_present)
4455 tmp = gfc_conv_expr_present (sym);
4456 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4459 gfc_add_expr_to_block (&block, stmt);
4460 gfc_add_expr_to_block (&block, body);
4462 return gfc_finish_block (&block);
4466 /* Modify the descriptor of an array parameter so that it has the
4467 correct lower bound. Also move the upper bound accordingly.
4468 If the array is not packed, it will be copied into a temporary.
4469 For each dimension we set the new lower and upper bounds. Then we copy the
4470 stride and calculate the offset for this dimension. We also work out
4471 what the stride of a packed array would be, and see it the two match.
4472 If the array need repacking, we set the stride to the values we just
4473 calculated, recalculate the offset and copy the array data.
4474 Code is also added to copy the data back at the end of the function.
4478 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4485 stmtblock_t cleanup;
4493 tree stride, stride2;
4503 /* Do nothing for pointer and allocatable arrays. */
4504 if (sym->attr.pointer || sym->attr.allocatable)
4507 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4508 return gfc_trans_g77_array (sym, body);
4510 gfc_get_backend_locus (&loc);
4511 gfc_set_backend_locus (&sym->declared_at);
4513 /* Descriptor type. */
4514 type = TREE_TYPE (tmpdesc);
4515 gcc_assert (GFC_ARRAY_TYPE_P (type));
4516 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4517 dumdesc = build_fold_indirect_ref_loc (input_location,
4519 gfc_start_block (&block);
4521 if (sym->ts.type == BT_CHARACTER
4522 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4523 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4525 checkparm = (sym->as->type == AS_EXPLICIT
4526 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4528 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4529 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4531 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4533 /* For non-constant shape arrays we only check if the first dimension
4534 is contiguous. Repacking higher dimensions wouldn't gain us
4535 anything as we still don't know the array stride. */
4536 partial = gfc_create_var (boolean_type_node, "partial");
4537 TREE_USED (partial) = 1;
4538 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4539 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4540 gfc_add_modify (&block, partial, tmp);
4544 partial = NULL_TREE;
4547 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4548 here, however I think it does the right thing. */
4551 /* Set the first stride. */
4552 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4553 stride = gfc_evaluate_now (stride, &block);
4555 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4556 stride, gfc_index_zero_node);
4557 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4558 gfc_index_one_node, stride);
4559 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4560 gfc_add_modify (&block, stride, tmp);
4562 /* Allow the user to disable array repacking. */
4563 stmt_unpacked = NULL_TREE;
4567 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4568 /* A library call to repack the array if necessary. */
4569 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4570 stmt_unpacked = build_call_expr_loc (input_location,
4571 gfor_fndecl_in_pack, 1, tmp);
4573 stride = gfc_index_one_node;
4575 if (gfc_option.warn_array_temp)
4576 gfc_warning ("Creating array temporary at %L", &loc);
4579 /* This is for the case where the array data is used directly without
4580 calling the repack function. */
4581 if (no_repack || partial != NULL_TREE)
4582 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4584 stmt_packed = NULL_TREE;
4586 /* Assign the data pointer. */
4587 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4589 /* Don't repack unknown shape arrays when the first stride is 1. */
4590 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4591 partial, stmt_packed, stmt_unpacked);
4594 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4595 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4597 offset = gfc_index_zero_node;
4598 size = gfc_index_one_node;
4600 /* Evaluate the bounds of the array. */
4601 for (n = 0; n < sym->as->rank; n++)
4603 if (checkparm || !sym->as->upper[n])
4605 /* Get the bounds of the actual parameter. */
4606 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4607 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4611 dubound = NULL_TREE;
4612 dlbound = NULL_TREE;
4615 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4616 if (!INTEGER_CST_P (lbound))
4618 gfc_init_se (&se, NULL);
4619 gfc_conv_expr_type (&se, sym->as->lower[n],
4620 gfc_array_index_type);
4621 gfc_add_block_to_block (&block, &se.pre);
4622 gfc_add_modify (&block, lbound, se.expr);
4625 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4626 /* Set the desired upper bound. */
4627 if (sym->as->upper[n])
4629 /* We know what we want the upper bound to be. */
4630 if (!INTEGER_CST_P (ubound))
4632 gfc_init_se (&se, NULL);
4633 gfc_conv_expr_type (&se, sym->as->upper[n],
4634 gfc_array_index_type);
4635 gfc_add_block_to_block (&block, &se.pre);
4636 gfc_add_modify (&block, ubound, se.expr);
4639 /* Check the sizes match. */
4642 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4646 temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4648 temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4649 gfc_index_one_node, temp);
4651 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4653 stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4654 gfc_index_one_node, stride2);
4656 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
4657 asprintf (&msg, "Dimension %d of array '%s' has extent "
4658 "%%ld instead of %%ld", n+1, sym->name);
4660 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg,
4661 fold_convert (long_integer_type_node, temp),
4662 fold_convert (long_integer_type_node, stride2));
4669 /* For assumed shape arrays move the upper bound by the same amount
4670 as the lower bound. */
4671 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4673 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4674 gfc_add_modify (&block, ubound, tmp);
4676 /* The offset of this dimension. offset = offset - lbound * stride. */
4677 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4678 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4680 /* The size of this dimension, and the stride of the next. */
4681 if (n + 1 < sym->as->rank)
4683 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4685 if (no_repack || partial != NULL_TREE)
4688 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4691 /* Figure out the stride if not a known constant. */
4692 if (!INTEGER_CST_P (stride))
4695 stmt_packed = NULL_TREE;
4698 /* Calculate stride = size * (ubound + 1 - lbound). */
4699 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4700 gfc_index_one_node, lbound);
4701 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4703 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4708 /* Assign the stride. */
4709 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4710 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4711 stmt_unpacked, stmt_packed);
4713 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4714 gfc_add_modify (&block, stride, tmp);
4719 stride = GFC_TYPE_ARRAY_SIZE (type);
4721 if (stride && !INTEGER_CST_P (stride))
4723 /* Calculate size = stride * (ubound + 1 - lbound). */
4724 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4725 gfc_index_one_node, lbound);
4726 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4728 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4729 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4730 gfc_add_modify (&block, stride, tmp);
4735 /* Set the offset. */
4736 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4737 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4739 gfc_trans_vla_type_sizes (sym, &block);
4741 stmt = gfc_finish_block (&block);
4743 gfc_start_block (&block);
4745 /* Only do the entry/initialization code if the arg is present. */
4746 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4747 optional_arg = (sym->attr.optional
4748 || (sym->ns->proc_name->attr.entry_master
4749 && sym->attr.dummy));
4752 tmp = gfc_conv_expr_present (sym);
4753 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4755 gfc_add_expr_to_block (&block, stmt);
4757 /* Add the main function body. */
4758 gfc_add_expr_to_block (&block, body);
4763 gfc_start_block (&cleanup);
4765 if (sym->attr.intent != INTENT_IN)
4767 /* Copy the data back. */
4768 tmp = build_call_expr_loc (input_location,
4769 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4770 gfc_add_expr_to_block (&cleanup, tmp);
4773 /* Free the temporary. */
4774 tmp = gfc_call_free (tmpdesc);
4775 gfc_add_expr_to_block (&cleanup, tmp);
4777 stmt = gfc_finish_block (&cleanup);
4779 /* Only do the cleanup if the array was repacked. */
4780 tmp = build_fold_indirect_ref_loc (input_location,
4782 tmp = gfc_conv_descriptor_data_get (tmp);
4783 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4784 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4788 tmp = gfc_conv_expr_present (sym);
4789 stmt = build3_v (COND_EXPR, tmp, stmt,
4790 build_empty_stmt (input_location));
4792 gfc_add_expr_to_block (&block, stmt);
4794 /* We don't need to free any memory allocated by internal_pack as it will
4795 be freed at the end of the function by pop_context. */
4796 return gfc_finish_block (&block);
4800 /* Calculate the overall offset, including subreferences. */
4802 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4803 bool subref, gfc_expr *expr)
4813 /* If offset is NULL and this is not a subreferenced array, there is
4815 if (offset == NULL_TREE)
4818 offset = gfc_index_zero_node;
4823 tmp = gfc_conv_array_data (desc);
4824 tmp = build_fold_indirect_ref_loc (input_location,
4826 tmp = gfc_build_array_ref (tmp, offset, NULL);
4828 /* Offset the data pointer for pointer assignments from arrays with
4829 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4832 /* Go past the array reference. */
4833 for (ref = expr->ref; ref; ref = ref->next)
4834 if (ref->type == REF_ARRAY &&
4835 ref->u.ar.type != AR_ELEMENT)
4841 /* Calculate the offset for each subsequent subreference. */
4842 for (; ref; ref = ref->next)
4847 field = ref->u.c.component->backend_decl;
4848 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4849 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4850 tmp, field, NULL_TREE);
4854 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4855 gfc_init_se (&start, NULL);
4856 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4857 gfc_add_block_to_block (block, &start.pre);
4858 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4862 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4863 && ref->u.ar.type == AR_ELEMENT);
4865 /* TODO - Add bounds checking. */
4866 stride = gfc_index_one_node;
4867 index = gfc_index_zero_node;
4868 for (n = 0; n < ref->u.ar.dimen; n++)
4873 /* Update the index. */
4874 gfc_init_se (&start, NULL);
4875 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4876 itmp = gfc_evaluate_now (start.expr, block);
4877 gfc_init_se (&start, NULL);
4878 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4879 jtmp = gfc_evaluate_now (start.expr, block);
4880 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4881 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4882 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4883 index = gfc_evaluate_now (index, block);
4885 /* Update the stride. */
4886 gfc_init_se (&start, NULL);
4887 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4888 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4889 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4890 gfc_index_one_node, itmp);
4891 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4892 stride = gfc_evaluate_now (stride, block);
4895 /* Apply the index to obtain the array element. */
4896 tmp = gfc_build_array_ref (tmp, index, NULL);
4906 /* Set the target data pointer. */
4907 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4908 gfc_conv_descriptor_data_set (block, parm, offset);
4912 /* gfc_conv_expr_descriptor needs the string length an expression
4913 so that the size of the temporary can be obtained. This is done
4914 by adding up the string lengths of all the elements in the
4915 expression. Function with non-constant expressions have their
4916 string lengths mapped onto the actual arguments using the
4917 interface mapping machinery in trans-expr.c. */
4919 get_array_charlen (gfc_expr *expr, gfc_se *se)
4921 gfc_interface_mapping mapping;
4922 gfc_formal_arglist *formal;
4923 gfc_actual_arglist *arg;
4926 if (expr->ts.u.cl->length
4927 && gfc_is_constant_expr (expr->ts.u.cl->length))
4929 if (!expr->ts.u.cl->backend_decl)
4930 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4934 switch (expr->expr_type)
4937 get_array_charlen (expr->value.op.op1, se);
4939 /* For parentheses the expression ts.u.cl is identical. */
4940 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4943 expr->ts.u.cl->backend_decl =
4944 gfc_create_var (gfc_charlen_type_node, "sln");
4946 if (expr->value.op.op2)
4948 get_array_charlen (expr->value.op.op2, se);
4950 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4952 /* Add the string lengths and assign them to the expression
4953 string length backend declaration. */
4954 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4955 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4956 expr->value.op.op1->ts.u.cl->backend_decl,
4957 expr->value.op.op2->ts.u.cl->backend_decl));
4960 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4961 expr->value.op.op1->ts.u.cl->backend_decl);
4965 if (expr->value.function.esym == NULL
4966 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4968 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4972 /* Map expressions involving the dummy arguments onto the actual
4973 argument expressions. */
4974 gfc_init_interface_mapping (&mapping);
4975 formal = expr->symtree->n.sym->formal;
4976 arg = expr->value.function.actual;
4978 /* Set se = NULL in the calls to the interface mapping, to suppress any
4980 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4985 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4988 gfc_init_se (&tse, NULL);
4990 /* Build the expression for the character length and convert it. */
4991 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
4993 gfc_add_block_to_block (&se->pre, &tse.pre);
4994 gfc_add_block_to_block (&se->post, &tse.post);
4995 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4996 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4997 build_int_cst (gfc_charlen_type_node, 0));
4998 expr->ts.u.cl->backend_decl = tse.expr;
4999 gfc_free_interface_mapping (&mapping);
5003 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5010 /* Convert an array for passing as an actual argument. Expressions and
5011 vector subscripts are evaluated and stored in a temporary, which is then
5012 passed. For whole arrays the descriptor is passed. For array sections
5013 a modified copy of the descriptor is passed, but using the original data.
5015 This function is also used for array pointer assignments, and there
5018 - se->want_pointer && !se->direct_byref
5019 EXPR is an actual argument. On exit, se->expr contains a
5020 pointer to the array descriptor.
5022 - !se->want_pointer && !se->direct_byref
5023 EXPR is an actual argument to an intrinsic function or the
5024 left-hand side of a pointer assignment. On exit, se->expr
5025 contains the descriptor for EXPR.
5027 - !se->want_pointer && se->direct_byref
5028 EXPR is the right-hand side of a pointer assignment and
5029 se->expr is the descriptor for the previously-evaluated
5030 left-hand side. The function creates an assignment from
5031 EXPR to se->expr. */
5034 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5047 bool subref_array_target = false;
5049 gcc_assert (ss != gfc_ss_terminator);
5051 /* Special case things we know we can pass easily. */
5052 switch (expr->expr_type)
5055 /* If we have a linear array section, we can pass it directly.
5056 Otherwise we need to copy it into a temporary. */
5058 /* Find the SS for the array section. */
5060 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5061 secss = secss->next;
5063 gcc_assert (secss != gfc_ss_terminator);
5064 info = &secss->data.info;
5066 /* Get the descriptor for the array. */
5067 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5068 desc = info->descriptor;
5070 subref_array_target = se->direct_byref && is_subref_array (expr);
5071 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5072 && !subref_array_target;
5076 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5078 /* Create a new descriptor if the array doesn't have one. */
5081 else if (info->ref->u.ar.type == AR_FULL)
5083 else if (se->direct_byref)
5086 full = gfc_full_array_ref_p (info->ref, NULL);
5090 if (se->direct_byref)
5092 /* Copy the descriptor for pointer assignments. */
5093 gfc_add_modify (&se->pre, se->expr, desc);
5095 /* Add any offsets from subreferences. */
5096 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5097 subref_array_target, expr);
5099 else if (se->want_pointer)
5101 /* We pass full arrays directly. This means that pointers and
5102 allocatable arrays should also work. */
5103 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5110 if (expr->ts.type == BT_CHARACTER)
5111 se->string_length = gfc_get_expr_charlen (expr);
5118 /* A transformational function return value will be a temporary
5119 array descriptor. We still need to go through the scalarizer
5120 to create the descriptor. Elemental functions ar handled as
5121 arbitrary expressions, i.e. copy to a temporary. */
5123 /* Look for the SS for this function. */
5124 while (secss != gfc_ss_terminator
5125 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5126 secss = secss->next;
5128 if (se->direct_byref)
5130 gcc_assert (secss != gfc_ss_terminator);
5132 /* For pointer assignments pass the descriptor directly. */
5134 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5135 gfc_conv_expr (se, expr);
5139 if (secss == gfc_ss_terminator)
5141 /* Elemental function. */
5143 if (expr->ts.type == BT_CHARACTER
5144 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5145 get_array_charlen (expr, se);
5151 /* Transformational function. */
5152 info = &secss->data.info;
5158 /* Constant array constructors don't need a temporary. */
5159 if (ss->type == GFC_SS_CONSTRUCTOR
5160 && expr->ts.type != BT_CHARACTER
5161 && gfc_constant_array_constructor_p (expr->value.constructor))
5164 info = &ss->data.info;
5176 /* Something complicated. Copy it into a temporary. */
5183 gfc_init_loopinfo (&loop);
5185 /* Associate the SS with the loop. */
5186 gfc_add_ss_to_loop (&loop, ss);
5188 /* Tell the scalarizer not to bother creating loop variables, etc. */
5190 loop.array_parameter = 1;
5192 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5193 gcc_assert (!se->direct_byref);
5195 /* Setup the scalarizing loops and bounds. */
5196 gfc_conv_ss_startstride (&loop);
5200 /* Tell the scalarizer to make a temporary. */
5201 loop.temp_ss = gfc_get_ss ();
5202 loop.temp_ss->type = GFC_SS_TEMP;
5203 loop.temp_ss->next = gfc_ss_terminator;
5205 if (expr->ts.type == BT_CHARACTER
5206 && !expr->ts.u.cl->backend_decl)
5207 get_array_charlen (expr, se);
5209 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5211 if (expr->ts.type == BT_CHARACTER)
5212 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5214 loop.temp_ss->string_length = NULL;
5216 se->string_length = loop.temp_ss->string_length;
5217 loop.temp_ss->data.temp.dimen = loop.dimen;
5218 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5221 gfc_conv_loop_setup (&loop, & expr->where);
5225 /* Copy into a temporary and pass that. We don't need to copy the data
5226 back because expressions and vector subscripts must be INTENT_IN. */
5227 /* TODO: Optimize passing function return values. */
5231 /* Start the copying loops. */
5232 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5233 gfc_mark_ss_chain_used (ss, 1);
5234 gfc_start_scalarized_body (&loop, &block);
5236 /* Copy each data element. */
5237 gfc_init_se (&lse, NULL);
5238 gfc_copy_loopinfo_to_se (&lse, &loop);
5239 gfc_init_se (&rse, NULL);
5240 gfc_copy_loopinfo_to_se (&rse, &loop);
5242 lse.ss = loop.temp_ss;
5245 gfc_conv_scalarized_array_ref (&lse, NULL);
5246 if (expr->ts.type == BT_CHARACTER)
5248 gfc_conv_expr (&rse, expr);
5249 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5250 rse.expr = build_fold_indirect_ref_loc (input_location,
5254 gfc_conv_expr_val (&rse, expr);
5256 gfc_add_block_to_block (&block, &rse.pre);
5257 gfc_add_block_to_block (&block, &lse.pre);
5259 lse.string_length = rse.string_length;
5260 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5261 expr->expr_type == EXPR_VARIABLE, true);
5262 gfc_add_expr_to_block (&block, tmp);
5264 /* Finish the copying loops. */
5265 gfc_trans_scalarizing_loops (&loop, &block);
5267 desc = loop.temp_ss->data.info.descriptor;
5269 else if (expr->expr_type == EXPR_FUNCTION)
5271 desc = info->descriptor;
5272 se->string_length = ss->string_length;
5276 /* We pass sections without copying to a temporary. Make a new
5277 descriptor and point it at the section we want. The loop variable
5278 limits will be the limits of the section.
5279 A function may decide to repack the array to speed up access, but
5280 we're not bothered about that here. */
5289 /* Set the string_length for a character array. */
5290 if (expr->ts.type == BT_CHARACTER)
5291 se->string_length = gfc_get_expr_charlen (expr);
5293 desc = info->descriptor;
5294 gcc_assert (secss && secss != gfc_ss_terminator);
5295 if (se->direct_byref)
5297 /* For pointer assignments we fill in the destination. */
5299 parmtype = TREE_TYPE (parm);
5303 /* Otherwise make a new one. */
5304 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5305 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5306 loop.from, loop.to, 0,
5307 GFC_ARRAY_UNKNOWN, false);
5308 parm = gfc_create_var (parmtype, "parm");
5311 offset = gfc_index_zero_node;
5314 /* The following can be somewhat confusing. We have two
5315 descriptors, a new one and the original array.
5316 {parm, parmtype, dim} refer to the new one.
5317 {desc, type, n, secss, loop} refer to the original, which maybe
5318 a descriptorless array.
5319 The bounds of the scalarization are the bounds of the section.
5320 We don't have to worry about numeric overflows when calculating
5321 the offsets because all elements are within the array data. */
5323 /* Set the dtype. */
5324 tmp = gfc_conv_descriptor_dtype (parm);
5325 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5327 /* Set offset for assignments to pointer only to zero if it is not
5329 if (se->direct_byref
5330 && info->ref && info->ref->u.ar.type != AR_FULL)
5331 base = gfc_index_zero_node;
5332 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5333 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5337 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5338 for (n = 0; n < ndim; n++)
5340 stride = gfc_conv_array_stride (desc, n);
5342 /* Work out the offset. */
5344 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5346 gcc_assert (info->subscript[n]
5347 && info->subscript[n]->type == GFC_SS_SCALAR);
5348 start = info->subscript[n]->data.scalar.expr;
5352 /* Check we haven't somehow got out of sync. */
5353 gcc_assert (info->dim[dim] == n);
5355 /* Evaluate and remember the start of the section. */
5356 start = info->start[dim];
5357 stride = gfc_evaluate_now (stride, &loop.pre);
5360 tmp = gfc_conv_array_lbound (desc, n);
5361 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5363 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5364 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5367 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5369 /* For elemental dimensions, we only need the offset. */
5373 /* Vector subscripts need copying and are handled elsewhere. */
5375 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5377 /* Set the new lower bound. */
5378 from = loop.from[dim];
5381 /* If we have an array section or are assigning make sure that
5382 the lower bound is 1. References to the full
5383 array should otherwise keep the original bounds. */
5385 || info->ref->u.ar.type != AR_FULL)
5386 && !integer_onep (from))
5388 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5389 gfc_index_one_node, from);
5390 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5391 from = gfc_index_one_node;
5393 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5394 gfc_rank_cst[dim], from);
5396 /* Set the new upper bound. */
5397 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5398 gfc_rank_cst[dim], to);
5400 /* Multiply the stride by the section stride to get the
5402 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5403 stride, info->stride[dim]);
5405 if (se->direct_byref
5407 && info->ref->u.ar.type != AR_FULL)
5409 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5412 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5414 tmp = gfc_conv_array_lbound (desc, n);
5415 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5416 tmp, loop.from[dim]);
5417 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5418 tmp, gfc_conv_array_stride (desc, n));
5419 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5423 /* Store the new stride. */
5424 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5425 gfc_rank_cst[dim], stride);
5430 if (se->data_not_needed)
5431 gfc_conv_descriptor_data_set (&loop.pre, parm,
5432 gfc_index_zero_node);
5434 /* Point the data pointer at the 1st element in the section. */
5435 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5436 subref_array_target, expr);
5438 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5439 && !se->data_not_needed)
5441 /* Set the offset. */
5442 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5446 /* Only the callee knows what the correct offset it, so just set
5448 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5453 if (!se->direct_byref)
5455 /* Get a pointer to the new descriptor. */
5456 if (se->want_pointer)
5457 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5462 gfc_add_block_to_block (&se->pre, &loop.pre);
5463 gfc_add_block_to_block (&se->post, &loop.post);
5465 /* Cleanup the scalarizer. */
5466 gfc_cleanup_loop (&loop);
5469 /* Helper function for gfc_conv_array_parameter if array size needs to be
5473 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5476 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5477 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5478 else if (expr->rank > 1)
5479 *size = build_call_expr_loc (input_location,
5480 gfor_fndecl_size0, 1,
5481 gfc_build_addr_expr (NULL, desc));
5484 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5485 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5487 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5488 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5489 gfc_index_one_node);
5490 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5491 gfc_index_zero_node);
5493 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5494 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5495 fold_convert (gfc_array_index_type, elem));
5498 /* Convert an array for passing as an actual parameter. */
5499 /* TODO: Optimize passing g77 arrays. */
5502 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5503 const gfc_symbol *fsym, const char *proc_name,
5508 tree tmp = NULL_TREE;
5510 tree parent = DECL_CONTEXT (current_function_decl);
5511 bool full_array_var;
5512 bool this_array_result;
5515 bool array_constructor;
5516 bool good_allocatable;
5517 bool ultimate_ptr_comp;
5518 bool ultimate_alloc_comp;
5523 ultimate_ptr_comp = false;
5524 ultimate_alloc_comp = false;
5525 for (ref = expr->ref; ref; ref = ref->next)
5527 if (ref->next == NULL)
5530 if (ref->type == REF_COMPONENT)
5532 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5533 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5537 full_array_var = false;
5540 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5541 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5543 sym = full_array_var ? expr->symtree->n.sym : NULL;
5545 /* The symbol should have an array specification. */
5546 gcc_assert (!sym || sym->as || ref->u.ar.as);
5548 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5550 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5551 expr->ts.u.cl->backend_decl = tmp;
5552 se->string_length = tmp;
5555 /* Is this the result of the enclosing procedure? */
5556 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5557 if (this_array_result
5558 && (sym->backend_decl != current_function_decl)
5559 && (sym->backend_decl != parent))
5560 this_array_result = false;
5562 /* Passing address of the array if it is not pointer or assumed-shape. */
5563 if (full_array_var && g77 && !this_array_result)
5565 tmp = gfc_get_symbol_decl (sym);
5567 if (sym->ts.type == BT_CHARACTER)
5568 se->string_length = sym->ts.u.cl->backend_decl;
5570 if (sym->ts.type == BT_DERIVED)
5572 gfc_conv_expr_descriptor (se, expr, ss);
5573 se->expr = gfc_conv_array_data (se->expr);
5577 if (!sym->attr.pointer
5579 && sym->as->type != AS_ASSUMED_SHAPE
5580 && !sym->attr.allocatable)
5582 /* Some variables are declared directly, others are declared as
5583 pointers and allocated on the heap. */
5584 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5587 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5589 array_parameter_size (tmp, expr, size);
5593 if (sym->attr.allocatable)
5595 if (sym->attr.dummy || sym->attr.result)
5597 gfc_conv_expr_descriptor (se, expr, ss);
5601 array_parameter_size (tmp, expr, size);
5602 se->expr = gfc_conv_array_data (tmp);
5607 /* A convenient reduction in scope. */
5608 contiguous = g77 && !this_array_result && contiguous;
5610 /* There is no need to pack and unpack the array, if it is contiguous
5611 and not deferred or assumed shape. */
5612 no_pack = ((sym && sym->as
5613 && !sym->attr.pointer
5614 && sym->as->type != AS_DEFERRED
5615 && sym->as->type != AS_ASSUMED_SHAPE)
5617 (ref && ref->u.ar.as
5618 && ref->u.ar.as->type != AS_DEFERRED
5619 && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
5621 no_pack = contiguous && no_pack;
5623 /* Array constructors are always contiguous and do not need packing. */
5624 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5626 /* Same is true of contiguous sections from allocatable variables. */
5627 good_allocatable = contiguous
5629 && expr->symtree->n.sym->attr.allocatable;
5631 /* Or ultimate allocatable components. */
5632 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5634 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5636 gfc_conv_expr_descriptor (se, expr, ss);
5637 if (expr->ts.type == BT_CHARACTER)
5638 se->string_length = expr->ts.u.cl->backend_decl;
5640 array_parameter_size (se->expr, expr, size);
5641 se->expr = gfc_conv_array_data (se->expr);
5645 if (this_array_result)
5647 /* Result of the enclosing function. */
5648 gfc_conv_expr_descriptor (se, expr, ss);
5650 array_parameter_size (se->expr, expr, size);
5651 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5653 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5654 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5655 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5662 /* Every other type of array. */
5663 se->want_pointer = 1;
5664 gfc_conv_expr_descriptor (se, expr, ss);
5666 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5671 /* Deallocate the allocatable components of structures that are
5673 if (expr->ts.type == BT_DERIVED
5674 && expr->ts.u.derived->attr.alloc_comp
5675 && expr->expr_type != EXPR_VARIABLE)
5677 tmp = build_fold_indirect_ref_loc (input_location,
5679 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5680 gfc_add_expr_to_block (&se->post, tmp);
5686 /* Repack the array. */
5687 if (gfc_option.warn_array_temp)
5690 gfc_warning ("Creating array temporary at %L for argument '%s'",
5691 &expr->where, fsym->name);
5693 gfc_warning ("Creating array temporary at %L", &expr->where);
5696 ptr = build_call_expr_loc (input_location,
5697 gfor_fndecl_in_pack, 1, desc);
5699 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5701 tmp = gfc_conv_expr_present (sym);
5702 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5703 fold_convert (TREE_TYPE (se->expr), ptr),
5704 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5707 ptr = gfc_evaluate_now (ptr, &se->pre);
5711 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5715 if (fsym && proc_name)
5716 asprintf (&msg, "An array temporary was created for argument "
5717 "'%s' of procedure '%s'", fsym->name, proc_name);
5719 asprintf (&msg, "An array temporary was created");
5721 tmp = build_fold_indirect_ref_loc (input_location,
5723 tmp = gfc_conv_array_data (tmp);
5724 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5725 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5727 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5728 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5729 gfc_conv_expr_present (sym), tmp);
5731 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5736 gfc_start_block (&block);
5738 /* Copy the data back. */
5739 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5741 tmp = build_call_expr_loc (input_location,
5742 gfor_fndecl_in_unpack, 2, desc, ptr);
5743 gfc_add_expr_to_block (&block, tmp);
5746 /* Free the temporary. */
5747 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5748 gfc_add_expr_to_block (&block, tmp);
5750 stmt = gfc_finish_block (&block);
5752 gfc_init_block (&block);
5753 /* Only if it was repacked. This code needs to be executed before the
5754 loop cleanup code. */
5755 tmp = build_fold_indirect_ref_loc (input_location,
5757 tmp = gfc_conv_array_data (tmp);
5758 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5759 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5761 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5762 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5763 gfc_conv_expr_present (sym), tmp);
5765 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5767 gfc_add_expr_to_block (&block, tmp);
5768 gfc_add_block_to_block (&block, &se->post);
5770 gfc_init_block (&se->post);
5771 gfc_add_block_to_block (&se->post, &block);
5776 /* Generate code to deallocate an array, if it is allocated. */
5779 gfc_trans_dealloc_allocated (tree descriptor)
5785 gfc_start_block (&block);
5787 var = gfc_conv_descriptor_data_get (descriptor);
5790 /* Call array_deallocate with an int * present in the second argument.
5791 Although it is ignored here, it's presence ensures that arrays that
5792 are already deallocated are ignored. */
5793 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5794 gfc_add_expr_to_block (&block, tmp);
5796 /* Zero the data pointer. */
5797 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5798 var, build_int_cst (TREE_TYPE (var), 0));
5799 gfc_add_expr_to_block (&block, tmp);
5801 return gfc_finish_block (&block);
5805 /* This helper function calculates the size in words of a full array. */
5808 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5813 idx = gfc_rank_cst[rank - 1];
5814 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5815 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5816 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5817 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5818 tmp, gfc_index_one_node);
5819 tmp = gfc_evaluate_now (tmp, block);
5821 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5822 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5823 return gfc_evaluate_now (tmp, block);
5827 /* Allocate dest to the same size as src, and copy src -> dest.
5828 If no_malloc is set, only the copy is done. */
5831 duplicate_allocatable(tree dest, tree src, tree type, int rank,
5841 /* If the source is null, set the destination to null. Then,
5842 allocate memory to the destination. */
5843 gfc_init_block (&block);
5847 tmp = null_pointer_node;
5848 tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
5849 gfc_add_expr_to_block (&block, tmp);
5850 null_data = gfc_finish_block (&block);
5852 gfc_init_block (&block);
5853 size = TYPE_SIZE_UNIT (type);
5856 tmp = gfc_call_malloc (&block, type, size);
5857 tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
5858 fold_convert (type, tmp));
5859 gfc_add_expr_to_block (&block, tmp);
5862 tmp = built_in_decls[BUILT_IN_MEMCPY];
5863 tmp = build_call_expr_loc (input_location, tmp, 3,
5868 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5869 null_data = gfc_finish_block (&block);
5871 gfc_init_block (&block);
5872 nelems = get_full_array_size (&block, src, rank);
5873 tmp = fold_convert (gfc_array_index_type,
5874 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
5875 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5878 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
5879 tmp = gfc_call_malloc (&block, tmp, size);
5880 gfc_conv_descriptor_data_set (&block, dest, tmp);
5883 /* We know the temporary and the value will be the same length,
5884 so can use memcpy. */
5885 tmp = built_in_decls[BUILT_IN_MEMCPY];
5886 tmp = build_call_expr_loc (input_location,
5887 tmp, 3, gfc_conv_descriptor_data_get (dest),
5888 gfc_conv_descriptor_data_get (src), size);
5891 gfc_add_expr_to_block (&block, tmp);
5892 tmp = gfc_finish_block (&block);
5894 /* Null the destination if the source is null; otherwise do
5895 the allocate and copy. */
5899 null_cond = gfc_conv_descriptor_data_get (src);
5901 null_cond = convert (pvoid_type_node, null_cond);
5902 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5903 null_cond, null_pointer_node);
5904 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5908 /* Allocate dest to the same size as src, and copy data src -> dest. */
5911 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
5913 return duplicate_allocatable(dest, src, type, rank, false);
5917 /* Copy data src -> dest. */
5920 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
5922 return duplicate_allocatable(dest, src, type, rank, true);
5926 /* Recursively traverse an object of derived type, generating code to
5927 deallocate, nullify or copy allocatable components. This is the work horse
5928 function for the functions named in this enum. */
5930 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
5931 COPY_ONLY_ALLOC_COMP};
5934 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5935 tree dest, int rank, int purpose)
5939 stmtblock_t fnblock;
5940 stmtblock_t loopbody;
5950 tree null_cond = NULL_TREE;
5952 gfc_init_block (&fnblock);
5954 if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
5955 decl = build_fold_indirect_ref_loc (input_location,
5958 /* If this an array of derived types with allocatable components
5959 build a loop and recursively call this function. */
5960 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5961 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5963 tmp = gfc_conv_array_data (decl);
5964 var = build_fold_indirect_ref_loc (input_location,
5967 /* Get the number of elements - 1 and set the counter. */
5968 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5970 /* Use the descriptor for an allocatable array. Since this
5971 is a full array reference, we only need the descriptor
5972 information from dimension = rank. */
5973 tmp = get_full_array_size (&fnblock, decl, rank);
5974 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5975 tmp, gfc_index_one_node);
5977 null_cond = gfc_conv_descriptor_data_get (decl);
5978 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5979 build_int_cst (TREE_TYPE (null_cond), 0));
5983 /* Otherwise use the TYPE_DOMAIN information. */
5984 tmp = array_type_nelts (TREE_TYPE (decl));
5985 tmp = fold_convert (gfc_array_index_type, tmp);
5988 /* Remember that this is, in fact, the no. of elements - 1. */
5989 nelems = gfc_evaluate_now (tmp, &fnblock);
5990 index = gfc_create_var (gfc_array_index_type, "S");
5992 /* Build the body of the loop. */
5993 gfc_init_block (&loopbody);
5995 vref = gfc_build_array_ref (var, index, NULL);
5997 if (purpose == COPY_ALLOC_COMP)
5999 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6001 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
6002 gfc_add_expr_to_block (&fnblock, tmp);
6004 tmp = build_fold_indirect_ref_loc (input_location,
6005 gfc_conv_array_data (dest));
6006 dref = gfc_build_array_ref (tmp, index, NULL);
6007 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6009 else if (purpose == COPY_ONLY_ALLOC_COMP)
6011 tmp = build_fold_indirect_ref_loc (input_location,
6012 gfc_conv_array_data (dest));
6013 dref = gfc_build_array_ref (tmp, index, NULL);
6014 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6018 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6020 gfc_add_expr_to_block (&loopbody, tmp);
6022 /* Build the loop and return. */
6023 gfc_init_loopinfo (&loop);
6025 loop.from[0] = gfc_index_zero_node;
6026 loop.loopvar[0] = index;
6027 loop.to[0] = nelems;
6028 gfc_trans_scalarizing_loops (&loop, &loopbody);
6029 gfc_add_block_to_block (&fnblock, &loop.pre);
6031 tmp = gfc_finish_block (&fnblock);
6032 if (null_cond != NULL_TREE)
6033 tmp = build3_v (COND_EXPR, null_cond, tmp,
6034 build_empty_stmt (input_location));
6039 /* Otherwise, act on the components or recursively call self to
6040 act on a chain of components. */
6041 for (c = der_type->components; c; c = c->next)
6043 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6044 && c->ts.u.derived->attr.alloc_comp;
6045 cdecl = c->backend_decl;
6046 ctype = TREE_TYPE (cdecl);
6050 case DEALLOCATE_ALLOC_COMP:
6051 /* Do not deallocate the components of ultimate pointer
6053 if (cmp_has_alloc_comps && !c->attr.pointer)
6055 comp = fold_build3 (COMPONENT_REF, ctype,
6056 decl, cdecl, NULL_TREE);
6057 rank = c->as ? c->as->rank : 0;
6058 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6060 gfc_add_expr_to_block (&fnblock, tmp);
6063 if (c->attr.allocatable && c->attr.dimension)
6065 comp = fold_build3 (COMPONENT_REF, ctype,
6066 decl, cdecl, NULL_TREE);
6067 tmp = gfc_trans_dealloc_allocated (comp);
6068 gfc_add_expr_to_block (&fnblock, tmp);
6070 else if (c->attr.allocatable)
6072 /* Allocatable scalar components. */
6073 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6075 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6076 gfc_add_expr_to_block (&fnblock, tmp);
6078 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6079 build_int_cst (TREE_TYPE (comp), 0));
6080 gfc_add_expr_to_block (&fnblock, tmp);
6082 else if (c->ts.type == BT_CLASS
6083 && c->ts.u.derived->components->attr.allocatable)
6085 /* Allocatable scalar CLASS components. */
6086 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6088 /* Add reference to '$data' component. */
6089 tmp = c->ts.u.derived->components->backend_decl;
6090 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6091 comp, tmp, NULL_TREE);
6093 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6094 gfc_add_expr_to_block (&fnblock, tmp);
6096 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6097 build_int_cst (TREE_TYPE (comp), 0));
6098 gfc_add_expr_to_block (&fnblock, tmp);
6102 case NULLIFY_ALLOC_COMP:
6103 if (c->attr.pointer)
6105 else if (c->attr.allocatable && c->attr.dimension)
6107 comp = fold_build3 (COMPONENT_REF, ctype,
6108 decl, cdecl, NULL_TREE);
6109 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6111 else if (c->attr.allocatable)
6113 /* Allocatable scalar components. */
6114 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6115 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6116 build_int_cst (TREE_TYPE (comp), 0));
6117 gfc_add_expr_to_block (&fnblock, tmp);
6119 else if (c->ts.type == BT_CLASS
6120 && c->ts.u.derived->components->attr.allocatable)
6122 /* Allocatable scalar CLASS components. */
6123 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6124 /* Add reference to '$data' component. */
6125 tmp = c->ts.u.derived->components->backend_decl;
6126 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6127 comp, tmp, NULL_TREE);
6128 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6129 build_int_cst (TREE_TYPE (comp), 0));
6130 gfc_add_expr_to_block (&fnblock, tmp);
6132 else if (cmp_has_alloc_comps)
6134 comp = fold_build3 (COMPONENT_REF, ctype,
6135 decl, cdecl, NULL_TREE);
6136 rank = c->as ? c->as->rank : 0;
6137 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6139 gfc_add_expr_to_block (&fnblock, tmp);
6143 case COPY_ALLOC_COMP:
6144 if (c->attr.pointer)
6147 /* We need source and destination components. */
6148 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6149 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
6150 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6152 if (c->attr.allocatable && !cmp_has_alloc_comps)
6154 rank = c->as ? c->as->rank : 0;
6155 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
6156 gfc_add_expr_to_block (&fnblock, tmp);
6159 if (cmp_has_alloc_comps)
6161 rank = c->as ? c->as->rank : 0;
6162 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6163 gfc_add_modify (&fnblock, dcmp, tmp);
6164 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6166 gfc_add_expr_to_block (&fnblock, tmp);
6176 return gfc_finish_block (&fnblock);
6179 /* Recursively traverse an object of derived type, generating code to
6180 nullify allocatable components. */
6183 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6185 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6186 NULLIFY_ALLOC_COMP);
6190 /* Recursively traverse an object of derived type, generating code to
6191 deallocate allocatable components. */
6194 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6196 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6197 DEALLOCATE_ALLOC_COMP);
6201 /* Recursively traverse an object of derived type, generating code to
6202 copy it and its allocatable components. */
6205 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6207 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6211 /* Recursively traverse an object of derived type, generating code to
6212 copy only its allocatable components. */
6215 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6217 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6221 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6222 Do likewise, recursively if necessary, with the allocatable components of
6226 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
6231 stmtblock_t fnblock;
6234 bool sym_has_alloc_comp;
6236 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6237 && sym->ts.u.derived->attr.alloc_comp;
6239 /* Make sure the frontend gets these right. */
6240 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6241 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6242 "allocatable attribute or derived type without allocatable "
6245 gfc_init_block (&fnblock);
6247 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6248 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6250 if (sym->ts.type == BT_CHARACTER
6251 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6253 gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
6254 gfc_trans_vla_type_sizes (sym, &fnblock);
6257 /* Dummy, use associated and result variables don't need anything special. */
6258 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6260 gfc_add_expr_to_block (&fnblock, body);
6262 return gfc_finish_block (&fnblock);
6265 gfc_get_backend_locus (&loc);
6266 gfc_set_backend_locus (&sym->declared_at);
6267 descriptor = sym->backend_decl;
6269 /* Although static, derived types with default initializers and
6270 allocatable components must not be nulled wholesale; instead they
6271 are treated component by component. */
6272 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6274 /* SAVEd variables are not freed on exit. */
6275 gfc_trans_static_array_pointer (sym);
6279 /* Get the descriptor type. */
6280 type = TREE_TYPE (sym->backend_decl);
6282 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6285 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6287 if (sym->value == NULL
6288 || !gfc_has_default_initializer (sym->ts.u.derived))
6290 rank = sym->as ? sym->as->rank : 0;
6291 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
6292 gfc_add_expr_to_block (&fnblock, tmp);
6296 tmp = gfc_init_default_dt (sym, NULL, false);
6297 gfc_add_expr_to_block (&fnblock, tmp);
6301 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6303 /* If the backend_decl is not a descriptor, we must have a pointer
6305 descriptor = build_fold_indirect_ref_loc (input_location,
6307 type = TREE_TYPE (descriptor);
6310 /* NULLIFY the data pointer. */
6311 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6312 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
6314 gfc_add_expr_to_block (&fnblock, body);
6316 gfc_set_backend_locus (&loc);
6318 /* Allocatable arrays need to be freed when they go out of scope.
6319 The allocatable components of pointers must not be touched. */
6320 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6321 && !sym->attr.pointer && !sym->attr.save)
6324 rank = sym->as ? sym->as->rank : 0;
6325 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6326 gfc_add_expr_to_block (&fnblock, tmp);
6329 if (sym->attr.allocatable && sym->attr.dimension
6330 && !sym->attr.save && !sym->attr.result)
6332 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6333 gfc_add_expr_to_block (&fnblock, tmp);
6336 return gfc_finish_block (&fnblock);
6339 /************ Expression Walking Functions ******************/
6341 /* Walk a variable reference.
6343 Possible extension - multiple component subscripts.
6344 x(:,:) = foo%a(:)%b(:)
6346 forall (i=..., j=...)
6347 x(i,j) = foo%a(j)%b(i)
6349 This adds a fair amount of complexity because you need to deal with more
6350 than one ref. Maybe handle in a similar manner to vector subscripts.
6351 Maybe not worth the effort. */
6355 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6362 for (ref = expr->ref; ref; ref = ref->next)
6363 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6366 for (; ref; ref = ref->next)
6368 if (ref->type == REF_SUBSTRING)
6370 newss = gfc_get_ss ();
6371 newss->type = GFC_SS_SCALAR;
6372 newss->expr = ref->u.ss.start;
6376 newss = gfc_get_ss ();
6377 newss->type = GFC_SS_SCALAR;
6378 newss->expr = ref->u.ss.end;
6383 /* We're only interested in array sections from now on. */
6384 if (ref->type != REF_ARRAY)
6389 if (ar->as->rank == 0)
6391 /* Scalar coarray. */
6398 for (n = 0; n < ar->dimen; n++)
6400 newss = gfc_get_ss ();
6401 newss->type = GFC_SS_SCALAR;
6402 newss->expr = ar->start[n];
6409 newss = gfc_get_ss ();
6410 newss->type = GFC_SS_SECTION;
6413 newss->data.info.dimen = ar->as->rank;
6414 newss->data.info.ref = ref;
6416 /* Make sure array is the same as array(:,:), this way
6417 we don't need to special case all the time. */
6418 ar->dimen = ar->as->rank;
6419 for (n = 0; n < ar->dimen; n++)
6421 newss->data.info.dim[n] = n;
6422 ar->dimen_type[n] = DIMEN_RANGE;
6424 gcc_assert (ar->start[n] == NULL);
6425 gcc_assert (ar->end[n] == NULL);
6426 gcc_assert (ar->stride[n] == NULL);
6432 newss = gfc_get_ss ();
6433 newss->type = GFC_SS_SECTION;
6436 newss->data.info.dimen = 0;
6437 newss->data.info.ref = ref;
6439 /* We add SS chains for all the subscripts in the section. */
6440 for (n = 0; n < ar->dimen; n++)
6444 switch (ar->dimen_type[n])
6447 /* Add SS for elemental (scalar) subscripts. */
6448 gcc_assert (ar->start[n]);
6449 indexss = gfc_get_ss ();
6450 indexss->type = GFC_SS_SCALAR;
6451 indexss->expr = ar->start[n];
6452 indexss->next = gfc_ss_terminator;
6453 indexss->loop_chain = gfc_ss_terminator;
6454 newss->data.info.subscript[n] = indexss;
6458 /* We don't add anything for sections, just remember this
6459 dimension for later. */
6460 newss->data.info.dim[newss->data.info.dimen] = n;
6461 newss->data.info.dimen++;
6465 /* Create a GFC_SS_VECTOR index in which we can store
6466 the vector's descriptor. */
6467 indexss = gfc_get_ss ();
6468 indexss->type = GFC_SS_VECTOR;
6469 indexss->expr = ar->start[n];
6470 indexss->next = gfc_ss_terminator;
6471 indexss->loop_chain = gfc_ss_terminator;
6472 newss->data.info.subscript[n] = indexss;
6473 newss->data.info.dim[newss->data.info.dimen] = n;
6474 newss->data.info.dimen++;
6478 /* We should know what sort of section it is by now. */
6482 /* We should have at least one non-elemental dimension. */
6483 gcc_assert (newss->data.info.dimen > 0);
6488 /* We should know what sort of section it is by now. */
6497 /* Walk an expression operator. If only one operand of a binary expression is
6498 scalar, we must also add the scalar term to the SS chain. */
6501 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6507 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6508 if (expr->value.op.op2 == NULL)
6511 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6513 /* All operands are scalar. Pass back and let the caller deal with it. */
6517 /* All operands require scalarization. */
6518 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6521 /* One of the operands needs scalarization, the other is scalar.
6522 Create a gfc_ss for the scalar expression. */
6523 newss = gfc_get_ss ();
6524 newss->type = GFC_SS_SCALAR;
6527 /* First operand is scalar. We build the chain in reverse order, so
6528 add the scalar SS after the second operand. */
6530 while (head && head->next != ss)
6532 /* Check we haven't somehow broken the chain. */
6536 newss->expr = expr->value.op.op1;
6538 else /* head2 == head */
6540 gcc_assert (head2 == head);
6541 /* Second operand is scalar. */
6542 newss->next = head2;
6544 newss->expr = expr->value.op.op2;
6551 /* Reverse a SS chain. */
6554 gfc_reverse_ss (gfc_ss * ss)
6559 gcc_assert (ss != NULL);
6561 head = gfc_ss_terminator;
6562 while (ss != gfc_ss_terminator)
6565 /* Check we didn't somehow break the chain. */
6566 gcc_assert (next != NULL);
6576 /* Walk the arguments of an elemental function. */
6579 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6587 head = gfc_ss_terminator;
6590 for (; arg; arg = arg->next)
6595 newss = gfc_walk_subexpr (head, arg->expr);
6598 /* Scalar argument. */
6599 newss = gfc_get_ss ();
6601 newss->expr = arg->expr;
6611 while (tail->next != gfc_ss_terminator)
6618 /* If all the arguments are scalar we don't need the argument SS. */
6619 gfc_free_ss_chain (head);
6624 /* Add it onto the existing chain. */
6630 /* Walk a function call. Scalar functions are passed back, and taken out of
6631 scalarization loops. For elemental functions we walk their arguments.
6632 The result of functions returning arrays is stored in a temporary outside
6633 the loop, so that the function is only called once. Hence we do not need
6634 to walk their arguments. */
6637 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6640 gfc_intrinsic_sym *isym;
6642 gfc_component *comp = NULL;
6644 isym = expr->value.function.isym;
6646 /* Handle intrinsic functions separately. */
6648 return gfc_walk_intrinsic_function (ss, expr, isym);
6650 sym = expr->value.function.esym;
6652 sym = expr->symtree->n.sym;
6654 /* A function that returns arrays. */
6655 gfc_is_proc_ptr_comp (expr, &comp);
6656 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6657 || (comp && comp->attr.dimension))
6659 newss = gfc_get_ss ();
6660 newss->type = GFC_SS_FUNCTION;
6663 newss->data.info.dimen = expr->rank;
6667 /* Walk the parameters of an elemental function. For now we always pass
6669 if (sym->attr.elemental)
6670 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6673 /* Scalar functions are OK as these are evaluated outside the scalarization
6674 loop. Pass back and let the caller deal with it. */
6679 /* An array temporary is constructed for array constructors. */
6682 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6687 newss = gfc_get_ss ();
6688 newss->type = GFC_SS_CONSTRUCTOR;
6691 newss->data.info.dimen = expr->rank;
6692 for (n = 0; n < expr->rank; n++)
6693 newss->data.info.dim[n] = n;
6699 /* Walk an expression. Add walked expressions to the head of the SS chain.
6700 A wholly scalar expression will not be added. */
6703 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6707 switch (expr->expr_type)
6710 head = gfc_walk_variable_expr (ss, expr);
6714 head = gfc_walk_op_expr (ss, expr);
6718 head = gfc_walk_function_expr (ss, expr);
6723 case EXPR_STRUCTURE:
6724 /* Pass back and let the caller deal with it. */
6728 head = gfc_walk_array_constructor (ss, expr);
6731 case EXPR_SUBSTRING:
6732 /* Pass back and let the caller deal with it. */
6736 internal_error ("bad expression type during walk (%d)",
6743 /* Entry point for expression walking.
6744 A return value equal to the passed chain means this is
6745 a scalar expression. It is up to the caller to take whatever action is
6746 necessary to translate these. */
6749 gfc_walk_expr (gfc_expr * expr)
6753 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6754 return gfc_reverse_ss (res);