1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set. */
167 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
171 type = TREE_TYPE (desc);
172 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
174 field = TYPE_FIELDS (type);
175 gcc_assert (DATA_FIELD == 0);
177 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc)
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
196 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
197 return gfc_build_addr_expr (NULL_TREE, t);
201 gfc_conv_descriptor_offset (tree desc)
206 type = TREE_TYPE (desc);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
210 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
213 desc, field, NULL_TREE);
217 gfc_conv_descriptor_dtype (tree desc)
222 type = TREE_TYPE (desc);
223 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
225 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
226 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
228 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
229 desc, field, NULL_TREE);
233 gfc_conv_descriptor_dimension (tree desc, tree dim)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
243 gcc_assert (field != NULL_TREE
244 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
247 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
248 desc, field, NULL_TREE);
249 tmp = gfc_build_array_ref (tmp, dim, NULL);
254 gfc_conv_descriptor_stride (tree desc, tree dim)
259 tmp = gfc_conv_descriptor_dimension (desc, dim);
260 field = TYPE_FIELDS (TREE_TYPE (tmp));
261 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
262 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
264 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
265 tmp, field, NULL_TREE);
270 gfc_conv_descriptor_lbound (tree desc, tree dim)
275 tmp = gfc_conv_descriptor_dimension (desc, dim);
276 field = TYPE_FIELDS (TREE_TYPE (tmp));
277 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
278 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
280 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
281 tmp, field, NULL_TREE);
286 gfc_conv_descriptor_ubound (tree desc, tree dim)
291 tmp = gfc_conv_descriptor_dimension (desc, dim);
292 field = TYPE_FIELDS (TREE_TYPE (tmp));
293 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
294 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
296 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
297 tmp, field, NULL_TREE);
302 /* Build a null array descriptor constructor. */
305 gfc_build_null_descriptor (tree type)
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
311 gcc_assert (DATA_FIELD == 0);
312 field = TYPE_FIELDS (type);
314 /* Set a NULL data pointer. */
315 tmp = build_constructor_single (type, field, null_pointer_node);
316 TREE_CONSTANT (tmp) = 1;
317 /* All other fields are ignored. */
323 /* Cleanup those #defines. */
328 #undef DIMENSION_FIELD
329 #undef STRIDE_SUBFIELD
330 #undef LBOUND_SUBFIELD
331 #undef UBOUND_SUBFIELD
334 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
335 flags & 1 = Main loop body.
336 flags & 2 = temp copy loop. */
339 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
341 for (; ss != gfc_ss_terminator; ss = ss->next)
342 ss->useflags = flags;
345 static void gfc_free_ss (gfc_ss *);
348 /* Free a gfc_ss chain. */
351 gfc_free_ss_chain (gfc_ss * ss)
355 while (ss != gfc_ss_terminator)
357 gcc_assert (ss != NULL);
368 gfc_free_ss (gfc_ss * ss)
375 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
377 if (ss->data.info.subscript[n])
378 gfc_free_ss_chain (ss->data.info.subscript[n]);
390 /* Free all the SS associated with a loop. */
393 gfc_cleanup_loop (gfc_loopinfo * loop)
399 while (ss != gfc_ss_terminator)
401 gcc_assert (ss != NULL);
402 next = ss->loop_chain;
409 /* Associate a SS chain with a loop. */
412 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
416 if (head == gfc_ss_terminator)
420 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
422 if (ss->next == gfc_ss_terminator)
423 ss->loop_chain = loop->ss;
425 ss->loop_chain = ss->next;
427 gcc_assert (ss == gfc_ss_terminator);
432 /* Generate an initializer for a static pointer or allocatable array. */
435 gfc_trans_static_array_pointer (gfc_symbol * sym)
439 gcc_assert (TREE_STATIC (sym->backend_decl));
440 /* Just zero the data member. */
441 type = TREE_TYPE (sym->backend_decl);
442 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
446 /* If the bounds of SE's loop have not yet been set, see if they can be
447 determined from array spec AS, which is the array spec of a called
448 function. MAPPING maps the callee's dummy arguments to the values
449 that the caller is passing. Add any initialization and finalization
453 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
454 gfc_se * se, gfc_array_spec * as)
462 if (as && as->type == AS_EXPLICIT)
463 for (dim = 0; dim < se->loop->dimen; dim++)
465 n = se->loop->order[dim];
466 if (se->loop->to[n] == NULL_TREE)
468 /* Evaluate the lower bound. */
469 gfc_init_se (&tmpse, NULL);
470 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
471 gfc_add_block_to_block (&se->pre, &tmpse.pre);
472 gfc_add_block_to_block (&se->post, &tmpse.post);
473 lower = fold_convert (gfc_array_index_type, tmpse.expr);
475 /* ...and the upper bound. */
476 gfc_init_se (&tmpse, NULL);
477 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
478 gfc_add_block_to_block (&se->pre, &tmpse.pre);
479 gfc_add_block_to_block (&se->post, &tmpse.post);
480 upper = fold_convert (gfc_array_index_type, tmpse.expr);
482 /* Set the upper bound of the loop to UPPER - LOWER. */
483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
484 tmp = gfc_evaluate_now (tmp, &se->pre);
485 se->loop->to[n] = tmp;
491 /* Generate code to allocate an array temporary, or create a variable to
492 hold the data. If size is NULL, zero the descriptor so that the
493 callee will allocate the array. If DEALLOC is true, also generate code to
494 free the array afterwards.
496 If INITIAL is not NULL, it is packed using internal_pack and the result used
497 as data instead of allocating a fresh, unitialized area of memory.
499 Initialization code is added to PRE and finalization code to POST.
500 DYNAMIC is true if the caller may want to extend the array later
501 using realloc. This prevents us from putting the array on the stack. */
504 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
505 gfc_ss_info * info, tree size, tree nelem,
506 tree initial, bool dynamic, bool dealloc)
512 desc = info->descriptor;
513 info->offset = gfc_index_zero_node;
514 if (size == NULL_TREE || integer_zerop (size))
516 /* A callee allocated array. */
517 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
522 /* Allocate the temporary. */
523 onstack = !dynamic && initial == NULL_TREE
524 && gfc_can_put_var_on_stack (size);
528 /* Make a temporary variable to hold the data. */
529 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
531 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
533 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
535 tmp = gfc_create_var (tmp, "A");
536 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
537 gfc_conv_descriptor_data_set (pre, desc, tmp);
541 /* Allocate memory to hold the data or call internal_pack. */
542 if (initial == NULL_TREE)
544 tmp = gfc_call_malloc (pre, NULL, size);
545 tmp = gfc_evaluate_now (tmp, pre);
552 stmtblock_t do_copying;
554 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
555 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
556 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
557 tmp = gfc_get_element_type (tmp);
558 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
559 packed = gfc_create_var (build_pointer_type (tmp), "data");
561 tmp = build_call_expr (gfor_fndecl_in_pack, 1, initial);
562 tmp = fold_convert (TREE_TYPE (packed), tmp);
563 gfc_add_modify (pre, packed, tmp);
565 tmp = build_fold_indirect_ref (initial);
566 source_data = gfc_conv_descriptor_data_get (tmp);
568 /* internal_pack may return source->data without any allocation
569 or copying if it is already packed. If that's the case, we
570 need to allocate and copy manually. */
572 gfc_start_block (&do_copying);
573 tmp = gfc_call_malloc (&do_copying, NULL, size);
574 tmp = fold_convert (TREE_TYPE (packed), tmp);
575 gfc_add_modify (&do_copying, packed, tmp);
576 tmp = gfc_build_memcpy_call (packed, source_data, size);
577 gfc_add_expr_to_block (&do_copying, tmp);
579 was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
580 packed, source_data);
581 tmp = gfc_finish_block (&do_copying);
582 tmp = build3_v (COND_EXPR, was_packed, tmp, build_empty_stmt ());
583 gfc_add_expr_to_block (pre, tmp);
585 tmp = fold_convert (pvoid_type_node, packed);
588 gfc_conv_descriptor_data_set (pre, desc, tmp);
591 info->data = gfc_conv_descriptor_data_get (desc);
593 /* The offset is zero because we create temporaries with a zero
595 tmp = gfc_conv_descriptor_offset (desc);
596 gfc_add_modify (pre, tmp, gfc_index_zero_node);
598 if (dealloc && !onstack)
600 /* Free the temporary. */
601 tmp = gfc_conv_descriptor_data_get (desc);
602 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
603 gfc_add_expr_to_block (post, tmp);
608 /* Generate code to create and initialize the descriptor for a temporary
609 array. This is used for both temporaries needed by the scalarizer, and
610 functions returning arrays. Adjusts the loop variables to be
611 zero-based, and calculates the loop bounds for callee allocated arrays.
612 Allocate the array unless it's callee allocated (we have a callee
613 allocated array if 'callee_alloc' is true, or if loop->to[n] is
614 NULL_TREE for any n). Also fills in the descriptor, data and offset
615 fields of info if known. Returns the size of the array, or NULL for a
616 callee allocated array.
618 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
619 gfc_trans_allocate_array_storage.
623 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
624 gfc_loopinfo * loop, gfc_ss_info * info,
625 tree eltype, tree initial, bool dynamic,
626 bool dealloc, bool callee_alloc, locus * where)
638 gcc_assert (info->dimen > 0);
640 if (gfc_option.warn_array_temp && where)
641 gfc_warning ("Creating array temporary at %L", where);
643 /* Set the lower bound to zero. */
644 for (dim = 0; dim < info->dimen; dim++)
646 n = loop->order[dim];
647 /* Callee allocated arrays may not have a known bound yet. */
649 loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
650 gfc_array_index_type,
651 loop->to[n], loop->from[n]), pre);
652 loop->from[n] = gfc_index_zero_node;
654 info->delta[dim] = gfc_index_zero_node;
655 info->start[dim] = gfc_index_zero_node;
656 info->end[dim] = gfc_index_zero_node;
657 info->stride[dim] = gfc_index_one_node;
658 info->dim[dim] = dim;
661 /* Initialize the descriptor. */
663 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
665 desc = gfc_create_var (type, "atmp");
666 GFC_DECL_PACKED_ARRAY (desc) = 1;
668 info->descriptor = desc;
669 size = gfc_index_one_node;
671 /* Fill in the array dtype. */
672 tmp = gfc_conv_descriptor_dtype (desc);
673 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
676 Fill in the bounds and stride. This is a packed array, so:
679 for (n = 0; n < rank; n++)
682 delta = ubound[n] + 1 - lbound[n];
685 size = size * sizeof(element);
690 /* If there is at least one null loop->to[n], it is a callee allocated
692 for (n = 0; n < info->dimen; n++)
693 if (loop->to[n] == NULL_TREE)
699 for (n = 0; n < info->dimen; n++)
701 if (size == NULL_TREE)
703 /* For a callee allocated array express the loop bounds in terms
704 of the descriptor fields. */
706 fold_build2 (MINUS_EXPR, gfc_array_index_type,
707 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
708 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
713 /* Store the stride and bound components in the descriptor. */
714 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
715 gfc_add_modify (pre, tmp, size);
717 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
718 gfc_add_modify (pre, tmp, gfc_index_zero_node);
720 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
721 gfc_add_modify (pre, tmp, loop->to[n]);
723 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
724 loop->to[n], gfc_index_one_node);
726 /* Check whether the size for this dimension is negative. */
727 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
728 gfc_index_zero_node);
729 cond = gfc_evaluate_now (cond, pre);
734 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
736 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
737 size = gfc_evaluate_now (size, pre);
740 /* Get the size of the array. */
742 if (size && !callee_alloc)
744 /* If or_expr is true, then the extent in at least one
745 dimension is zero and the size is set to zero. */
746 size = fold_build3 (COND_EXPR, gfc_array_index_type,
747 or_expr, gfc_index_zero_node, size);
750 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
751 fold_convert (gfc_array_index_type,
752 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
760 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
763 if (info->dimen > loop->temp_dim)
764 loop->temp_dim = info->dimen;
770 /* Generate code to transpose array EXPR by creating a new descriptor
771 in which the dimension specifications have been reversed. */
774 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
776 tree dest, src, dest_index, src_index;
778 gfc_ss_info *dest_info, *src_info;
779 gfc_ss *dest_ss, *src_ss;
785 src_ss = gfc_walk_expr (expr);
788 src_info = &src_ss->data.info;
789 dest_info = &dest_ss->data.info;
790 gcc_assert (dest_info->dimen == 2);
791 gcc_assert (src_info->dimen == 2);
793 /* Get a descriptor for EXPR. */
794 gfc_init_se (&src_se, NULL);
795 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
796 gfc_add_block_to_block (&se->pre, &src_se.pre);
797 gfc_add_block_to_block (&se->post, &src_se.post);
800 /* Allocate a new descriptor for the return value. */
801 dest = gfc_create_var (TREE_TYPE (src), "atmp");
802 dest_info->descriptor = dest;
805 /* Copy across the dtype field. */
806 gfc_add_modify (&se->pre,
807 gfc_conv_descriptor_dtype (dest),
808 gfc_conv_descriptor_dtype (src));
810 /* Copy the dimension information, renumbering dimension 1 to 0 and
812 for (n = 0; n < 2; n++)
814 dest_info->delta[n] = gfc_index_zero_node;
815 dest_info->start[n] = gfc_index_zero_node;
816 dest_info->end[n] = gfc_index_zero_node;
817 dest_info->stride[n] = gfc_index_one_node;
818 dest_info->dim[n] = n;
820 dest_index = gfc_rank_cst[n];
821 src_index = gfc_rank_cst[1 - n];
823 gfc_add_modify (&se->pre,
824 gfc_conv_descriptor_stride (dest, dest_index),
825 gfc_conv_descriptor_stride (src, src_index));
827 gfc_add_modify (&se->pre,
828 gfc_conv_descriptor_lbound (dest, dest_index),
829 gfc_conv_descriptor_lbound (src, src_index));
831 gfc_add_modify (&se->pre,
832 gfc_conv_descriptor_ubound (dest, dest_index),
833 gfc_conv_descriptor_ubound (src, src_index));
837 gcc_assert (integer_zerop (loop->from[n]));
839 fold_build2 (MINUS_EXPR, gfc_array_index_type,
840 gfc_conv_descriptor_ubound (dest, dest_index),
841 gfc_conv_descriptor_lbound (dest, dest_index));
845 /* Copy the data pointer. */
846 dest_info->data = gfc_conv_descriptor_data_get (src);
847 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
849 /* Copy the offset. This is not changed by transposition; the top-left
850 element is still at the same offset as before, except where the loop
852 if (!integer_zerop (loop->from[0]))
853 dest_info->offset = gfc_conv_descriptor_offset (src);
855 dest_info->offset = gfc_index_zero_node;
857 gfc_add_modify (&se->pre,
858 gfc_conv_descriptor_offset (dest),
861 if (dest_info->dimen > loop->temp_dim)
862 loop->temp_dim = dest_info->dimen;
866 /* Return the number of iterations in a loop that starts at START,
867 ends at END, and has step STEP. */
870 gfc_get_iteration_count (tree start, tree end, tree step)
875 type = TREE_TYPE (step);
876 tmp = fold_build2 (MINUS_EXPR, type, end, start);
877 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
878 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
879 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
880 return fold_convert (gfc_array_index_type, tmp);
884 /* Extend the data in array DESC by EXTRA elements. */
887 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
894 if (integer_zerop (extra))
897 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
899 /* Add EXTRA to the upper bound. */
900 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
901 gfc_add_modify (pblock, ubound, tmp);
903 /* Get the value of the current data pointer. */
904 arg0 = gfc_conv_descriptor_data_get (desc);
906 /* Calculate the new array size. */
907 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
908 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
909 ubound, gfc_index_one_node);
910 arg1 = fold_build2 (MULT_EXPR, size_type_node,
911 fold_convert (size_type_node, tmp),
912 fold_convert (size_type_node, size));
914 /* Call the realloc() function. */
915 tmp = gfc_call_realloc (pblock, arg0, arg1);
916 gfc_conv_descriptor_data_set (pblock, desc, tmp);
920 /* Return true if the bounds of iterator I can only be determined
924 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
926 return (i->start->expr_type != EXPR_CONSTANT
927 || i->end->expr_type != EXPR_CONSTANT
928 || i->step->expr_type != EXPR_CONSTANT);
932 /* Split the size of constructor element EXPR into the sum of two terms,
933 one of which can be determined at compile time and one of which must
934 be calculated at run time. Set *SIZE to the former and return true
935 if the latter might be nonzero. */
938 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
940 if (expr->expr_type == EXPR_ARRAY)
941 return gfc_get_array_constructor_size (size, expr->value.constructor);
942 else if (expr->rank > 0)
944 /* Calculate everything at run time. */
945 mpz_set_ui (*size, 0);
950 /* A single element. */
951 mpz_set_ui (*size, 1);
957 /* Like gfc_get_array_constructor_element_size, but applied to the whole
958 of array constructor C. */
961 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
968 mpz_set_ui (*size, 0);
973 for (; c; c = c->next)
976 if (i && gfc_iterator_has_dynamic_bounds (i))
980 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
983 /* Multiply the static part of the element size by the
984 number of iterations. */
985 mpz_sub (val, i->end->value.integer, i->start->value.integer);
986 mpz_fdiv_q (val, val, i->step->value.integer);
987 mpz_add_ui (val, val, 1);
988 if (mpz_sgn (val) > 0)
989 mpz_mul (len, len, val);
993 mpz_add (*size, *size, len);
1002 /* Make sure offset is a variable. */
1005 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1008 /* We should have already created the offset variable. We cannot
1009 create it here because we may be in an inner scope. */
1010 gcc_assert (*offsetvar != NULL_TREE);
1011 gfc_add_modify (pblock, *offsetvar, *poffset);
1012 *poffset = *offsetvar;
1013 TREE_USED (*offsetvar) = 1;
1017 /* Variables needed for bounds-checking. */
1018 static bool first_len;
1019 static tree first_len_val;
1020 static bool typespec_chararray_ctor;
1023 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1024 tree offset, gfc_se * se, gfc_expr * expr)
1028 gfc_conv_expr (se, expr);
1030 /* Store the value. */
1031 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
1032 tmp = gfc_build_array_ref (tmp, offset, NULL);
1034 if (expr->ts.type == BT_CHARACTER)
1036 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1039 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1040 esize = fold_convert (gfc_charlen_type_node, esize);
1041 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1042 build_int_cst (gfc_charlen_type_node,
1043 gfc_character_kinds[i].bit_size / 8));
1045 gfc_conv_string_parameter (se);
1046 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1048 /* The temporary is an array of pointers. */
1049 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1050 gfc_add_modify (&se->pre, tmp, se->expr);
1054 /* The temporary is an array of string values. */
1055 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1056 /* We know the temporary and the value will be the same length,
1057 so can use memcpy. */
1058 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1059 se->string_length, se->expr, expr->ts.kind);
1061 if (flag_bounds_check && !typespec_chararray_ctor)
1065 gfc_add_modify (&se->pre, first_len_val,
1071 /* Verify that all constructor elements are of the same
1073 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1074 first_len_val, se->string_length);
1075 gfc_trans_runtime_check
1076 (true, false, cond, &se->pre, &expr->where,
1077 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1078 fold_convert (long_integer_type_node, first_len_val),
1079 fold_convert (long_integer_type_node, se->string_length));
1085 /* TODO: Should the frontend already have done this conversion? */
1086 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1087 gfc_add_modify (&se->pre, tmp, se->expr);
1090 gfc_add_block_to_block (pblock, &se->pre);
1091 gfc_add_block_to_block (pblock, &se->post);
1095 /* Add the contents of an array to the constructor. DYNAMIC is as for
1096 gfc_trans_array_constructor_value. */
1099 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1100 tree type ATTRIBUTE_UNUSED,
1101 tree desc, gfc_expr * expr,
1102 tree * poffset, tree * offsetvar,
1113 /* We need this to be a variable so we can increment it. */
1114 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1116 gfc_init_se (&se, NULL);
1118 /* Walk the array expression. */
1119 ss = gfc_walk_expr (expr);
1120 gcc_assert (ss != gfc_ss_terminator);
1122 /* Initialize the scalarizer. */
1123 gfc_init_loopinfo (&loop);
1124 gfc_add_ss_to_loop (&loop, ss);
1126 /* Initialize the loop. */
1127 gfc_conv_ss_startstride (&loop);
1128 gfc_conv_loop_setup (&loop, &expr->where);
1130 /* Make sure the constructed array has room for the new data. */
1133 /* Set SIZE to the total number of elements in the subarray. */
1134 size = gfc_index_one_node;
1135 for (n = 0; n < loop.dimen; n++)
1137 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1138 gfc_index_one_node);
1139 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1142 /* Grow the constructed array by SIZE elements. */
1143 gfc_grow_array (&loop.pre, desc, size);
1146 /* Make the loop body. */
1147 gfc_mark_ss_chain_used (ss, 1);
1148 gfc_start_scalarized_body (&loop, &body);
1149 gfc_copy_loopinfo_to_se (&se, &loop);
1152 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1153 gcc_assert (se.ss == gfc_ss_terminator);
1155 /* Increment the offset. */
1156 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1157 *poffset, gfc_index_one_node);
1158 gfc_add_modify (&body, *poffset, tmp);
1160 /* Finish the loop. */
1161 gfc_trans_scalarizing_loops (&loop, &body);
1162 gfc_add_block_to_block (&loop.pre, &loop.post);
1163 tmp = gfc_finish_block (&loop.pre);
1164 gfc_add_expr_to_block (pblock, tmp);
1166 gfc_cleanup_loop (&loop);
1170 /* Assign the values to the elements of an array constructor. DYNAMIC
1171 is true if descriptor DESC only contains enough data for the static
1172 size calculated by gfc_get_array_constructor_size. When true, memory
1173 for the dynamic parts must be allocated using realloc. */
1176 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1177 tree desc, gfc_constructor * c,
1178 tree * poffset, tree * offsetvar,
1187 for (; c; c = c->next)
1189 /* If this is an iterator or an array, the offset must be a variable. */
1190 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1191 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1193 gfc_start_block (&body);
1195 if (c->expr->expr_type == EXPR_ARRAY)
1197 /* Array constructors can be nested. */
1198 gfc_trans_array_constructor_value (&body, type, desc,
1199 c->expr->value.constructor,
1200 poffset, offsetvar, dynamic);
1202 else if (c->expr->rank > 0)
1204 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1205 poffset, offsetvar, dynamic);
1209 /* This code really upsets the gimplifier so don't bother for now. */
1216 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1223 /* Scalar values. */
1224 gfc_init_se (&se, NULL);
1225 gfc_trans_array_ctor_element (&body, desc, *poffset,
1228 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1229 *poffset, gfc_index_one_node);
1233 /* Collect multiple scalar constants into a constructor. */
1238 HOST_WIDE_INT idx = 0;
1242 /* Count the number of consecutive scalar constants. */
1243 while (p && !(p->iterator
1244 || p->expr->expr_type != EXPR_CONSTANT))
1246 gfc_init_se (&se, NULL);
1247 gfc_conv_constant (&se, p->expr);
1249 /* For constant character array constructors we build
1250 an array of pointers. */
1251 if (p->expr->ts.type == BT_CHARACTER
1252 && POINTER_TYPE_P (type))
1253 se.expr = gfc_build_addr_expr
1254 (gfc_get_pchar_type (p->expr->ts.kind),
1257 list = tree_cons (build_int_cst (gfc_array_index_type,
1258 idx++), se.expr, list);
1263 bound = build_int_cst (NULL_TREE, n - 1);
1264 /* Create an array type to hold them. */
1265 tmptype = build_range_type (gfc_array_index_type,
1266 gfc_index_zero_node, bound);
1267 tmptype = build_array_type (type, tmptype);
1269 init = build_constructor_from_list (tmptype, nreverse (list));
1270 TREE_CONSTANT (init) = 1;
1271 TREE_STATIC (init) = 1;
1272 /* Create a static variable to hold the data. */
1273 tmp = gfc_create_var (tmptype, "data");
1274 TREE_STATIC (tmp) = 1;
1275 TREE_CONSTANT (tmp) = 1;
1276 TREE_READONLY (tmp) = 1;
1277 DECL_INITIAL (tmp) = init;
1280 /* Use BUILTIN_MEMCPY to assign the values. */
1281 tmp = gfc_conv_descriptor_data_get (desc);
1282 tmp = build_fold_indirect_ref (tmp);
1283 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1284 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1285 init = gfc_build_addr_expr (NULL_TREE, init);
1287 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1288 bound = build_int_cst (NULL_TREE, n * size);
1289 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1291 gfc_add_expr_to_block (&body, tmp);
1293 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1295 build_int_cst (gfc_array_index_type, n));
1297 if (!INTEGER_CST_P (*poffset))
1299 gfc_add_modify (&body, *offsetvar, *poffset);
1300 *poffset = *offsetvar;
1304 /* The frontend should already have done any expansions
1308 /* Pass the code as is. */
1309 tmp = gfc_finish_block (&body);
1310 gfc_add_expr_to_block (pblock, tmp);
1314 /* Build the implied do-loop. */
1324 loopbody = gfc_finish_block (&body);
1326 if (c->iterator->var->symtree->n.sym->backend_decl)
1328 gfc_init_se (&se, NULL);
1329 gfc_conv_expr (&se, c->iterator->var);
1330 gfc_add_block_to_block (pblock, &se.pre);
1335 /* If the iterator appears in a specification expression in
1336 an interface mapping, we need to make a temp for the loop
1337 variable because it is not declared locally. */
1338 loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
1339 loopvar = gfc_create_var (loopvar, "loopvar");
1342 /* Make a temporary, store the current value in that
1343 and return it, once the loop is done. */
1344 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1345 gfc_add_modify (pblock, tmp_loopvar, loopvar);
1347 /* Initialize the loop. */
1348 gfc_init_se (&se, NULL);
1349 gfc_conv_expr_val (&se, c->iterator->start);
1350 gfc_add_block_to_block (pblock, &se.pre);
1351 gfc_add_modify (pblock, loopvar, se.expr);
1353 gfc_init_se (&se, NULL);
1354 gfc_conv_expr_val (&se, c->iterator->end);
1355 gfc_add_block_to_block (pblock, &se.pre);
1356 end = gfc_evaluate_now (se.expr, pblock);
1358 gfc_init_se (&se, NULL);
1359 gfc_conv_expr_val (&se, c->iterator->step);
1360 gfc_add_block_to_block (pblock, &se.pre);
1361 step = gfc_evaluate_now (se.expr, pblock);
1363 /* If this array expands dynamically, and the number of iterations
1364 is not constant, we won't have allocated space for the static
1365 part of C->EXPR's size. Do that now. */
1366 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1368 /* Get the number of iterations. */
1369 tmp = gfc_get_iteration_count (loopvar, end, step);
1371 /* Get the static part of C->EXPR's size. */
1372 gfc_get_array_constructor_element_size (&size, c->expr);
1373 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1375 /* Grow the array by TMP * TMP2 elements. */
1376 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1377 gfc_grow_array (pblock, desc, tmp);
1380 /* Generate the loop body. */
1381 exit_label = gfc_build_label_decl (NULL_TREE);
1382 gfc_start_block (&body);
1384 /* Generate the exit condition. Depending on the sign of
1385 the step variable we have to generate the correct
1387 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1388 build_int_cst (TREE_TYPE (step), 0));
1389 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1390 fold_build2 (GT_EXPR, boolean_type_node,
1392 fold_build2 (LT_EXPR, boolean_type_node,
1394 tmp = build1_v (GOTO_EXPR, exit_label);
1395 TREE_USED (exit_label) = 1;
1396 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1397 gfc_add_expr_to_block (&body, tmp);
1399 /* The main loop body. */
1400 gfc_add_expr_to_block (&body, loopbody);
1402 /* Increase loop variable by step. */
1403 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1404 gfc_add_modify (&body, loopvar, tmp);
1406 /* Finish the loop. */
1407 tmp = gfc_finish_block (&body);
1408 tmp = build1_v (LOOP_EXPR, tmp);
1409 gfc_add_expr_to_block (pblock, tmp);
1411 /* Add the exit label. */
1412 tmp = build1_v (LABEL_EXPR, exit_label);
1413 gfc_add_expr_to_block (pblock, tmp);
1415 /* Restore the original value of the loop counter. */
1416 gfc_add_modify (pblock, loopvar, tmp_loopvar);
1423 /* Figure out the string length of a variable reference expression.
1424 Used by get_array_ctor_strlen. */
1427 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1433 /* Don't bother if we already know the length is a constant. */
1434 if (*len && INTEGER_CST_P (*len))
1437 ts = &expr->symtree->n.sym->ts;
1438 for (ref = expr->ref; ref; ref = ref->next)
1443 /* Array references don't change the string length. */
1447 /* Use the length of the component. */
1448 ts = &ref->u.c.component->ts;
1452 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1453 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1455 mpz_init_set_ui (char_len, 1);
1456 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1457 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1458 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1459 *len = convert (gfc_charlen_type_node, *len);
1460 mpz_clear (char_len);
1464 /* TODO: Substrings are tricky because we can't evaluate the
1465 expression more than once. For now we just give up, and hope
1466 we can figure it out elsewhere. */
1471 *len = ts->cl->backend_decl;
1475 /* A catch-all to obtain the string length for anything that is not a
1476 constant, array or variable. */
1478 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1483 /* Don't bother if we already know the length is a constant. */
1484 if (*len && INTEGER_CST_P (*len))
1487 if (!e->ref && e->ts.cl && e->ts.cl->length
1488 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1491 gfc_conv_const_charlen (e->ts.cl);
1492 *len = e->ts.cl->backend_decl;
1496 /* Otherwise, be brutal even if inefficient. */
1497 ss = gfc_walk_expr (e);
1498 gfc_init_se (&se, NULL);
1500 /* No function call, in case of side effects. */
1501 se.no_function_call = 1;
1502 if (ss == gfc_ss_terminator)
1503 gfc_conv_expr (&se, e);
1505 gfc_conv_expr_descriptor (&se, e, ss);
1507 /* Fix the value. */
1508 *len = gfc_evaluate_now (se.string_length, &se.pre);
1510 gfc_add_block_to_block (block, &se.pre);
1511 gfc_add_block_to_block (block, &se.post);
1513 e->ts.cl->backend_decl = *len;
1518 /* Figure out the string length of a character array constructor.
1519 If len is NULL, don't calculate the length; this happens for recursive calls
1520 when a sub-array-constructor is an element but not at the first position,
1521 so when we're not interested in the length.
1522 Returns TRUE if all elements are character constants. */
1525 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1534 *len = build_int_cstu (gfc_charlen_type_node, 0);
1538 /* Loop over all constructor elements to find out is_const, but in len we
1539 want to store the length of the first, not the last, element. We can
1540 of course exit the loop as soon as is_const is found to be false. */
1541 for (; c && is_const; c = c->next)
1543 switch (c->expr->expr_type)
1546 if (len && !(*len && INTEGER_CST_P (*len)))
1547 *len = build_int_cstu (gfc_charlen_type_node,
1548 c->expr->value.character.length);
1552 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1559 get_array_ctor_var_strlen (c->expr, len);
1565 get_array_ctor_all_strlen (block, c->expr, len);
1569 /* After the first iteration, we don't want the length modified. */
1576 /* Check whether the array constructor C consists entirely of constant
1577 elements, and if so returns the number of those elements, otherwise
1578 return zero. Note, an empty or NULL array constructor returns zero. */
1580 unsigned HOST_WIDE_INT
1581 gfc_constant_array_constructor_p (gfc_constructor * c)
1583 unsigned HOST_WIDE_INT nelem = 0;
1588 || c->expr->rank > 0
1589 || c->expr->expr_type != EXPR_CONSTANT)
1598 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1599 and the tree type of it's elements, TYPE, return a static constant
1600 variable that is compile-time initialized. */
1603 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1605 tree tmptype, list, init, tmp;
1606 HOST_WIDE_INT nelem;
1612 /* First traverse the constructor list, converting the constants
1613 to tree to build an initializer. */
1616 c = expr->value.constructor;
1619 gfc_init_se (&se, NULL);
1620 gfc_conv_constant (&se, c->expr);
1621 if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
1622 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1624 list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1630 /* Next determine the tree type for the array. We use the gfortran
1631 front-end's gfc_get_nodesc_array_type in order to create a suitable
1632 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1634 memset (&as, 0, sizeof (gfc_array_spec));
1636 as.rank = expr->rank;
1637 as.type = AS_EXPLICIT;
1640 as.lower[0] = gfc_int_expr (0);
1641 as.upper[0] = gfc_int_expr (nelem - 1);
1644 for (i = 0; i < expr->rank; i++)
1646 int tmp = (int) mpz_get_si (expr->shape[i]);
1647 as.lower[i] = gfc_int_expr (0);
1648 as.upper[i] = gfc_int_expr (tmp - 1);
1651 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1653 init = build_constructor_from_list (tmptype, nreverse (list));
1655 TREE_CONSTANT (init) = 1;
1656 TREE_STATIC (init) = 1;
1658 tmp = gfc_create_var (tmptype, "A");
1659 TREE_STATIC (tmp) = 1;
1660 TREE_CONSTANT (tmp) = 1;
1661 TREE_READONLY (tmp) = 1;
1662 DECL_INITIAL (tmp) = init;
1668 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1669 This mostly initializes the scalarizer state info structure with the
1670 appropriate values to directly use the array created by the function
1671 gfc_build_constant_array_constructor. */
1674 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1675 gfc_ss * ss, tree type)
1681 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1683 info = &ss->data.info;
1685 info->descriptor = tmp;
1686 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1687 info->offset = gfc_index_zero_node;
1689 for (i = 0; i < info->dimen; i++)
1691 info->delta[i] = gfc_index_zero_node;
1692 info->start[i] = gfc_index_zero_node;
1693 info->end[i] = gfc_index_zero_node;
1694 info->stride[i] = gfc_index_one_node;
1698 if (info->dimen > loop->temp_dim)
1699 loop->temp_dim = info->dimen;
1702 /* Helper routine of gfc_trans_array_constructor to determine if the
1703 bounds of the loop specified by LOOP are constant and simple enough
1704 to use with gfc_trans_constant_array_constructor. Returns the
1705 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1708 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1710 tree size = gfc_index_one_node;
1714 for (i = 0; i < loop->dimen; i++)
1716 /* If the bounds aren't constant, return NULL_TREE. */
1717 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1719 if (!integer_zerop (loop->from[i]))
1721 /* Only allow nonzero "from" in one-dimensional arrays. */
1722 if (loop->dimen != 1)
1724 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1725 loop->to[i], loop->from[i]);
1729 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1730 tmp, gfc_index_one_node);
1731 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1738 /* Array constructors are handled by constructing a temporary, then using that
1739 within the scalarization loop. This is not optimal, but seems by far the
1743 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1751 bool old_first_len, old_typespec_chararray_ctor;
1752 tree old_first_len_val;
1754 /* Save the old values for nested checking. */
1755 old_first_len = first_len;
1756 old_first_len_val = first_len_val;
1757 old_typespec_chararray_ctor = typespec_chararray_ctor;
1759 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1760 typespec was given for the array constructor. */
1761 typespec_chararray_ctor = (ss->expr->ts.cl
1762 && ss->expr->ts.cl->length_from_typespec);
1764 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
1765 && !typespec_chararray_ctor)
1767 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1771 ss->data.info.dimen = loop->dimen;
1773 c = ss->expr->value.constructor;
1774 if (ss->expr->ts.type == BT_CHARACTER)
1778 /* get_array_ctor_strlen walks the elements of the constructor, if a
1779 typespec was given, we already know the string length and want the one
1781 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1782 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1786 const_string = false;
1787 gfc_init_se (&length_se, NULL);
1788 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1789 gfc_charlen_type_node);
1790 ss->string_length = length_se.expr;
1791 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1792 gfc_add_block_to_block (&loop->post, &length_se.post);
1795 const_string = get_array_ctor_strlen (&loop->pre, c,
1796 &ss->string_length);
1798 /* Complex character array constructors should have been taken care of
1799 and not end up here. */
1800 gcc_assert (ss->string_length);
1802 ss->expr->ts.cl->backend_decl = ss->string_length;
1804 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1806 type = build_pointer_type (type);
1809 type = gfc_typenode_for_spec (&ss->expr->ts);
1811 /* See if the constructor determines the loop bounds. */
1814 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1816 /* We have a multidimensional parameter. */
1818 for (n = 0; n < ss->expr->rank; n++)
1820 loop->from[n] = gfc_index_zero_node;
1821 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1822 gfc_index_integer_kind);
1823 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1824 loop->to[n], gfc_index_one_node);
1828 if (loop->to[0] == NULL_TREE)
1832 /* We should have a 1-dimensional, zero-based loop. */
1833 gcc_assert (loop->dimen == 1);
1834 gcc_assert (integer_zerop (loop->from[0]));
1836 /* Split the constructor size into a static part and a dynamic part.
1837 Allocate the static size up-front and record whether the dynamic
1838 size might be nonzero. */
1840 dynamic = gfc_get_array_constructor_size (&size, c);
1841 mpz_sub_ui (size, size, 1);
1842 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1846 /* Special case constant array constructors. */
1849 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1852 tree size = constant_array_constructor_loop_size (loop);
1853 if (size && compare_tree_int (size, nelem) == 0)
1855 gfc_trans_constant_array_constructor (loop, ss, type);
1861 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1862 type, NULL_TREE, dynamic, true, false, where);
1864 desc = ss->data.info.descriptor;
1865 offset = gfc_index_zero_node;
1866 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1867 TREE_NO_WARNING (offsetvar) = 1;
1868 TREE_USED (offsetvar) = 0;
1869 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1870 &offset, &offsetvar, dynamic);
1872 /* If the array grows dynamically, the upper bound of the loop variable
1873 is determined by the array's final upper bound. */
1875 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1877 if (TREE_USED (offsetvar))
1878 pushdecl (offsetvar);
1880 gcc_assert (INTEGER_CST_P (offset));
1882 /* Disable bound checking for now because it's probably broken. */
1883 if (flag_bounds_check)
1890 /* Restore old values of globals. */
1891 first_len = old_first_len;
1892 first_len_val = old_first_len_val;
1893 typespec_chararray_ctor = old_typespec_chararray_ctor;
1897 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1898 called after evaluating all of INFO's vector dimensions. Go through
1899 each such vector dimension and see if we can now fill in any missing
1903 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1912 for (n = 0; n < loop->dimen; n++)
1915 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1916 && loop->to[n] == NULL)
1918 /* Loop variable N indexes vector dimension DIM, and we don't
1919 yet know the upper bound of loop variable N. Set it to the
1920 difference between the vector's upper and lower bounds. */
1921 gcc_assert (loop->from[n] == gfc_index_zero_node);
1922 gcc_assert (info->subscript[dim]
1923 && info->subscript[dim]->type == GFC_SS_VECTOR);
1925 gfc_init_se (&se, NULL);
1926 desc = info->subscript[dim]->data.info.descriptor;
1927 zero = gfc_rank_cst[0];
1928 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1929 gfc_conv_descriptor_ubound (desc, zero),
1930 gfc_conv_descriptor_lbound (desc, zero));
1931 tmp = gfc_evaluate_now (tmp, &loop->pre);
1938 /* Add the pre and post chains for all the scalar expressions in a SS chain
1939 to loop. This is called after the loop parameters have been calculated,
1940 but before the actual scalarizing loops. */
1943 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1949 /* TODO: This can generate bad code if there are ordering dependencies,
1950 e.g., a callee allocated function and an unknown size constructor. */
1951 gcc_assert (ss != NULL);
1953 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1960 /* Scalar expression. Evaluate this now. This includes elemental
1961 dimension indices, but not array section bounds. */
1962 gfc_init_se (&se, NULL);
1963 gfc_conv_expr (&se, ss->expr);
1964 gfc_add_block_to_block (&loop->pre, &se.pre);
1966 if (ss->expr->ts.type != BT_CHARACTER)
1968 /* Move the evaluation of scalar expressions outside the
1969 scalarization loop, except for WHERE assignments. */
1971 se.expr = convert(gfc_array_index_type, se.expr);
1973 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1974 gfc_add_block_to_block (&loop->pre, &se.post);
1977 gfc_add_block_to_block (&loop->post, &se.post);
1979 ss->data.scalar.expr = se.expr;
1980 ss->string_length = se.string_length;
1983 case GFC_SS_REFERENCE:
1984 /* Scalar reference. Evaluate this now. */
1985 gfc_init_se (&se, NULL);
1986 gfc_conv_expr_reference (&se, ss->expr);
1987 gfc_add_block_to_block (&loop->pre, &se.pre);
1988 gfc_add_block_to_block (&loop->post, &se.post);
1990 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1991 ss->string_length = se.string_length;
1994 case GFC_SS_SECTION:
1995 /* Add the expressions for scalar and vector subscripts. */
1996 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1997 if (ss->data.info.subscript[n])
1998 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2001 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2005 /* Get the vector's descriptor and store it in SS. */
2006 gfc_init_se (&se, NULL);
2007 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2008 gfc_add_block_to_block (&loop->pre, &se.pre);
2009 gfc_add_block_to_block (&loop->post, &se.post);
2010 ss->data.info.descriptor = se.expr;
2013 case GFC_SS_INTRINSIC:
2014 gfc_add_intrinsic_ss_code (loop, ss);
2017 case GFC_SS_FUNCTION:
2018 /* Array function return value. We call the function and save its
2019 result in a temporary for use inside the loop. */
2020 gfc_init_se (&se, NULL);
2023 gfc_conv_expr (&se, ss->expr);
2024 gfc_add_block_to_block (&loop->pre, &se.pre);
2025 gfc_add_block_to_block (&loop->post, &se.post);
2026 ss->string_length = se.string_length;
2029 case GFC_SS_CONSTRUCTOR:
2030 if (ss->expr->ts.type == BT_CHARACTER
2031 && ss->string_length == NULL
2033 && ss->expr->ts.cl->length)
2035 gfc_init_se (&se, NULL);
2036 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
2037 gfc_charlen_type_node);
2038 ss->string_length = se.expr;
2039 gfc_add_block_to_block (&loop->pre, &se.pre);
2040 gfc_add_block_to_block (&loop->post, &se.post);
2042 gfc_trans_array_constructor (loop, ss, where);
2046 case GFC_SS_COMPONENT:
2047 /* Do nothing. These are handled elsewhere. */
2057 /* Translate expressions for the descriptor and data pointer of a SS. */
2061 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2066 /* Get the descriptor for the array to be scalarized. */
2067 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2068 gfc_init_se (&se, NULL);
2069 se.descriptor_only = 1;
2070 gfc_conv_expr_lhs (&se, ss->expr);
2071 gfc_add_block_to_block (block, &se.pre);
2072 ss->data.info.descriptor = se.expr;
2073 ss->string_length = se.string_length;
2077 /* Also the data pointer. */
2078 tmp = gfc_conv_array_data (se.expr);
2079 /* If this is a variable or address of a variable we use it directly.
2080 Otherwise we must evaluate it now to avoid breaking dependency
2081 analysis by pulling the expressions for elemental array indices
2084 || (TREE_CODE (tmp) == ADDR_EXPR
2085 && DECL_P (TREE_OPERAND (tmp, 0)))))
2086 tmp = gfc_evaluate_now (tmp, block);
2087 ss->data.info.data = tmp;
2089 tmp = gfc_conv_array_offset (se.expr);
2090 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2095 /* Initialize a gfc_loopinfo structure. */
2098 gfc_init_loopinfo (gfc_loopinfo * loop)
2102 memset (loop, 0, sizeof (gfc_loopinfo));
2103 gfc_init_block (&loop->pre);
2104 gfc_init_block (&loop->post);
2106 /* Initially scalarize in order. */
2107 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2110 loop->ss = gfc_ss_terminator;
2114 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2118 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2124 /* Return an expression for the data pointer of an array. */
2127 gfc_conv_array_data (tree descriptor)
2131 type = TREE_TYPE (descriptor);
2132 if (GFC_ARRAY_TYPE_P (type))
2134 if (TREE_CODE (type) == POINTER_TYPE)
2138 /* Descriptorless arrays. */
2139 return gfc_build_addr_expr (NULL_TREE, descriptor);
2143 return gfc_conv_descriptor_data_get (descriptor);
2147 /* Return an expression for the base offset of an array. */
2150 gfc_conv_array_offset (tree descriptor)
2154 type = TREE_TYPE (descriptor);
2155 if (GFC_ARRAY_TYPE_P (type))
2156 return GFC_TYPE_ARRAY_OFFSET (type);
2158 return gfc_conv_descriptor_offset (descriptor);
2162 /* Get an expression for the array stride. */
2165 gfc_conv_array_stride (tree descriptor, int dim)
2170 type = TREE_TYPE (descriptor);
2172 /* For descriptorless arrays use the array size. */
2173 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2174 if (tmp != NULL_TREE)
2177 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2182 /* Like gfc_conv_array_stride, but for the lower bound. */
2185 gfc_conv_array_lbound (tree descriptor, int dim)
2190 type = TREE_TYPE (descriptor);
2192 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2193 if (tmp != NULL_TREE)
2196 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2201 /* Like gfc_conv_array_stride, but for the upper bound. */
2204 gfc_conv_array_ubound (tree descriptor, int dim)
2209 type = TREE_TYPE (descriptor);
2211 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2212 if (tmp != NULL_TREE)
2215 /* This should only ever happen when passing an assumed shape array
2216 as an actual parameter. The value will never be used. */
2217 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2218 return gfc_index_zero_node;
2220 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2225 /* Generate code to perform an array index bound check. */
2228 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2229 locus * where, bool check_upper)
2234 const char * name = NULL;
2236 if (!flag_bounds_check)
2239 index = gfc_evaluate_now (index, &se->pre);
2241 /* We find a name for the error message. */
2243 name = se->ss->expr->symtree->name;
2245 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2246 && se->loop->ss->expr->symtree)
2247 name = se->loop->ss->expr->symtree->name;
2249 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2250 && se->loop->ss->loop_chain->expr
2251 && se->loop->ss->loop_chain->expr->symtree)
2252 name = se->loop->ss->loop_chain->expr->symtree->name;
2254 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2255 && se->loop->ss->loop_chain->expr->symtree)
2256 name = se->loop->ss->loop_chain->expr->symtree->name;
2258 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2260 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2261 && se->loop->ss->expr->value.function.name)
2262 name = se->loop->ss->expr->value.function.name;
2264 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2265 || se->loop->ss->type == GFC_SS_SCALAR)
2266 name = "unnamed constant";
2269 /* Check lower bound. */
2270 tmp = gfc_conv_array_lbound (descriptor, n);
2271 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2273 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2274 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2276 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2277 gfc_msg_fault, n+1);
2278 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2279 fold_convert (long_integer_type_node, index),
2280 fold_convert (long_integer_type_node, tmp));
2283 /* Check upper bound. */
2286 tmp = gfc_conv_array_ubound (descriptor, n);
2287 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2289 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2290 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2292 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2293 gfc_msg_fault, n+1);
2294 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2295 fold_convert (long_integer_type_node, index),
2296 fold_convert (long_integer_type_node, tmp));
2304 /* Return the offset for an index. Performs bound checking for elemental
2305 dimensions. Single element references are processed separately. */
2308 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2309 gfc_array_ref * ar, tree stride)
2315 /* Get the index into the array for this dimension. */
2318 gcc_assert (ar->type != AR_ELEMENT);
2319 switch (ar->dimen_type[dim])
2322 /* Elemental dimension. */
2323 gcc_assert (info->subscript[dim]
2324 && info->subscript[dim]->type == GFC_SS_SCALAR);
2325 /* We've already translated this value outside the loop. */
2326 index = info->subscript[dim]->data.scalar.expr;
2328 index = gfc_trans_array_bound_check (se, info->descriptor,
2329 index, dim, &ar->where,
2330 (ar->as->type != AS_ASSUMED_SIZE
2331 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2335 gcc_assert (info && se->loop);
2336 gcc_assert (info->subscript[dim]
2337 && info->subscript[dim]->type == GFC_SS_VECTOR);
2338 desc = info->subscript[dim]->data.info.descriptor;
2340 /* Get a zero-based index into the vector. */
2341 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2342 se->loop->loopvar[i], se->loop->from[i]);
2344 /* Multiply the index by the stride. */
2345 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2346 index, gfc_conv_array_stride (desc, 0));
2348 /* Read the vector to get an index into info->descriptor. */
2349 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2350 index = gfc_build_array_ref (data, index, NULL);
2351 index = gfc_evaluate_now (index, &se->pre);
2353 /* Do any bounds checking on the final info->descriptor index. */
2354 index = gfc_trans_array_bound_check (se, info->descriptor,
2355 index, dim, &ar->where,
2356 (ar->as->type != AS_ASSUMED_SIZE
2357 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2361 /* Scalarized dimension. */
2362 gcc_assert (info && se->loop);
2364 /* Multiply the loop variable by the stride and delta. */
2365 index = se->loop->loopvar[i];
2366 if (!integer_onep (info->stride[i]))
2367 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2369 if (!integer_zerop (info->delta[i]))
2370 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2380 /* Temporary array or derived type component. */
2381 gcc_assert (se->loop);
2382 index = se->loop->loopvar[se->loop->order[i]];
2383 if (!integer_zerop (info->delta[i]))
2384 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2385 index, info->delta[i]);
2388 /* Multiply by the stride. */
2389 if (!integer_onep (stride))
2390 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2396 /* Build a scalarized reference to an array. */
2399 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2402 tree decl = NULL_TREE;
2407 info = &se->ss->data.info;
2409 n = se->loop->order[0];
2413 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2415 /* Add the offset for this dimension to the stored offset for all other
2417 if (!integer_zerop (info->offset))
2418 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2420 if (se->ss->expr && is_subref_array (se->ss->expr))
2421 decl = se->ss->expr->symtree->n.sym->backend_decl;
2423 tmp = build_fold_indirect_ref (info->data);
2424 se->expr = gfc_build_array_ref (tmp, index, decl);
2428 /* Translate access of temporary array. */
2431 gfc_conv_tmp_array_ref (gfc_se * se)
2433 se->string_length = se->ss->string_length;
2434 gfc_conv_scalarized_array_ref (se, NULL);
2438 /* Build an array reference. se->expr already holds the array descriptor.
2439 This should be either a variable, indirect variable reference or component
2440 reference. For arrays which do not have a descriptor, se->expr will be
2442 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2445 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2454 /* Handle scalarized references separately. */
2455 if (ar->type != AR_ELEMENT)
2457 gfc_conv_scalarized_array_ref (se, ar);
2458 gfc_advance_se_ss_chain (se);
2462 index = gfc_index_zero_node;
2464 /* Calculate the offsets from all the dimensions. */
2465 for (n = 0; n < ar->dimen; n++)
2467 /* Calculate the index for this dimension. */
2468 gfc_init_se (&indexse, se);
2469 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2470 gfc_add_block_to_block (&se->pre, &indexse.pre);
2472 if (flag_bounds_check)
2474 /* Check array bounds. */
2478 /* Evaluate the indexse.expr only once. */
2479 indexse.expr = save_expr (indexse.expr);
2482 tmp = gfc_conv_array_lbound (se->expr, n);
2483 cond = fold_build2 (LT_EXPR, boolean_type_node,
2485 asprintf (&msg, "%s for array '%s', "
2486 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2487 gfc_msg_fault, sym->name, n+1);
2488 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2489 fold_convert (long_integer_type_node,
2491 fold_convert (long_integer_type_node, tmp));
2494 /* Upper bound, but not for the last dimension of assumed-size
2496 if (n < ar->dimen - 1
2497 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2499 tmp = gfc_conv_array_ubound (se->expr, n);
2500 cond = fold_build2 (GT_EXPR, boolean_type_node,
2502 asprintf (&msg, "%s for array '%s', "
2503 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2504 gfc_msg_fault, sym->name, n+1);
2505 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2506 fold_convert (long_integer_type_node,
2508 fold_convert (long_integer_type_node, tmp));
2513 /* Multiply the index by the stride. */
2514 stride = gfc_conv_array_stride (se->expr, n);
2515 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2518 /* And add it to the total. */
2519 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2522 tmp = gfc_conv_array_offset (se->expr);
2523 if (!integer_zerop (tmp))
2524 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2526 /* Access the calculated element. */
2527 tmp = gfc_conv_array_data (se->expr);
2528 tmp = build_fold_indirect_ref (tmp);
2529 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2533 /* Generate the code to be executed immediately before entering a
2534 scalarization loop. */
2537 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2538 stmtblock_t * pblock)
2547 /* This code will be executed before entering the scalarization loop
2548 for this dimension. */
2549 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2551 if ((ss->useflags & flag) == 0)
2554 if (ss->type != GFC_SS_SECTION
2555 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2556 && ss->type != GFC_SS_COMPONENT)
2559 info = &ss->data.info;
2561 if (dim >= info->dimen)
2564 if (dim == info->dimen - 1)
2566 /* For the outermost loop calculate the offset due to any
2567 elemental dimensions. It will have been initialized with the
2568 base offset of the array. */
2571 for (i = 0; i < info->ref->u.ar.dimen; i++)
2573 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2576 gfc_init_se (&se, NULL);
2578 se.expr = info->descriptor;
2579 stride = gfc_conv_array_stride (info->descriptor, i);
2580 index = gfc_conv_array_index_offset (&se, info, i, -1,
2583 gfc_add_block_to_block (pblock, &se.pre);
2585 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2586 info->offset, index);
2587 info->offset = gfc_evaluate_now (info->offset, pblock);
2591 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2594 stride = gfc_conv_array_stride (info->descriptor, 0);
2596 /* Calculate the stride of the innermost loop. Hopefully this will
2597 allow the backend optimizers to do their stuff more effectively.
2599 info->stride0 = gfc_evaluate_now (stride, pblock);
2603 /* Add the offset for the previous loop dimension. */
2608 ar = &info->ref->u.ar;
2609 i = loop->order[dim + 1];
2617 gfc_init_se (&se, NULL);
2619 se.expr = info->descriptor;
2620 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2621 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2623 gfc_add_block_to_block (pblock, &se.pre);
2624 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2625 info->offset, index);
2626 info->offset = gfc_evaluate_now (info->offset, pblock);
2629 /* Remember this offset for the second loop. */
2630 if (dim == loop->temp_dim - 1)
2631 info->saved_offset = info->offset;
2636 /* Start a scalarized expression. Creates a scope and declares loop
2640 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2646 gcc_assert (!loop->array_parameter);
2648 for (dim = loop->dimen - 1; dim >= 0; dim--)
2650 n = loop->order[dim];
2652 gfc_start_block (&loop->code[n]);
2654 /* Create the loop variable. */
2655 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2657 if (dim < loop->temp_dim)
2661 /* Calculate values that will be constant within this loop. */
2662 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2664 gfc_start_block (pbody);
2668 /* Generates the actual loop code for a scalarization loop. */
2671 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2672 stmtblock_t * pbody)
2680 loopbody = gfc_finish_block (pbody);
2682 /* Initialize the loopvar. */
2683 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2685 exit_label = gfc_build_label_decl (NULL_TREE);
2687 /* Generate the loop body. */
2688 gfc_init_block (&block);
2690 /* The exit condition. */
2691 cond = fold_build2 (GT_EXPR, boolean_type_node,
2692 loop->loopvar[n], loop->to[n]);
2693 tmp = build1_v (GOTO_EXPR, exit_label);
2694 TREE_USED (exit_label) = 1;
2695 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2696 gfc_add_expr_to_block (&block, tmp);
2698 /* The main body. */
2699 gfc_add_expr_to_block (&block, loopbody);
2701 /* Increment the loopvar. */
2702 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2703 loop->loopvar[n], gfc_index_one_node);
2704 gfc_add_modify (&block, loop->loopvar[n], tmp);
2706 /* Build the loop. */
2707 tmp = gfc_finish_block (&block);
2708 tmp = build1_v (LOOP_EXPR, tmp);
2709 gfc_add_expr_to_block (&loop->code[n], tmp);
2711 /* Add the exit label. */
2712 tmp = build1_v (LABEL_EXPR, exit_label);
2713 gfc_add_expr_to_block (&loop->code[n], tmp);
2717 /* Finishes and generates the loops for a scalarized expression. */
2720 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2725 stmtblock_t *pblock;
2729 /* Generate the loops. */
2730 for (dim = 0; dim < loop->dimen; dim++)
2732 n = loop->order[dim];
2733 gfc_trans_scalarized_loop_end (loop, n, pblock);
2734 loop->loopvar[n] = NULL_TREE;
2735 pblock = &loop->code[n];
2738 tmp = gfc_finish_block (pblock);
2739 gfc_add_expr_to_block (&loop->pre, tmp);
2741 /* Clear all the used flags. */
2742 for (ss = loop->ss; ss; ss = ss->loop_chain)
2747 /* Finish the main body of a scalarized expression, and start the secondary
2751 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2755 stmtblock_t *pblock;
2759 /* We finish as many loops as are used by the temporary. */
2760 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2762 n = loop->order[dim];
2763 gfc_trans_scalarized_loop_end (loop, n, pblock);
2764 loop->loopvar[n] = NULL_TREE;
2765 pblock = &loop->code[n];
2768 /* We don't want to finish the outermost loop entirely. */
2769 n = loop->order[loop->temp_dim - 1];
2770 gfc_trans_scalarized_loop_end (loop, n, pblock);
2772 /* Restore the initial offsets. */
2773 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2775 if ((ss->useflags & 2) == 0)
2778 if (ss->type != GFC_SS_SECTION
2779 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2780 && ss->type != GFC_SS_COMPONENT)
2783 ss->data.info.offset = ss->data.info.saved_offset;
2786 /* Restart all the inner loops we just finished. */
2787 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2789 n = loop->order[dim];
2791 gfc_start_block (&loop->code[n]);
2793 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2795 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2798 /* Start a block for the secondary copying code. */
2799 gfc_start_block (body);
2803 /* Calculate the upper bound of an array section. */
2806 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2815 gcc_assert (ss->type == GFC_SS_SECTION);
2817 info = &ss->data.info;
2820 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2821 /* We'll calculate the upper bound once we have access to the
2822 vector's descriptor. */
2825 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2826 desc = info->descriptor;
2827 end = info->ref->u.ar.end[dim];
2831 /* The upper bound was specified. */
2832 gfc_init_se (&se, NULL);
2833 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2834 gfc_add_block_to_block (pblock, &se.pre);
2839 /* No upper bound was specified, so use the bound of the array. */
2840 bound = gfc_conv_array_ubound (desc, dim);
2847 /* Calculate the lower bound of an array section. */
2850 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2860 gcc_assert (ss->type == GFC_SS_SECTION);
2862 info = &ss->data.info;
2865 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2867 /* We use a zero-based index to access the vector. */
2868 info->start[n] = gfc_index_zero_node;
2869 info->end[n] = gfc_index_zero_node;
2870 info->stride[n] = gfc_index_one_node;
2874 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2875 desc = info->descriptor;
2876 start = info->ref->u.ar.start[dim];
2877 end = info->ref->u.ar.end[dim];
2878 stride = info->ref->u.ar.stride[dim];
2880 /* Calculate the start of the range. For vector subscripts this will
2881 be the range of the vector. */
2884 /* Specified section start. */
2885 gfc_init_se (&se, NULL);
2886 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2887 gfc_add_block_to_block (&loop->pre, &se.pre);
2888 info->start[n] = se.expr;
2892 /* No lower bound specified so use the bound of the array. */
2893 info->start[n] = gfc_conv_array_lbound (desc, dim);
2895 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2897 /* Similarly calculate the end. Although this is not used in the
2898 scalarizer, it is needed when checking bounds and where the end
2899 is an expression with side-effects. */
2902 /* Specified section start. */
2903 gfc_init_se (&se, NULL);
2904 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2905 gfc_add_block_to_block (&loop->pre, &se.pre);
2906 info->end[n] = se.expr;
2910 /* No upper bound specified so use the bound of the array. */
2911 info->end[n] = gfc_conv_array_ubound (desc, dim);
2913 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2915 /* Calculate the stride. */
2917 info->stride[n] = gfc_index_one_node;
2920 gfc_init_se (&se, NULL);
2921 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2922 gfc_add_block_to_block (&loop->pre, &se.pre);
2923 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2928 /* Calculates the range start and stride for a SS chain. Also gets the
2929 descriptor and data pointer. The range of vector subscripts is the size
2930 of the vector. Array bounds are also checked. */
2933 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2941 /* Determine the rank of the loop. */
2943 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2947 case GFC_SS_SECTION:
2948 case GFC_SS_CONSTRUCTOR:
2949 case GFC_SS_FUNCTION:
2950 case GFC_SS_COMPONENT:
2951 loop->dimen = ss->data.info.dimen;
2954 /* As usual, lbound and ubound are exceptions!. */
2955 case GFC_SS_INTRINSIC:
2956 switch (ss->expr->value.function.isym->id)
2958 case GFC_ISYM_LBOUND:
2959 case GFC_ISYM_UBOUND:
2960 loop->dimen = ss->data.info.dimen;
2971 /* We should have determined the rank of the expression by now. If
2972 not, that's bad news. */
2973 gcc_assert (loop->dimen != 0);
2975 /* Loop over all the SS in the chain. */
2976 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2978 if (ss->expr && ss->expr->shape && !ss->shape)
2979 ss->shape = ss->expr->shape;
2983 case GFC_SS_SECTION:
2984 /* Get the descriptor for the array. */
2985 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2987 for (n = 0; n < ss->data.info.dimen; n++)
2988 gfc_conv_section_startstride (loop, ss, n);
2991 case GFC_SS_INTRINSIC:
2992 switch (ss->expr->value.function.isym->id)
2994 /* Fall through to supply start and stride. */
2995 case GFC_ISYM_LBOUND:
2996 case GFC_ISYM_UBOUND:
3002 case GFC_SS_CONSTRUCTOR:
3003 case GFC_SS_FUNCTION:
3004 for (n = 0; n < ss->data.info.dimen; n++)
3006 ss->data.info.start[n] = gfc_index_zero_node;
3007 ss->data.info.end[n] = gfc_index_zero_node;
3008 ss->data.info.stride[n] = gfc_index_one_node;
3017 /* The rest is just runtime bound checking. */
3018 if (flag_bounds_check)
3021 tree lbound, ubound;
3023 tree size[GFC_MAX_DIMENSIONS];
3024 tree stride_pos, stride_neg, non_zerosized, tmp2;
3029 gfc_start_block (&block);
3031 for (n = 0; n < loop->dimen; n++)
3032 size[n] = NULL_TREE;
3034 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3038 if (ss->type != GFC_SS_SECTION)
3041 gfc_start_block (&inner);
3043 /* TODO: range checking for mapped dimensions. */
3044 info = &ss->data.info;
3046 /* This code only checks ranges. Elemental and vector
3047 dimensions are checked later. */
3048 for (n = 0; n < loop->dimen; n++)
3053 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3056 if (dim == info->ref->u.ar.dimen - 1
3057 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3058 || info->ref->u.ar.as->cp_was_assumed))
3059 check_upper = false;
3063 /* Zero stride is not allowed. */
3064 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3065 gfc_index_zero_node);
3066 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3067 "of array '%s'", info->dim[n]+1,
3068 ss->expr->symtree->name);
3069 gfc_trans_runtime_check (true, false, tmp, &inner,
3070 &ss->expr->where, msg);
3073 desc = ss->data.info.descriptor;
3075 /* This is the run-time equivalent of resolve.c's
3076 check_dimension(). The logical is more readable there
3077 than it is here, with all the trees. */
3078 lbound = gfc_conv_array_lbound (desc, dim);
3081 ubound = gfc_conv_array_ubound (desc, dim);
3085 /* non_zerosized is true when the selected range is not
3087 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3088 info->stride[n], gfc_index_zero_node);
3089 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3091 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3094 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3095 info->stride[n], gfc_index_zero_node);
3096 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3098 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3100 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3101 stride_pos, stride_neg);
3103 /* Check the start of the range against the lower and upper
3104 bounds of the array, if the range is not empty. */
3105 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3107 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3108 non_zerosized, tmp);
3109 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3110 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3111 info->dim[n]+1, ss->expr->symtree->name);
3112 gfc_trans_runtime_check (true, false, tmp, &inner,
3113 &ss->expr->where, msg,
3114 fold_convert (long_integer_type_node,
3116 fold_convert (long_integer_type_node,
3122 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3123 info->start[n], ubound);
3124 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3125 non_zerosized, tmp);
3126 asprintf (&msg, "%s, upper bound of dimension %d of array "
3127 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3128 info->dim[n]+1, ss->expr->symtree->name);
3129 gfc_trans_runtime_check (true, false, tmp, &inner,
3130 &ss->expr->where, msg,
3131 fold_convert (long_integer_type_node, info->start[n]),
3132 fold_convert (long_integer_type_node, ubound));
3136 /* Compute the last element of the range, which is not
3137 necessarily "end" (think 0:5:3, which doesn't contain 5)
3138 and check it against both lower and upper bounds. */
3139 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3141 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3143 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3146 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3147 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3148 non_zerosized, tmp);
3149 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3150 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3151 info->dim[n]+1, ss->expr->symtree->name);
3152 gfc_trans_runtime_check (true, false, tmp, &inner,
3153 &ss->expr->where, msg,
3154 fold_convert (long_integer_type_node,
3156 fold_convert (long_integer_type_node,
3162 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3163 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3164 non_zerosized, tmp);
3165 asprintf (&msg, "%s, upper bound of dimension %d of array "
3166 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3167 info->dim[n]+1, ss->expr->symtree->name);
3168 gfc_trans_runtime_check (true, false, tmp, &inner,
3169 &ss->expr->where, msg,
3170 fold_convert (long_integer_type_node, tmp2),
3171 fold_convert (long_integer_type_node, ubound));
3175 /* Check the section sizes match. */
3176 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3178 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3180 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3181 build_int_cst (gfc_array_index_type, 0));
3182 /* We remember the size of the first section, and check all the
3183 others against this. */
3188 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3189 asprintf (&msg, "%s, size mismatch for dimension %d "
3190 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3191 info->dim[n]+1, ss->expr->symtree->name);
3192 gfc_trans_runtime_check (true, false, tmp3, &inner,
3193 &ss->expr->where, msg,
3194 fold_convert (long_integer_type_node, tmp),
3195 fold_convert (long_integer_type_node, size[n]));
3199 size[n] = gfc_evaluate_now (tmp, &inner);
3202 tmp = gfc_finish_block (&inner);
3204 /* For optional arguments, only check bounds if the argument is
3206 if (ss->expr->symtree->n.sym->attr.optional
3207 || ss->expr->symtree->n.sym->attr.not_always_present)
3208 tmp = build3_v (COND_EXPR,
3209 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3210 tmp, build_empty_stmt ());
3212 gfc_add_expr_to_block (&block, tmp);
3216 tmp = gfc_finish_block (&block);
3217 gfc_add_expr_to_block (&loop->pre, tmp);
3222 /* Return true if the two SS could be aliased, i.e. both point to the same data
3224 /* TODO: resolve aliases based on frontend expressions. */
3227 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3234 lsym = lss->expr->symtree->n.sym;
3235 rsym = rss->expr->symtree->n.sym;
3236 if (gfc_symbols_could_alias (lsym, rsym))
3239 if (rsym->ts.type != BT_DERIVED
3240 && lsym->ts.type != BT_DERIVED)
3243 /* For derived types we must check all the component types. We can ignore
3244 array references as these will have the same base type as the previous
3246 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3248 if (lref->type != REF_COMPONENT)
3251 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3254 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3257 if (rref->type != REF_COMPONENT)
3260 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3265 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3267 if (rref->type != REF_COMPONENT)
3270 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3278 /* Resolve array data dependencies. Creates a temporary if required. */
3279 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3283 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3293 loop->temp_ss = NULL;
3294 aref = dest->data.info.ref;
3297 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3299 if (ss->type != GFC_SS_SECTION)
3302 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3304 if (gfc_could_be_alias (dest, ss)
3305 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3313 lref = dest->expr->ref;
3314 rref = ss->expr->ref;
3316 nDepend = gfc_dep_resolver (lref, rref);
3320 /* TODO : loop shifting. */
3323 /* Mark the dimensions for LOOP SHIFTING */
3324 for (n = 0; n < loop->dimen; n++)
3326 int dim = dest->data.info.dim[n];
3328 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3330 else if (! gfc_is_same_range (&lref->u.ar,
3331 &rref->u.ar, dim, 0))
3335 /* Put all the dimensions with dependencies in the
3338 for (n = 0; n < loop->dimen; n++)
3340 gcc_assert (loop->order[n] == n);
3342 loop->order[dim++] = n;
3345 for (n = 0; n < loop->dimen; n++)
3348 loop->order[dim++] = n;
3351 gcc_assert (dim == loop->dimen);
3360 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3361 if (GFC_ARRAY_TYPE_P (base_type)
3362 || GFC_DESCRIPTOR_TYPE_P (base_type))
3363 base_type = gfc_get_element_type (base_type);
3364 loop->temp_ss = gfc_get_ss ();
3365 loop->temp_ss->type = GFC_SS_TEMP;
3366 loop->temp_ss->data.temp.type = base_type;
3367 loop->temp_ss->string_length = dest->string_length;
3368 loop->temp_ss->data.temp.dimen = loop->dimen;
3369 loop->temp_ss->next = gfc_ss_terminator;
3370 gfc_add_ss_to_loop (loop, loop->temp_ss);
3373 loop->temp_ss = NULL;
3377 /* Initialize the scalarization loop. Creates the loop variables. Determines
3378 the range of the loop variables. Creates a temporary if required.
3379 Calculates how to transform from loop variables to array indices for each
3380 expression. Also generates code for scalar expressions which have been
3381 moved outside the loop. */
3384 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3389 gfc_ss_info *specinfo;
3393 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3394 bool dynamic[GFC_MAX_DIMENSIONS];
3400 for (n = 0; n < loop->dimen; n++)
3404 /* We use one SS term, and use that to determine the bounds of the
3405 loop for this dimension. We try to pick the simplest term. */
3406 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3410 /* The frontend has worked out the size for us. */
3411 if (!loopspec[n] || !loopspec[n]->shape
3412 || !integer_zerop (loopspec[n]->data.info.start[n]))
3413 /* Prefer zero-based descriptors if possible. */
3418 if (ss->type == GFC_SS_CONSTRUCTOR)
3420 /* An unknown size constructor will always be rank one.
3421 Higher rank constructors will either have known shape,
3422 or still be wrapped in a call to reshape. */
3423 gcc_assert (loop->dimen == 1);
3425 /* Always prefer to use the constructor bounds if the size
3426 can be determined at compile time. Prefer not to otherwise,
3427 since the general case involves realloc, and it's better to
3428 avoid that overhead if possible. */
3429 c = ss->expr->value.constructor;
3430 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3431 if (!dynamic[n] || !loopspec[n])
3436 /* TODO: Pick the best bound if we have a choice between a
3437 function and something else. */
3438 if (ss->type == GFC_SS_FUNCTION)
3444 if (ss->type != GFC_SS_SECTION)
3448 specinfo = &loopspec[n]->data.info;
3451 info = &ss->data.info;
3455 /* Criteria for choosing a loop specifier (most important first):
3456 doesn't need realloc
3462 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3464 else if (integer_onep (info->stride[n])
3465 && !integer_onep (specinfo->stride[n]))
3467 else if (INTEGER_CST_P (info->stride[n])
3468 && !INTEGER_CST_P (specinfo->stride[n]))
3470 else if (INTEGER_CST_P (info->start[n])
3471 && !INTEGER_CST_P (specinfo->start[n]))
3473 /* We don't work out the upper bound.
3474 else if (INTEGER_CST_P (info->finish[n])
3475 && ! INTEGER_CST_P (specinfo->finish[n]))
3476 loopspec[n] = ss; */
3479 /* We should have found the scalarization loop specifier. If not,
3481 gcc_assert (loopspec[n]);
3483 info = &loopspec[n]->data.info;
3485 /* Set the extents of this range. */
3486 cshape = loopspec[n]->shape;
3487 if (cshape && INTEGER_CST_P (info->start[n])
3488 && INTEGER_CST_P (info->stride[n]))
3490 loop->from[n] = info->start[n];
3491 mpz_set (i, cshape[n]);
3492 mpz_sub_ui (i, i, 1);
3493 /* To = from + (size - 1) * stride. */
3494 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3495 if (!integer_onep (info->stride[n]))
3496 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3497 tmp, info->stride[n]);
3498 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3499 loop->from[n], tmp);
3503 loop->from[n] = info->start[n];
3504 switch (loopspec[n]->type)
3506 case GFC_SS_CONSTRUCTOR:
3507 /* The upper bound is calculated when we expand the
3509 gcc_assert (loop->to[n] == NULL_TREE);
3512 case GFC_SS_SECTION:
3513 /* Use the end expression if it exists and is not constant,
3514 so that it is only evaluated once. */
3515 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3516 loop->to[n] = info->end[n];
3518 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3522 case GFC_SS_FUNCTION:
3523 /* The loop bound will be set when we generate the call. */
3524 gcc_assert (loop->to[n] == NULL_TREE);
3532 /* Transform everything so we have a simple incrementing variable. */
3533 if (integer_onep (info->stride[n]))
3534 info->delta[n] = gfc_index_zero_node;
3537 /* Set the delta for this section. */
3538 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3539 /* Number of iterations is (end - start + step) / step.
3540 with start = 0, this simplifies to
3542 for (i = 0; i<=last; i++){...}; */
3543 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3544 loop->to[n], loop->from[n]);
3545 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3546 tmp, info->stride[n]);
3547 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3548 build_int_cst (gfc_array_index_type, -1));
3549 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3550 /* Make the loop variable start at 0. */
3551 loop->from[n] = gfc_index_zero_node;
3555 /* Add all the scalar code that can be taken out of the loops.
3556 This may include calculating the loop bounds, so do it before
3557 allocating the temporary. */
3558 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3560 /* If we want a temporary then create it. */
3561 if (loop->temp_ss != NULL)
3563 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3565 /* Make absolutely sure that this is a complete type. */
3566 if (loop->temp_ss->string_length)
3567 loop->temp_ss->data.temp.type
3568 = gfc_get_character_type_len_for_eltype
3569 (TREE_TYPE (loop->temp_ss->data.temp.type),
3570 loop->temp_ss->string_length);
3572 tmp = loop->temp_ss->data.temp.type;
3573 len = loop->temp_ss->string_length;
3574 n = loop->temp_ss->data.temp.dimen;
3575 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3576 loop->temp_ss->type = GFC_SS_SECTION;
3577 loop->temp_ss->data.info.dimen = n;
3578 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3579 &loop->temp_ss->data.info, tmp, NULL_TREE,
3580 false, true, false, where);
3583 for (n = 0; n < loop->temp_dim; n++)
3584 loopspec[loop->order[n]] = NULL;
3588 /* For array parameters we don't have loop variables, so don't calculate the
3590 if (loop->array_parameter)
3593 /* Calculate the translation from loop variables to array indices. */
3594 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3596 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3597 && ss->type != GFC_SS_CONSTRUCTOR)
3601 info = &ss->data.info;
3603 for (n = 0; n < info->dimen; n++)
3607 /* If we are specifying the range the delta is already set. */
3608 if (loopspec[n] != ss)
3610 /* Calculate the offset relative to the loop variable.
3611 First multiply by the stride. */
3612 tmp = loop->from[n];
3613 if (!integer_onep (info->stride[n]))
3614 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3615 tmp, info->stride[n]);
3617 /* Then subtract this from our starting value. */
3618 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3619 info->start[n], tmp);
3621 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3628 /* Fills in an array descriptor, and returns the size of the array. The size
3629 will be a simple_val, ie a variable or a constant. Also calculates the
3630 offset of the base. Returns the size of the array.
3634 for (n = 0; n < rank; n++)
3636 a.lbound[n] = specified_lower_bound;
3637 offset = offset + a.lbond[n] * stride;
3639 a.ubound[n] = specified_upper_bound;
3640 a.stride[n] = stride;
3641 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3642 stride = stride * size;
3649 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3650 gfc_expr ** lower, gfc_expr ** upper,
3651 stmtblock_t * pblock)
3663 stmtblock_t thenblock;
3664 stmtblock_t elseblock;
3669 type = TREE_TYPE (descriptor);
3671 stride = gfc_index_one_node;
3672 offset = gfc_index_zero_node;
3674 /* Set the dtype. */
3675 tmp = gfc_conv_descriptor_dtype (descriptor);
3676 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3678 or_expr = NULL_TREE;
3680 for (n = 0; n < rank; n++)
3682 /* We have 3 possibilities for determining the size of the array:
3683 lower == NULL => lbound = 1, ubound = upper[n]
3684 upper[n] = NULL => lbound = 1, ubound = lower[n]
3685 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3688 /* Set lower bound. */
3689 gfc_init_se (&se, NULL);
3691 se.expr = gfc_index_one_node;
3694 gcc_assert (lower[n]);
3697 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3698 gfc_add_block_to_block (pblock, &se.pre);
3702 se.expr = gfc_index_one_node;
3706 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3707 gfc_add_modify (pblock, tmp, se.expr);
3709 /* Work out the offset for this component. */
3710 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3711 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3713 /* Start the calculation for the size of this dimension. */
3714 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3715 gfc_index_one_node, se.expr);
3717 /* Set upper bound. */
3718 gfc_init_se (&se, NULL);
3719 gcc_assert (ubound);
3720 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3721 gfc_add_block_to_block (pblock, &se.pre);
3723 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3724 gfc_add_modify (pblock, tmp, se.expr);
3726 /* Store the stride. */
3727 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3728 gfc_add_modify (pblock, tmp, stride);
3730 /* Calculate the size of this dimension. */
3731 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3733 /* Check whether the size for this dimension is negative. */
3734 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3735 gfc_index_zero_node);
3739 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3741 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3742 gfc_index_zero_node, size);
3744 /* Multiply the stride by the number of elements in this dimension. */
3745 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3746 stride = gfc_evaluate_now (stride, pblock);
3749 /* The stride is the number of elements in the array, so multiply by the
3750 size of an element to get the total size. */
3751 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3752 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3753 fold_convert (gfc_array_index_type, tmp));
3755 if (poffset != NULL)
3757 offset = gfc_evaluate_now (offset, pblock);
3761 if (integer_zerop (or_expr))
3763 if (integer_onep (or_expr))
3764 return gfc_index_zero_node;
3766 var = gfc_create_var (TREE_TYPE (size), "size");
3767 gfc_start_block (&thenblock);
3768 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3769 thencase = gfc_finish_block (&thenblock);
3771 gfc_start_block (&elseblock);
3772 gfc_add_modify (&elseblock, var, size);
3773 elsecase = gfc_finish_block (&elseblock);
3775 tmp = gfc_evaluate_now (or_expr, pblock);
3776 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3777 gfc_add_expr_to_block (pblock, tmp);
3783 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3784 the work for an ALLOCATE statement. */
3788 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3796 gfc_ref *ref, *prev_ref = NULL;
3797 bool allocatable_array;
3801 /* Find the last reference in the chain. */
3802 while (ref && ref->next != NULL)
3804 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3809 if (ref == NULL || ref->type != REF_ARRAY)
3813 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3815 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3817 /* Figure out the size of the array. */
3818 switch (ref->u.ar.type)
3822 upper = ref->u.ar.start;
3826 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3828 lower = ref->u.ar.as->lower;
3829 upper = ref->u.ar.as->upper;
3833 lower = ref->u.ar.start;
3834 upper = ref->u.ar.end;
3842 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3843 lower, upper, &se->pre);
3845 /* Allocate memory to store the data. */
3846 pointer = gfc_conv_descriptor_data_get (se->expr);
3847 STRIP_NOPS (pointer);
3849 /* The allocate_array variants take the old pointer as first argument. */
3850 if (allocatable_array)
3851 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3853 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3854 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3855 gfc_add_expr_to_block (&se->pre, tmp);
3857 tmp = gfc_conv_descriptor_offset (se->expr);
3858 gfc_add_modify (&se->pre, tmp, offset);
3860 if (expr->ts.type == BT_DERIVED
3861 && expr->ts.derived->attr.alloc_comp)
3863 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3864 ref->u.ar.as->rank);
3865 gfc_add_expr_to_block (&se->pre, tmp);
3872 /* Deallocate an array variable. Also used when an allocated variable goes
3877 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3883 gfc_start_block (&block);
3884 /* Get a pointer to the data. */
3885 var = gfc_conv_descriptor_data_get (descriptor);
3888 /* Parameter is the address of the data component. */
3889 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3890 gfc_add_expr_to_block (&block, tmp);
3892 /* Zero the data pointer. */
3893 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3894 var, build_int_cst (TREE_TYPE (var), 0));
3895 gfc_add_expr_to_block (&block, tmp);
3897 return gfc_finish_block (&block);
3901 /* Create an array constructor from an initialization expression.
3902 We assume the frontend already did any expansions and conversions. */
3905 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3912 unsigned HOST_WIDE_INT lo;
3914 VEC(constructor_elt,gc) *v = NULL;
3916 switch (expr->expr_type)
3919 case EXPR_STRUCTURE:
3920 /* A single scalar or derived type value. Create an array with all
3921 elements equal to that value. */
3922 gfc_init_se (&se, NULL);
3924 if (expr->expr_type == EXPR_CONSTANT)
3925 gfc_conv_constant (&se, expr);
3927 gfc_conv_structure (&se, expr, 1);
3929 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3930 gcc_assert (tmp && INTEGER_CST_P (tmp));
3931 hi = TREE_INT_CST_HIGH (tmp);
3932 lo = TREE_INT_CST_LOW (tmp);
3936 /* This will probably eat buckets of memory for large arrays. */
3937 while (hi != 0 || lo != 0)
3939 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3947 /* Create a vector of all the elements. */
3948 for (c = expr->value.constructor; c; c = c->next)
3952 /* Problems occur when we get something like
3953 integer :: a(lots) = (/(i, i=1, lots)/) */
3954 gfc_error_now ("The number of elements in the array constructor "
3955 "at %L requires an increase of the allowed %d "
3956 "upper limit. See -fmax-array-constructor "
3957 "option", &expr->where,
3958 gfc_option.flag_max_array_constructor);
3961 if (mpz_cmp_si (c->n.offset, 0) != 0)
3962 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3966 if (mpz_cmp_si (c->repeat, 0) != 0)
3970 mpz_set (maxval, c->repeat);
3971 mpz_add (maxval, c->n.offset, maxval);
3972 mpz_sub_ui (maxval, maxval, 1);
3973 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3974 if (mpz_cmp_si (c->n.offset, 0) != 0)
3976 mpz_add_ui (maxval, c->n.offset, 1);
3977 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3980 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3982 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3988 gfc_init_se (&se, NULL);
3989 switch (c->expr->expr_type)
3992 gfc_conv_constant (&se, c->expr);
3993 if (range == NULL_TREE)
3994 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3997 if (index != NULL_TREE)
3998 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3999 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4003 case EXPR_STRUCTURE:
4004 gfc_conv_structure (&se, c->expr, 1);
4005 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4010 /* Catch those occasional beasts that do not simplify
4011 for one reason or another, assuming that if they are
4012 standard defying the frontend will catch them. */
4013 gfc_conv_expr (&se, c->expr);
4014 if (range == NULL_TREE)
4015 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4018 if (index != NULL_TREE)
4019 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4020 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4028 return gfc_build_null_descriptor (type);
4034 /* Create a constructor from the list of elements. */
4035 tmp = build_constructor (type, v);
4036 TREE_CONSTANT (tmp) = 1;
4041 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4042 returns the size (in elements) of the array. */
4045 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4046 stmtblock_t * pblock)
4061 size = gfc_index_one_node;
4062 offset = gfc_index_zero_node;
4063 for (dim = 0; dim < as->rank; dim++)
4065 /* Evaluate non-constant array bound expressions. */
4066 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4067 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4069 gfc_init_se (&se, NULL);
4070 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4071 gfc_add_block_to_block (pblock, &se.pre);
4072 gfc_add_modify (pblock, lbound, se.expr);
4074 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4075 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4077 gfc_init_se (&se, NULL);
4078 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4079 gfc_add_block_to_block (pblock, &se.pre);
4080 gfc_add_modify (pblock, ubound, se.expr);
4082 /* The offset of this dimension. offset = offset - lbound * stride. */
4083 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4084 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4086 /* The size of this dimension, and the stride of the next. */
4087 if (dim + 1 < as->rank)
4088 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4090 stride = GFC_TYPE_ARRAY_SIZE (type);
4092 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4094 /* Calculate stride = size * (ubound + 1 - lbound). */
4095 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4096 gfc_index_one_node, lbound);
4097 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4098 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4100 gfc_add_modify (pblock, stride, tmp);
4102 stride = gfc_evaluate_now (tmp, pblock);
4104 /* Make sure that negative size arrays are translated
4105 to being zero size. */
4106 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4107 stride, gfc_index_zero_node);
4108 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4109 stride, gfc_index_zero_node);
4110 gfc_add_modify (pblock, stride, tmp);
4116 gfc_trans_vla_type_sizes (sym, pblock);
4123 /* Generate code to initialize/allocate an array variable. */
4126 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4135 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4137 /* Do nothing for USEd variables. */
4138 if (sym->attr.use_assoc)
4141 type = TREE_TYPE (decl);
4142 gcc_assert (GFC_ARRAY_TYPE_P (type));
4143 onstack = TREE_CODE (type) != POINTER_TYPE;
4145 gfc_start_block (&block);
4147 /* Evaluate character string length. */
4148 if (sym->ts.type == BT_CHARACTER
4149 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4151 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4153 gfc_trans_vla_type_sizes (sym, &block);
4155 /* Emit a DECL_EXPR for this variable, which will cause the
4156 gimplifier to allocate storage, and all that good stuff. */
4157 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4158 gfc_add_expr_to_block (&block, tmp);
4163 gfc_add_expr_to_block (&block, fnbody);
4164 return gfc_finish_block (&block);
4167 type = TREE_TYPE (type);
4169 gcc_assert (!sym->attr.use_assoc);
4170 gcc_assert (!TREE_STATIC (decl));
4171 gcc_assert (!sym->module);
4173 if (sym->ts.type == BT_CHARACTER
4174 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4175 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4177 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4179 /* Don't actually allocate space for Cray Pointees. */
4180 if (sym->attr.cray_pointee)
4182 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4183 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4184 gfc_add_expr_to_block (&block, fnbody);
4185 return gfc_finish_block (&block);
4188 /* The size is the number of elements in the array, so multiply by the
4189 size of an element to get the total size. */
4190 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4191 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4192 fold_convert (gfc_array_index_type, tmp));
4194 /* Allocate memory to hold the data. */
4195 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4196 gfc_add_modify (&block, decl, tmp);
4198 /* Set offset of the array. */
4199 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4200 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4203 /* Automatic arrays should not have initializers. */
4204 gcc_assert (!sym->value);
4206 gfc_add_expr_to_block (&block, fnbody);
4208 /* Free the temporary. */
4209 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4210 gfc_add_expr_to_block (&block, tmp);
4212 return gfc_finish_block (&block);
4216 /* Generate entry and exit code for g77 calling convention arrays. */
4219 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4229 gfc_get_backend_locus (&loc);
4230 gfc_set_backend_locus (&sym->declared_at);
4232 /* Descriptor type. */
4233 parm = sym->backend_decl;
4234 type = TREE_TYPE (parm);
4235 gcc_assert (GFC_ARRAY_TYPE_P (type));
4237 gfc_start_block (&block);
4239 if (sym->ts.type == BT_CHARACTER
4240 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4241 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4243 /* Evaluate the bounds of the array. */
4244 gfc_trans_array_bounds (type, sym, &offset, &block);
4246 /* Set the offset. */
4247 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4248 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4250 /* Set the pointer itself if we aren't using the parameter directly. */
4251 if (TREE_CODE (parm) != PARM_DECL)
4253 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4254 gfc_add_modify (&block, parm, tmp);
4256 stmt = gfc_finish_block (&block);
4258 gfc_set_backend_locus (&loc);
4260 gfc_start_block (&block);
4262 /* Add the initialization code to the start of the function. */
4264 if (sym->attr.optional || sym->attr.not_always_present)
4266 tmp = gfc_conv_expr_present (sym);
4267 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4270 gfc_add_expr_to_block (&block, stmt);
4271 gfc_add_expr_to_block (&block, body);
4273 return gfc_finish_block (&block);
4277 /* Modify the descriptor of an array parameter so that it has the
4278 correct lower bound. Also move the upper bound accordingly.
4279 If the array is not packed, it will be copied into a temporary.
4280 For each dimension we set the new lower and upper bounds. Then we copy the
4281 stride and calculate the offset for this dimension. We also work out
4282 what the stride of a packed array would be, and see it the two match.
4283 If the array need repacking, we set the stride to the values we just
4284 calculated, recalculate the offset and copy the array data.
4285 Code is also added to copy the data back at the end of the function.
4289 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4296 stmtblock_t cleanup;
4304 tree stride, stride2;
4314 /* Do nothing for pointer and allocatable arrays. */
4315 if (sym->attr.pointer || sym->attr.allocatable)
4318 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4319 return gfc_trans_g77_array (sym, body);
4321 gfc_get_backend_locus (&loc);
4322 gfc_set_backend_locus (&sym->declared_at);
4324 /* Descriptor type. */
4325 type = TREE_TYPE (tmpdesc);
4326 gcc_assert (GFC_ARRAY_TYPE_P (type));
4327 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4328 dumdesc = build_fold_indirect_ref (dumdesc);
4329 gfc_start_block (&block);
4331 if (sym->ts.type == BT_CHARACTER
4332 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4333 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4335 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4337 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4338 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4340 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4342 /* For non-constant shape arrays we only check if the first dimension
4343 is contiguous. Repacking higher dimensions wouldn't gain us
4344 anything as we still don't know the array stride. */
4345 partial = gfc_create_var (boolean_type_node, "partial");
4346 TREE_USED (partial) = 1;
4347 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4348 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4349 gfc_add_modify (&block, partial, tmp);
4353 partial = NULL_TREE;
4356 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4357 here, however I think it does the right thing. */
4360 /* Set the first stride. */
4361 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4362 stride = gfc_evaluate_now (stride, &block);
4364 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4365 stride, gfc_index_zero_node);
4366 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4367 gfc_index_one_node, stride);
4368 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4369 gfc_add_modify (&block, stride, tmp);
4371 /* Allow the user to disable array repacking. */
4372 stmt_unpacked = NULL_TREE;
4376 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4377 /* A library call to repack the array if necessary. */
4378 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4379 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4381 stride = gfc_index_one_node;
4383 if (gfc_option.warn_array_temp)
4384 gfc_warning ("Creating array temporary at %L", &loc);
4387 /* This is for the case where the array data is used directly without
4388 calling the repack function. */
4389 if (no_repack || partial != NULL_TREE)
4390 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4392 stmt_packed = NULL_TREE;
4394 /* Assign the data pointer. */
4395 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4397 /* Don't repack unknown shape arrays when the first stride is 1. */
4398 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4399 partial, stmt_packed, stmt_unpacked);
4402 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4403 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4405 offset = gfc_index_zero_node;
4406 size = gfc_index_one_node;
4408 /* Evaluate the bounds of the array. */
4409 for (n = 0; n < sym->as->rank; n++)
4411 if (checkparm || !sym->as->upper[n])
4413 /* Get the bounds of the actual parameter. */
4414 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4415 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4419 dubound = NULL_TREE;
4420 dlbound = NULL_TREE;
4423 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4424 if (!INTEGER_CST_P (lbound))
4426 gfc_init_se (&se, NULL);
4427 gfc_conv_expr_type (&se, sym->as->lower[n],
4428 gfc_array_index_type);
4429 gfc_add_block_to_block (&block, &se.pre);
4430 gfc_add_modify (&block, lbound, se.expr);
4433 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4434 /* Set the desired upper bound. */
4435 if (sym->as->upper[n])
4437 /* We know what we want the upper bound to be. */
4438 if (!INTEGER_CST_P (ubound))
4440 gfc_init_se (&se, NULL);
4441 gfc_conv_expr_type (&se, sym->as->upper[n],
4442 gfc_array_index_type);
4443 gfc_add_block_to_block (&block, &se.pre);
4444 gfc_add_modify (&block, ubound, se.expr);
4447 /* Check the sizes match. */
4450 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4453 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4455 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4457 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4458 asprintf (&msg, "%s for dimension %d of array '%s'",
4459 gfc_msg_bounds, n+1, sym->name);
4460 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4466 /* For assumed shape arrays move the upper bound by the same amount
4467 as the lower bound. */
4468 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4470 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4471 gfc_add_modify (&block, ubound, tmp);
4473 /* The offset of this dimension. offset = offset - lbound * stride. */
4474 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4475 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4477 /* The size of this dimension, and the stride of the next. */
4478 if (n + 1 < sym->as->rank)
4480 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4482 if (no_repack || partial != NULL_TREE)
4485 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4488 /* Figure out the stride if not a known constant. */
4489 if (!INTEGER_CST_P (stride))
4492 stmt_packed = NULL_TREE;
4495 /* Calculate stride = size * (ubound + 1 - lbound). */
4496 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4497 gfc_index_one_node, lbound);
4498 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4500 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4505 /* Assign the stride. */
4506 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4507 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4508 stmt_unpacked, stmt_packed);
4510 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4511 gfc_add_modify (&block, stride, tmp);
4516 stride = GFC_TYPE_ARRAY_SIZE (type);
4518 if (stride && !INTEGER_CST_P (stride))
4520 /* Calculate size = stride * (ubound + 1 - lbound). */
4521 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4522 gfc_index_one_node, lbound);
4523 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4525 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4526 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4527 gfc_add_modify (&block, stride, tmp);
4532 /* Set the offset. */
4533 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4534 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4536 gfc_trans_vla_type_sizes (sym, &block);
4538 stmt = gfc_finish_block (&block);
4540 gfc_start_block (&block);
4542 /* Only do the entry/initialization code if the arg is present. */
4543 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4544 optional_arg = (sym->attr.optional
4545 || (sym->ns->proc_name->attr.entry_master
4546 && sym->attr.dummy));
4549 tmp = gfc_conv_expr_present (sym);
4550 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4552 gfc_add_expr_to_block (&block, stmt);
4554 /* Add the main function body. */
4555 gfc_add_expr_to_block (&block, body);
4560 gfc_start_block (&cleanup);
4562 if (sym->attr.intent != INTENT_IN)
4564 /* Copy the data back. */
4565 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4566 gfc_add_expr_to_block (&cleanup, tmp);
4569 /* Free the temporary. */
4570 tmp = gfc_call_free (tmpdesc);
4571 gfc_add_expr_to_block (&cleanup, tmp);
4573 stmt = gfc_finish_block (&cleanup);
4575 /* Only do the cleanup if the array was repacked. */
4576 tmp = build_fold_indirect_ref (dumdesc);
4577 tmp = gfc_conv_descriptor_data_get (tmp);
4578 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4579 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4583 tmp = gfc_conv_expr_present (sym);
4584 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4586 gfc_add_expr_to_block (&block, stmt);
4588 /* We don't need to free any memory allocated by internal_pack as it will
4589 be freed at the end of the function by pop_context. */
4590 return gfc_finish_block (&block);
4594 /* Calculate the overall offset, including subreferences. */
4596 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4597 bool subref, gfc_expr *expr)
4607 /* If offset is NULL and this is not a subreferenced array, there is
4609 if (offset == NULL_TREE)
4612 offset = gfc_index_zero_node;
4617 tmp = gfc_conv_array_data (desc);
4618 tmp = build_fold_indirect_ref (tmp);
4619 tmp = gfc_build_array_ref (tmp, offset, NULL);
4621 /* Offset the data pointer for pointer assignments from arrays with
4622 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4625 /* Go past the array reference. */
4626 for (ref = expr->ref; ref; ref = ref->next)
4627 if (ref->type == REF_ARRAY &&
4628 ref->u.ar.type != AR_ELEMENT)
4634 /* Calculate the offset for each subsequent subreference. */
4635 for (; ref; ref = ref->next)
4640 field = ref->u.c.component->backend_decl;
4641 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4642 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4643 tmp, field, NULL_TREE);
4647 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4648 gfc_init_se (&start, NULL);
4649 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4650 gfc_add_block_to_block (block, &start.pre);
4651 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4655 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4656 && ref->u.ar.type == AR_ELEMENT);
4658 /* TODO - Add bounds checking. */
4659 stride = gfc_index_one_node;
4660 index = gfc_index_zero_node;
4661 for (n = 0; n < ref->u.ar.dimen; n++)
4666 /* Update the index. */
4667 gfc_init_se (&start, NULL);
4668 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4669 itmp = gfc_evaluate_now (start.expr, block);
4670 gfc_init_se (&start, NULL);
4671 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4672 jtmp = gfc_evaluate_now (start.expr, block);
4673 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4674 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4675 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4676 index = gfc_evaluate_now (index, block);
4678 /* Update the stride. */
4679 gfc_init_se (&start, NULL);
4680 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4681 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4682 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4683 gfc_index_one_node, itmp);
4684 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4685 stride = gfc_evaluate_now (stride, block);
4688 /* Apply the index to obtain the array element. */
4689 tmp = gfc_build_array_ref (tmp, index, NULL);
4699 /* Set the target data pointer. */
4700 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4701 gfc_conv_descriptor_data_set (block, parm, offset);
4705 /* gfc_conv_expr_descriptor needs the character length of elemental
4706 functions before the function is called so that the size of the
4707 temporary can be obtained. The only way to do this is to convert
4708 the expression, mapping onto the actual arguments. */
4710 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4712 gfc_interface_mapping mapping;
4713 gfc_formal_arglist *formal;
4714 gfc_actual_arglist *arg;
4717 formal = expr->symtree->n.sym->formal;
4718 arg = expr->value.function.actual;
4719 gfc_init_interface_mapping (&mapping);
4721 /* Set se = NULL in the calls to the interface mapping, to suppress any
4723 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4728 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4731 gfc_init_se (&tse, NULL);
4733 /* Build the expression for the character length and convert it. */
4734 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4736 gfc_add_block_to_block (&se->pre, &tse.pre);
4737 gfc_add_block_to_block (&se->post, &tse.post);
4738 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4739 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4740 build_int_cst (gfc_charlen_type_node, 0));
4741 expr->ts.cl->backend_decl = tse.expr;
4742 gfc_free_interface_mapping (&mapping);
4746 /* Convert an array for passing as an actual argument. Expressions and
4747 vector subscripts are evaluated and stored in a temporary, which is then
4748 passed. For whole arrays the descriptor is passed. For array sections
4749 a modified copy of the descriptor is passed, but using the original data.
4751 This function is also used for array pointer assignments, and there
4754 - se->want_pointer && !se->direct_byref
4755 EXPR is an actual argument. On exit, se->expr contains a
4756 pointer to the array descriptor.
4758 - !se->want_pointer && !se->direct_byref
4759 EXPR is an actual argument to an intrinsic function or the
4760 left-hand side of a pointer assignment. On exit, se->expr
4761 contains the descriptor for EXPR.
4763 - !se->want_pointer && se->direct_byref
4764 EXPR is the right-hand side of a pointer assignment and
4765 se->expr is the descriptor for the previously-evaluated
4766 left-hand side. The function creates an assignment from
4767 EXPR to se->expr. */
4770 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4783 bool subref_array_target = false;
4785 gcc_assert (ss != gfc_ss_terminator);
4787 /* Special case things we know we can pass easily. */
4788 switch (expr->expr_type)
4791 /* If we have a linear array section, we can pass it directly.
4792 Otherwise we need to copy it into a temporary. */
4794 /* Find the SS for the array section. */
4796 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4797 secss = secss->next;
4799 gcc_assert (secss != gfc_ss_terminator);
4800 info = &secss->data.info;
4802 /* Get the descriptor for the array. */
4803 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4804 desc = info->descriptor;
4806 subref_array_target = se->direct_byref && is_subref_array (expr);
4807 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4808 && !subref_array_target;
4812 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4814 /* Create a new descriptor if the array doesn't have one. */
4817 else if (info->ref->u.ar.type == AR_FULL)
4819 else if (se->direct_byref)
4822 full = gfc_full_array_ref_p (info->ref);
4826 if (se->direct_byref)
4828 /* Copy the descriptor for pointer assignments. */
4829 gfc_add_modify (&se->pre, se->expr, desc);
4831 /* Add any offsets from subreferences. */
4832 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4833 subref_array_target, expr);
4835 else if (se->want_pointer)
4837 /* We pass full arrays directly. This means that pointers and
4838 allocatable arrays should also work. */
4839 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
4846 if (expr->ts.type == BT_CHARACTER)
4847 se->string_length = gfc_get_expr_charlen (expr);
4854 /* A transformational function return value will be a temporary
4855 array descriptor. We still need to go through the scalarizer
4856 to create the descriptor. Elemental functions ar handled as
4857 arbitrary expressions, i.e. copy to a temporary. */
4859 /* Look for the SS for this function. */
4860 while (secss != gfc_ss_terminator
4861 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4862 secss = secss->next;
4864 if (se->direct_byref)
4866 gcc_assert (secss != gfc_ss_terminator);
4868 /* For pointer assignments pass the descriptor directly. */
4870 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4871 gfc_conv_expr (se, expr);
4875 if (secss == gfc_ss_terminator)
4877 /* Elemental function. */
4879 if (expr->ts.type == BT_CHARACTER
4880 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4881 get_elemental_fcn_charlen (expr, se);
4887 /* Transformational function. */
4888 info = &secss->data.info;
4894 /* Constant array constructors don't need a temporary. */
4895 if (ss->type == GFC_SS_CONSTRUCTOR
4896 && expr->ts.type != BT_CHARACTER
4897 && gfc_constant_array_constructor_p (expr->value.constructor))
4900 info = &ss->data.info;
4912 /* Something complicated. Copy it into a temporary. */
4919 gfc_init_loopinfo (&loop);
4921 /* Associate the SS with the loop. */
4922 gfc_add_ss_to_loop (&loop, ss);
4924 /* Tell the scalarizer not to bother creating loop variables, etc. */
4926 loop.array_parameter = 1;
4928 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4929 gcc_assert (!se->direct_byref);
4931 /* Setup the scalarizing loops and bounds. */
4932 gfc_conv_ss_startstride (&loop);
4936 /* Tell the scalarizer to make a temporary. */
4937 loop.temp_ss = gfc_get_ss ();
4938 loop.temp_ss->type = GFC_SS_TEMP;
4939 loop.temp_ss->next = gfc_ss_terminator;
4941 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4942 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4944 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4946 if (expr->ts.type == BT_CHARACTER)
4947 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4949 loop.temp_ss->string_length = NULL;
4951 se->string_length = loop.temp_ss->string_length;
4952 loop.temp_ss->data.temp.dimen = loop.dimen;
4953 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4956 gfc_conv_loop_setup (&loop, & expr->where);
4960 /* Copy into a temporary and pass that. We don't need to copy the data
4961 back because expressions and vector subscripts must be INTENT_IN. */
4962 /* TODO: Optimize passing function return values. */
4966 /* Start the copying loops. */
4967 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4968 gfc_mark_ss_chain_used (ss, 1);
4969 gfc_start_scalarized_body (&loop, &block);
4971 /* Copy each data element. */
4972 gfc_init_se (&lse, NULL);
4973 gfc_copy_loopinfo_to_se (&lse, &loop);
4974 gfc_init_se (&rse, NULL);
4975 gfc_copy_loopinfo_to_se (&rse, &loop);
4977 lse.ss = loop.temp_ss;
4980 gfc_conv_scalarized_array_ref (&lse, NULL);
4981 if (expr->ts.type == BT_CHARACTER)
4983 gfc_conv_expr (&rse, expr);
4984 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4985 rse.expr = build_fold_indirect_ref (rse.expr);
4988 gfc_conv_expr_val (&rse, expr);
4990 gfc_add_block_to_block (&block, &rse.pre);
4991 gfc_add_block_to_block (&block, &lse.pre);
4993 lse.string_length = rse.string_length;
4994 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4995 expr->expr_type == EXPR_VARIABLE);
4996 gfc_add_expr_to_block (&block, tmp);
4998 /* Finish the copying loops. */
4999 gfc_trans_scalarizing_loops (&loop, &block);
5001 desc = loop.temp_ss->data.info.descriptor;
5003 gcc_assert (is_gimple_lvalue (desc));
5005 else if (expr->expr_type == EXPR_FUNCTION)
5007 desc = info->descriptor;
5008 se->string_length = ss->string_length;
5012 /* We pass sections without copying to a temporary. Make a new
5013 descriptor and point it at the section we want. The loop variable
5014 limits will be the limits of the section.
5015 A function may decide to repack the array to speed up access, but
5016 we're not bothered about that here. */
5025 /* Set the string_length for a character array. */
5026 if (expr->ts.type == BT_CHARACTER)
5027 se->string_length = gfc_get_expr_charlen (expr);
5029 desc = info->descriptor;
5030 gcc_assert (secss && secss != gfc_ss_terminator);
5031 if (se->direct_byref)
5033 /* For pointer assignments we fill in the destination. */
5035 parmtype = TREE_TYPE (parm);
5039 /* Otherwise make a new one. */
5040 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5041 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5042 loop.from, loop.to, 0,
5044 parm = gfc_create_var (parmtype, "parm");
5047 offset = gfc_index_zero_node;
5050 /* The following can be somewhat confusing. We have two
5051 descriptors, a new one and the original array.
5052 {parm, parmtype, dim} refer to the new one.
5053 {desc, type, n, secss, loop} refer to the original, which maybe
5054 a descriptorless array.
5055 The bounds of the scalarization are the bounds of the section.
5056 We don't have to worry about numeric overflows when calculating
5057 the offsets because all elements are within the array data. */
5059 /* Set the dtype. */
5060 tmp = gfc_conv_descriptor_dtype (parm);
5061 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5063 /* Set offset for assignments to pointer only to zero if it is not
5065 if (se->direct_byref
5066 && info->ref && info->ref->u.ar.type != AR_FULL)
5067 base = gfc_index_zero_node;
5068 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5069 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5073 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5074 for (n = 0; n < ndim; n++)
5076 stride = gfc_conv_array_stride (desc, n);
5078 /* Work out the offset. */
5080 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5082 gcc_assert (info->subscript[n]
5083 && info->subscript[n]->type == GFC_SS_SCALAR);
5084 start = info->subscript[n]->data.scalar.expr;
5088 /* Check we haven't somehow got out of sync. */
5089 gcc_assert (info->dim[dim] == n);
5091 /* Evaluate and remember the start of the section. */
5092 start = info->start[dim];
5093 stride = gfc_evaluate_now (stride, &loop.pre);
5096 tmp = gfc_conv_array_lbound (desc, n);
5097 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5099 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5100 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5103 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5105 /* For elemental dimensions, we only need the offset. */
5109 /* Vector subscripts need copying and are handled elsewhere. */
5111 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5113 /* Set the new lower bound. */
5114 from = loop.from[dim];
5117 /* If we have an array section or are assigning make sure that
5118 the lower bound is 1. References to the full
5119 array should otherwise keep the original bounds. */
5121 || info->ref->u.ar.type != AR_FULL)
5122 && !integer_onep (from))
5124 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5125 gfc_index_one_node, from);
5126 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5127 from = gfc_index_one_node;
5129 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5130 gfc_add_modify (&loop.pre, tmp, from);
5132 /* Set the new upper bound. */
5133 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5134 gfc_add_modify (&loop.pre, tmp, to);
5136 /* Multiply the stride by the section stride to get the
5138 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5139 stride, info->stride[dim]);
5141 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5143 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5146 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5148 tmp = gfc_conv_array_lbound (desc, n);
5149 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5150 tmp, loop.from[dim]);
5151 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5152 tmp, gfc_conv_array_stride (desc, n));
5153 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5157 /* Store the new stride. */
5158 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5159 gfc_add_modify (&loop.pre, tmp, stride);
5164 if (se->data_not_needed)
5165 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5167 /* Point the data pointer at the first element in the section. */
5168 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5169 subref_array_target, expr);
5171 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5172 && !se->data_not_needed)
5174 /* Set the offset. */
5175 tmp = gfc_conv_descriptor_offset (parm);
5176 gfc_add_modify (&loop.pre, tmp, base);
5180 /* Only the callee knows what the correct offset it, so just set
5182 tmp = gfc_conv_descriptor_offset (parm);
5183 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5188 if (!se->direct_byref)
5190 /* Get a pointer to the new descriptor. */
5191 if (se->want_pointer)
5192 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5197 gfc_add_block_to_block (&se->pre, &loop.pre);
5198 gfc_add_block_to_block (&se->post, &loop.post);
5200 /* Cleanup the scalarizer. */
5201 gfc_cleanup_loop (&loop);
5205 /* Convert an array for passing as an actual parameter. */
5206 /* TODO: Optimize passing g77 arrays. */
5209 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5210 const gfc_symbol *fsym, const char *proc_name)
5214 tree tmp = NULL_TREE;
5216 tree parent = DECL_CONTEXT (current_function_decl);
5217 bool full_array_var, this_array_result;
5221 full_array_var = (expr->expr_type == EXPR_VARIABLE
5222 && expr->ref->type == REF_ARRAY
5223 && expr->ref->u.ar.type == AR_FULL);
5224 sym = full_array_var ? expr->symtree->n.sym : NULL;
5226 /* The symbol should have an array specification. */
5227 gcc_assert (!sym || sym->as);
5229 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5231 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5232 expr->ts.cl->backend_decl = tmp;
5233 se->string_length = tmp;
5236 /* Is this the result of the enclosing procedure? */
5237 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5238 if (this_array_result
5239 && (sym->backend_decl != current_function_decl)
5240 && (sym->backend_decl != parent))
5241 this_array_result = false;
5243 /* Passing address of the array if it is not pointer or assumed-shape. */
5244 if (full_array_var && g77 && !this_array_result)
5246 tmp = gfc_get_symbol_decl (sym);
5248 if (sym->ts.type == BT_CHARACTER)
5249 se->string_length = sym->ts.cl->backend_decl;
5250 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5251 && !sym->attr.allocatable)
5253 /* Some variables are declared directly, others are declared as
5254 pointers and allocated on the heap. */
5255 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5258 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5261 if (sym->attr.allocatable)
5263 if (sym->attr.dummy || sym->attr.result)
5265 gfc_conv_expr_descriptor (se, expr, ss);
5266 se->expr = gfc_conv_array_data (se->expr);
5269 se->expr = gfc_conv_array_data (tmp);
5274 if (this_array_result)
5276 /* Result of the enclosing function. */
5277 gfc_conv_expr_descriptor (se, expr, ss);
5278 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5280 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5281 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5282 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5288 /* Every other type of array. */
5289 se->want_pointer = 1;
5290 gfc_conv_expr_descriptor (se, expr, ss);
5293 /* Deallocate the allocatable components of structures that are
5295 if (expr->ts.type == BT_DERIVED
5296 && expr->ts.derived->attr.alloc_comp
5297 && expr->expr_type != EXPR_VARIABLE)
5299 tmp = build_fold_indirect_ref (se->expr);
5300 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5301 gfc_add_expr_to_block (&se->post, tmp);
5307 /* Repack the array. */
5309 if (gfc_option.warn_array_temp)
5312 gfc_warning ("Creating array temporary at %L for argument '%s'",
5313 &expr->where, fsym->name);
5315 gfc_warning ("Creating array temporary at %L", &expr->where);
5318 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5320 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5322 tmp = gfc_conv_expr_present (sym);
5323 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5324 fold_convert (TREE_TYPE (se->expr), ptr),
5325 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5328 ptr = gfc_evaluate_now (ptr, &se->pre);
5332 if (gfc_option.flag_check_array_temporaries)
5336 if (fsym && proc_name)
5337 asprintf (&msg, "An array temporary was created for argument "
5338 "'%s' of procedure '%s'", fsym->name, proc_name);
5340 asprintf (&msg, "An array temporary was created");
5342 tmp = build_fold_indirect_ref (desc);
5343 tmp = gfc_conv_array_data (tmp);
5344 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5345 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5347 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5348 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5349 gfc_conv_expr_present (sym), tmp);
5351 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5356 gfc_start_block (&block);
5358 /* Copy the data back. */
5359 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5361 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5362 gfc_add_expr_to_block (&block, tmp);
5365 /* Free the temporary. */
5366 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5367 gfc_add_expr_to_block (&block, tmp);
5369 stmt = gfc_finish_block (&block);
5371 gfc_init_block (&block);
5372 /* Only if it was repacked. This code needs to be executed before the
5373 loop cleanup code. */
5374 tmp = build_fold_indirect_ref (desc);
5375 tmp = gfc_conv_array_data (tmp);
5376 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5377 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5379 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5380 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5381 gfc_conv_expr_present (sym), tmp);
5383 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5385 gfc_add_expr_to_block (&block, tmp);
5386 gfc_add_block_to_block (&block, &se->post);
5388 gfc_init_block (&se->post);
5389 gfc_add_block_to_block (&se->post, &block);
5394 /* Generate code to deallocate an array, if it is allocated. */
5397 gfc_trans_dealloc_allocated (tree descriptor)
5403 gfc_start_block (&block);
5405 var = gfc_conv_descriptor_data_get (descriptor);
5408 /* Call array_deallocate with an int * present in the second argument.
5409 Although it is ignored here, it's presence ensures that arrays that
5410 are already deallocated are ignored. */
5411 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5412 gfc_add_expr_to_block (&block, tmp);
5414 /* Zero the data pointer. */
5415 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5416 var, build_int_cst (TREE_TYPE (var), 0));
5417 gfc_add_expr_to_block (&block, tmp);
5419 return gfc_finish_block (&block);
5423 /* This helper function calculates the size in words of a full array. */
5426 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5431 idx = gfc_rank_cst[rank - 1];
5432 nelems = gfc_conv_descriptor_ubound (decl, idx);
5433 tmp = gfc_conv_descriptor_lbound (decl, idx);
5434 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5435 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5436 tmp, gfc_index_one_node);
5437 tmp = gfc_evaluate_now (tmp, block);
5439 nelems = gfc_conv_descriptor_stride (decl, idx);
5440 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5441 return gfc_evaluate_now (tmp, block);
5445 /* Allocate dest to the same size as src, and copy src -> dest. */
5448 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5457 /* If the source is null, set the destination to null. */
5458 gfc_init_block (&block);
5459 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5460 null_data = gfc_finish_block (&block);
5462 gfc_init_block (&block);
5464 nelems = get_full_array_size (&block, src, rank);
5465 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5466 fold_convert (gfc_array_index_type,
5467 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5469 /* Allocate memory to the destination. */
5470 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5472 gfc_conv_descriptor_data_set (&block, dest, tmp);
5474 /* We know the temporary and the value will be the same length,
5475 so can use memcpy. */
5476 tmp = built_in_decls[BUILT_IN_MEMCPY];
5477 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5478 gfc_conv_descriptor_data_get (src), size);
5479 gfc_add_expr_to_block (&block, tmp);
5480 tmp = gfc_finish_block (&block);
5482 /* Null the destination if the source is null; otherwise do
5483 the allocate and copy. */
5484 null_cond = gfc_conv_descriptor_data_get (src);
5485 null_cond = convert (pvoid_type_node, null_cond);
5486 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5487 null_cond, null_pointer_node);
5488 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5492 /* Recursively traverse an object of derived type, generating code to
5493 deallocate, nullify or copy allocatable components. This is the work horse
5494 function for the functions named in this enum. */
5496 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5499 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5500 tree dest, int rank, int purpose)
5504 stmtblock_t fnblock;
5505 stmtblock_t loopbody;
5515 tree null_cond = NULL_TREE;
5517 gfc_init_block (&fnblock);
5519 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5520 decl = build_fold_indirect_ref (decl);
5522 /* If this an array of derived types with allocatable components
5523 build a loop and recursively call this function. */
5524 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5525 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5527 tmp = gfc_conv_array_data (decl);
5528 var = build_fold_indirect_ref (tmp);
5530 /* Get the number of elements - 1 and set the counter. */
5531 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5533 /* Use the descriptor for an allocatable array. Since this
5534 is a full array reference, we only need the descriptor
5535 information from dimension = rank. */
5536 tmp = get_full_array_size (&fnblock, decl, rank);
5537 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5538 tmp, gfc_index_one_node);
5540 null_cond = gfc_conv_descriptor_data_get (decl);
5541 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5542 build_int_cst (TREE_TYPE (null_cond), 0));
5546 /* Otherwise use the TYPE_DOMAIN information. */
5547 tmp = array_type_nelts (TREE_TYPE (decl));
5548 tmp = fold_convert (gfc_array_index_type, tmp);
5551 /* Remember that this is, in fact, the no. of elements - 1. */
5552 nelems = gfc_evaluate_now (tmp, &fnblock);
5553 index = gfc_create_var (gfc_array_index_type, "S");
5555 /* Build the body of the loop. */
5556 gfc_init_block (&loopbody);
5558 vref = gfc_build_array_ref (var, index, NULL);
5560 if (purpose == COPY_ALLOC_COMP)
5562 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5564 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5565 gfc_add_expr_to_block (&fnblock, tmp);
5567 tmp = build_fold_indirect_ref (gfc_conv_array_data (dest));
5568 dref = gfc_build_array_ref (tmp, index, NULL);
5569 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5572 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5574 gfc_add_expr_to_block (&loopbody, tmp);
5576 /* Build the loop and return. */
5577 gfc_init_loopinfo (&loop);
5579 loop.from[0] = gfc_index_zero_node;
5580 loop.loopvar[0] = index;
5581 loop.to[0] = nelems;
5582 gfc_trans_scalarizing_loops (&loop, &loopbody);
5583 gfc_add_block_to_block (&fnblock, &loop.pre);
5585 tmp = gfc_finish_block (&fnblock);
5586 if (null_cond != NULL_TREE)
5587 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5592 /* Otherwise, act on the components or recursively call self to
5593 act on a chain of components. */
5594 for (c = der_type->components; c; c = c->next)
5596 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5597 && c->ts.derived->attr.alloc_comp;
5598 cdecl = c->backend_decl;
5599 ctype = TREE_TYPE (cdecl);
5603 case DEALLOCATE_ALLOC_COMP:
5604 /* Do not deallocate the components of ultimate pointer
5606 if (cmp_has_alloc_comps && !c->attr.pointer)
5608 comp = fold_build3 (COMPONENT_REF, ctype,
5609 decl, cdecl, NULL_TREE);
5610 rank = c->as ? c->as->rank : 0;
5611 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5613 gfc_add_expr_to_block (&fnblock, tmp);
5616 if (c->attr.allocatable)
5618 comp = fold_build3 (COMPONENT_REF, ctype,
5619 decl, cdecl, NULL_TREE);
5620 tmp = gfc_trans_dealloc_allocated (comp);
5621 gfc_add_expr_to_block (&fnblock, tmp);
5625 case NULLIFY_ALLOC_COMP:
5626 if (c->attr.pointer)
5628 else if (c->attr.allocatable)
5630 comp = fold_build3 (COMPONENT_REF, ctype,
5631 decl, cdecl, NULL_TREE);
5632 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5634 else if (cmp_has_alloc_comps)
5636 comp = fold_build3 (COMPONENT_REF, ctype,
5637 decl, cdecl, NULL_TREE);
5638 rank = c->as ? c->as->rank : 0;
5639 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5641 gfc_add_expr_to_block (&fnblock, tmp);
5645 case COPY_ALLOC_COMP:
5646 if (c->attr.pointer)
5649 /* We need source and destination components. */
5650 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5651 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5652 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5654 if (c->attr.allocatable && !cmp_has_alloc_comps)
5656 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5657 gfc_add_expr_to_block (&fnblock, tmp);
5660 if (cmp_has_alloc_comps)
5662 rank = c->as ? c->as->rank : 0;
5663 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5664 gfc_add_modify (&fnblock, dcmp, tmp);
5665 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5667 gfc_add_expr_to_block (&fnblock, tmp);
5677 return gfc_finish_block (&fnblock);
5680 /* Recursively traverse an object of derived type, generating code to
5681 nullify allocatable components. */
5684 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5686 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5687 NULLIFY_ALLOC_COMP);
5691 /* Recursively traverse an object of derived type, generating code to
5692 deallocate allocatable components. */
5695 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5697 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5698 DEALLOCATE_ALLOC_COMP);
5702 /* Recursively traverse an object of derived type, generating code to
5703 copy its allocatable components. */
5706 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5708 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5712 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5713 Do likewise, recursively if necessary, with the allocatable components of
5717 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5722 stmtblock_t fnblock;
5725 bool sym_has_alloc_comp;
5727 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5728 && sym->ts.derived->attr.alloc_comp;
5730 /* Make sure the frontend gets these right. */
5731 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5732 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5733 "allocatable attribute or derived type without allocatable "
5736 gfc_init_block (&fnblock);
5738 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5739 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5741 if (sym->ts.type == BT_CHARACTER
5742 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5744 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5745 gfc_trans_vla_type_sizes (sym, &fnblock);
5748 /* Dummy and use associated variables don't need anything special. */
5749 if (sym->attr.dummy || sym->attr.use_assoc)
5751 gfc_add_expr_to_block (&fnblock, body);
5753 return gfc_finish_block (&fnblock);
5756 gfc_get_backend_locus (&loc);
5757 gfc_set_backend_locus (&sym->declared_at);
5758 descriptor = sym->backend_decl;
5760 /* Although static, derived types with default initializers and
5761 allocatable components must not be nulled wholesale; instead they
5762 are treated component by component. */
5763 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5765 /* SAVEd variables are not freed on exit. */
5766 gfc_trans_static_array_pointer (sym);
5770 /* Get the descriptor type. */
5771 type = TREE_TYPE (sym->backend_decl);
5773 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5775 if (!sym->attr.save)
5777 rank = sym->as ? sym->as->rank : 0;
5778 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5779 gfc_add_expr_to_block (&fnblock, tmp);
5782 tmp = gfc_init_default_dt (sym, NULL);
5783 gfc_add_expr_to_block (&fnblock, tmp);
5787 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5789 /* If the backend_decl is not a descriptor, we must have a pointer
5791 descriptor = build_fold_indirect_ref (sym->backend_decl);
5792 type = TREE_TYPE (descriptor);
5795 /* NULLIFY the data pointer. */
5796 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5797 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5799 gfc_add_expr_to_block (&fnblock, body);
5801 gfc_set_backend_locus (&loc);
5803 /* Allocatable arrays need to be freed when they go out of scope.
5804 The allocatable components of pointers must not be touched. */
5805 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5806 && !sym->attr.pointer && !sym->attr.save)
5809 rank = sym->as ? sym->as->rank : 0;
5810 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5811 gfc_add_expr_to_block (&fnblock, tmp);
5814 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5816 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5817 gfc_add_expr_to_block (&fnblock, tmp);
5820 return gfc_finish_block (&fnblock);
5823 /************ Expression Walking Functions ******************/
5825 /* Walk a variable reference.
5827 Possible extension - multiple component subscripts.
5828 x(:,:) = foo%a(:)%b(:)
5830 forall (i=..., j=...)
5831 x(i,j) = foo%a(j)%b(i)
5833 This adds a fair amount of complexity because you need to deal with more
5834 than one ref. Maybe handle in a similar manner to vector subscripts.
5835 Maybe not worth the effort. */
5839 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5847 for (ref = expr->ref; ref; ref = ref->next)
5848 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5851 for (; ref; ref = ref->next)
5853 if (ref->type == REF_SUBSTRING)
5855 newss = gfc_get_ss ();
5856 newss->type = GFC_SS_SCALAR;
5857 newss->expr = ref->u.ss.start;
5861 newss = gfc_get_ss ();
5862 newss->type = GFC_SS_SCALAR;
5863 newss->expr = ref->u.ss.end;
5868 /* We're only interested in array sections from now on. */
5869 if (ref->type != REF_ARRAY)
5876 for (n = 0; n < ar->dimen; n++)
5878 newss = gfc_get_ss ();
5879 newss->type = GFC_SS_SCALAR;
5880 newss->expr = ar->start[n];
5887 newss = gfc_get_ss ();
5888 newss->type = GFC_SS_SECTION;
5891 newss->data.info.dimen = ar->as->rank;
5892 newss->data.info.ref = ref;
5894 /* Make sure array is the same as array(:,:), this way
5895 we don't need to special case all the time. */
5896 ar->dimen = ar->as->rank;
5897 for (n = 0; n < ar->dimen; n++)
5899 newss->data.info.dim[n] = n;
5900 ar->dimen_type[n] = DIMEN_RANGE;
5902 gcc_assert (ar->start[n] == NULL);
5903 gcc_assert (ar->end[n] == NULL);
5904 gcc_assert (ar->stride[n] == NULL);
5910 newss = gfc_get_ss ();
5911 newss->type = GFC_SS_SECTION;
5914 newss->data.info.dimen = 0;
5915 newss->data.info.ref = ref;
5919 /* We add SS chains for all the subscripts in the section. */
5920 for (n = 0; n < ar->dimen; n++)
5924 switch (ar->dimen_type[n])
5927 /* Add SS for elemental (scalar) subscripts. */
5928 gcc_assert (ar->start[n]);
5929 indexss = gfc_get_ss ();
5930 indexss->type = GFC_SS_SCALAR;
5931 indexss->expr = ar->start[n];
5932 indexss->next = gfc_ss_terminator;
5933 indexss->loop_chain = gfc_ss_terminator;
5934 newss->data.info.subscript[n] = indexss;
5938 /* We don't add anything for sections, just remember this
5939 dimension for later. */
5940 newss->data.info.dim[newss->data.info.dimen] = n;
5941 newss->data.info.dimen++;
5945 /* Create a GFC_SS_VECTOR index in which we can store
5946 the vector's descriptor. */
5947 indexss = gfc_get_ss ();
5948 indexss->type = GFC_SS_VECTOR;
5949 indexss->expr = ar->start[n];
5950 indexss->next = gfc_ss_terminator;
5951 indexss->loop_chain = gfc_ss_terminator;
5952 newss->data.info.subscript[n] = indexss;
5953 newss->data.info.dim[newss->data.info.dimen] = n;
5954 newss->data.info.dimen++;
5958 /* We should know what sort of section it is by now. */
5962 /* We should have at least one non-elemental dimension. */
5963 gcc_assert (newss->data.info.dimen > 0);
5968 /* We should know what sort of section it is by now. */
5977 /* Walk an expression operator. If only one operand of a binary expression is
5978 scalar, we must also add the scalar term to the SS chain. */
5981 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5987 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5988 if (expr->value.op.op2 == NULL)
5991 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5993 /* All operands are scalar. Pass back and let the caller deal with it. */
5997 /* All operands require scalarization. */
5998 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6001 /* One of the operands needs scalarization, the other is scalar.
6002 Create a gfc_ss for the scalar expression. */
6003 newss = gfc_get_ss ();
6004 newss->type = GFC_SS_SCALAR;
6007 /* First operand is scalar. We build the chain in reverse order, so
6008 add the scalar SS after the second operand. */
6010 while (head && head->next != ss)
6012 /* Check we haven't somehow broken the chain. */
6016 newss->expr = expr->value.op.op1;
6018 else /* head2 == head */
6020 gcc_assert (head2 == head);
6021 /* Second operand is scalar. */
6022 newss->next = head2;
6024 newss->expr = expr->value.op.op2;
6031 /* Reverse a SS chain. */
6034 gfc_reverse_ss (gfc_ss * ss)
6039 gcc_assert (ss != NULL);
6041 head = gfc_ss_terminator;
6042 while (ss != gfc_ss_terminator)
6045 /* Check we didn't somehow break the chain. */
6046 gcc_assert (next != NULL);
6056 /* Walk the arguments of an elemental function. */
6059 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6067 head = gfc_ss_terminator;
6070 for (; arg; arg = arg->next)
6075 newss = gfc_walk_subexpr (head, arg->expr);
6078 /* Scalar argument. */
6079 newss = gfc_get_ss ();
6081 newss->expr = arg->expr;
6091 while (tail->next != gfc_ss_terminator)
6098 /* If all the arguments are scalar we don't need the argument SS. */
6099 gfc_free_ss_chain (head);
6104 /* Add it onto the existing chain. */
6110 /* Walk a function call. Scalar functions are passed back, and taken out of
6111 scalarization loops. For elemental functions we walk their arguments.
6112 The result of functions returning arrays is stored in a temporary outside
6113 the loop, so that the function is only called once. Hence we do not need
6114 to walk their arguments. */
6117 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6120 gfc_intrinsic_sym *isym;
6123 isym = expr->value.function.isym;
6125 /* Handle intrinsic functions separately. */
6127 return gfc_walk_intrinsic_function (ss, expr, isym);
6129 sym = expr->value.function.esym;
6131 sym = expr->symtree->n.sym;
6133 /* A function that returns arrays. */
6134 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6136 newss = gfc_get_ss ();
6137 newss->type = GFC_SS_FUNCTION;
6140 newss->data.info.dimen = expr->rank;
6144 /* Walk the parameters of an elemental function. For now we always pass
6146 if (sym->attr.elemental)
6147 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6150 /* Scalar functions are OK as these are evaluated outside the scalarization
6151 loop. Pass back and let the caller deal with it. */
6156 /* An array temporary is constructed for array constructors. */
6159 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6164 newss = gfc_get_ss ();
6165 newss->type = GFC_SS_CONSTRUCTOR;
6168 newss->data.info.dimen = expr->rank;
6169 for (n = 0; n < expr->rank; n++)
6170 newss->data.info.dim[n] = n;
6176 /* Walk an expression. Add walked expressions to the head of the SS chain.
6177 A wholly scalar expression will not be added. */
6180 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6184 switch (expr->expr_type)
6187 head = gfc_walk_variable_expr (ss, expr);
6191 head = gfc_walk_op_expr (ss, expr);
6195 head = gfc_walk_function_expr (ss, expr);
6200 case EXPR_STRUCTURE:
6201 /* Pass back and let the caller deal with it. */
6205 head = gfc_walk_array_constructor (ss, expr);
6208 case EXPR_SUBSTRING:
6209 /* Pass back and let the caller deal with it. */
6213 internal_error ("bad expression type during walk (%d)",
6220 /* Entry point for expression walking.
6221 A return value equal to the passed chain means this is
6222 a scalar expression. It is up to the caller to take whatever action is
6223 necessary to translate these. */
6226 gfc_walk_expr (gfc_expr * expr)
6230 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6231 return gfc_reverse_ss (res);