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 build_fold_addr_expr (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 = build_fold_addr_expr (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 if (n < loop->temp_dim)
648 gcc_assert (integer_zerop (loop->from[n]));
651 /* Callee allocated arrays may not have a known bound yet. */
653 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
654 loop->to[n], loop->from[n]);
655 loop->from[n] = gfc_index_zero_node;
658 info->delta[dim] = gfc_index_zero_node;
659 info->start[dim] = gfc_index_zero_node;
660 info->end[dim] = gfc_index_zero_node;
661 info->stride[dim] = gfc_index_one_node;
662 info->dim[dim] = dim;
665 /* Initialize the descriptor. */
667 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
669 desc = gfc_create_var (type, "atmp");
670 GFC_DECL_PACKED_ARRAY (desc) = 1;
672 info->descriptor = desc;
673 size = gfc_index_one_node;
675 /* Fill in the array dtype. */
676 tmp = gfc_conv_descriptor_dtype (desc);
677 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
680 Fill in the bounds and stride. This is a packed array, so:
683 for (n = 0; n < rank; n++)
686 delta = ubound[n] + 1 - lbound[n];
689 size = size * sizeof(element);
694 /* If there is at least one null loop->to[n], it is a callee allocated
696 for (n = 0; n < info->dimen; n++)
697 if (loop->to[n] == NULL_TREE)
703 for (n = 0; n < info->dimen; n++)
705 if (size == NULL_TREE)
707 /* For a callee allocated array express the loop bounds in terms
708 of the descriptor fields. */
710 fold_build2 (MINUS_EXPR, gfc_array_index_type,
711 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
712 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
717 /* Store the stride and bound components in the descriptor. */
718 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
719 gfc_add_modify (pre, tmp, size);
721 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
722 gfc_add_modify (pre, tmp, gfc_index_zero_node);
724 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
725 gfc_add_modify (pre, tmp, loop->to[n]);
727 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
728 loop->to[n], gfc_index_one_node);
730 /* Check whether the size for this dimension is negative. */
731 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
732 gfc_index_zero_node);
733 cond = gfc_evaluate_now (cond, pre);
738 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
740 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
741 size = gfc_evaluate_now (size, pre);
744 /* Get the size of the array. */
746 if (size && !callee_alloc)
748 /* If or_expr is true, then the extent in at least one
749 dimension is zero and the size is set to zero. */
750 size = fold_build3 (COND_EXPR, gfc_array_index_type,
751 or_expr, gfc_index_zero_node, size);
754 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
755 fold_convert (gfc_array_index_type,
756 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
764 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
767 if (info->dimen > loop->temp_dim)
768 loop->temp_dim = info->dimen;
774 /* Generate code to transpose array EXPR by creating a new descriptor
775 in which the dimension specifications have been reversed. */
778 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
780 tree dest, src, dest_index, src_index;
782 gfc_ss_info *dest_info, *src_info;
783 gfc_ss *dest_ss, *src_ss;
789 src_ss = gfc_walk_expr (expr);
792 src_info = &src_ss->data.info;
793 dest_info = &dest_ss->data.info;
794 gcc_assert (dest_info->dimen == 2);
795 gcc_assert (src_info->dimen == 2);
797 /* Get a descriptor for EXPR. */
798 gfc_init_se (&src_se, NULL);
799 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
800 gfc_add_block_to_block (&se->pre, &src_se.pre);
801 gfc_add_block_to_block (&se->post, &src_se.post);
804 /* Allocate a new descriptor for the return value. */
805 dest = gfc_create_var (TREE_TYPE (src), "atmp");
806 dest_info->descriptor = dest;
809 /* Copy across the dtype field. */
810 gfc_add_modify (&se->pre,
811 gfc_conv_descriptor_dtype (dest),
812 gfc_conv_descriptor_dtype (src));
814 /* Copy the dimension information, renumbering dimension 1 to 0 and
816 for (n = 0; n < 2; n++)
818 dest_info->delta[n] = gfc_index_zero_node;
819 dest_info->start[n] = gfc_index_zero_node;
820 dest_info->end[n] = gfc_index_zero_node;
821 dest_info->stride[n] = gfc_index_one_node;
822 dest_info->dim[n] = n;
824 dest_index = gfc_rank_cst[n];
825 src_index = gfc_rank_cst[1 - n];
827 gfc_add_modify (&se->pre,
828 gfc_conv_descriptor_stride (dest, dest_index),
829 gfc_conv_descriptor_stride (src, src_index));
831 gfc_add_modify (&se->pre,
832 gfc_conv_descriptor_lbound (dest, dest_index),
833 gfc_conv_descriptor_lbound (src, src_index));
835 gfc_add_modify (&se->pre,
836 gfc_conv_descriptor_ubound (dest, dest_index),
837 gfc_conv_descriptor_ubound (src, src_index));
841 gcc_assert (integer_zerop (loop->from[n]));
843 fold_build2 (MINUS_EXPR, gfc_array_index_type,
844 gfc_conv_descriptor_ubound (dest, dest_index),
845 gfc_conv_descriptor_lbound (dest, dest_index));
849 /* Copy the data pointer. */
850 dest_info->data = gfc_conv_descriptor_data_get (src);
851 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
853 /* Copy the offset. This is not changed by transposition; the top-left
854 element is still at the same offset as before, except where the loop
856 if (!integer_zerop (loop->from[0]))
857 dest_info->offset = gfc_conv_descriptor_offset (src);
859 dest_info->offset = gfc_index_zero_node;
861 gfc_add_modify (&se->pre,
862 gfc_conv_descriptor_offset (dest),
865 if (dest_info->dimen > loop->temp_dim)
866 loop->temp_dim = dest_info->dimen;
870 /* Return the number of iterations in a loop that starts at START,
871 ends at END, and has step STEP. */
874 gfc_get_iteration_count (tree start, tree end, tree step)
879 type = TREE_TYPE (step);
880 tmp = fold_build2 (MINUS_EXPR, type, end, start);
881 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
882 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
883 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
884 return fold_convert (gfc_array_index_type, tmp);
888 /* Extend the data in array DESC by EXTRA elements. */
891 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
898 if (integer_zerop (extra))
901 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
903 /* Add EXTRA to the upper bound. */
904 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
905 gfc_add_modify (pblock, ubound, tmp);
907 /* Get the value of the current data pointer. */
908 arg0 = gfc_conv_descriptor_data_get (desc);
910 /* Calculate the new array size. */
911 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
912 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
913 ubound, gfc_index_one_node);
914 arg1 = fold_build2 (MULT_EXPR, size_type_node,
915 fold_convert (size_type_node, tmp),
916 fold_convert (size_type_node, size));
918 /* Call the realloc() function. */
919 tmp = gfc_call_realloc (pblock, arg0, arg1);
920 gfc_conv_descriptor_data_set (pblock, desc, tmp);
924 /* Return true if the bounds of iterator I can only be determined
928 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
930 return (i->start->expr_type != EXPR_CONSTANT
931 || i->end->expr_type != EXPR_CONSTANT
932 || i->step->expr_type != EXPR_CONSTANT);
936 /* Split the size of constructor element EXPR into the sum of two terms,
937 one of which can be determined at compile time and one of which must
938 be calculated at run time. Set *SIZE to the former and return true
939 if the latter might be nonzero. */
942 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
944 if (expr->expr_type == EXPR_ARRAY)
945 return gfc_get_array_constructor_size (size, expr->value.constructor);
946 else if (expr->rank > 0)
948 /* Calculate everything at run time. */
949 mpz_set_ui (*size, 0);
954 /* A single element. */
955 mpz_set_ui (*size, 1);
961 /* Like gfc_get_array_constructor_element_size, but applied to the whole
962 of array constructor C. */
965 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
972 mpz_set_ui (*size, 0);
977 for (; c; c = c->next)
980 if (i && gfc_iterator_has_dynamic_bounds (i))
984 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
987 /* Multiply the static part of the element size by the
988 number of iterations. */
989 mpz_sub (val, i->end->value.integer, i->start->value.integer);
990 mpz_fdiv_q (val, val, i->step->value.integer);
991 mpz_add_ui (val, val, 1);
992 if (mpz_sgn (val) > 0)
993 mpz_mul (len, len, val);
997 mpz_add (*size, *size, len);
1006 /* Make sure offset is a variable. */
1009 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1012 /* We should have already created the offset variable. We cannot
1013 create it here because we may be in an inner scope. */
1014 gcc_assert (*offsetvar != NULL_TREE);
1015 gfc_add_modify (pblock, *offsetvar, *poffset);
1016 *poffset = *offsetvar;
1017 TREE_USED (*offsetvar) = 1;
1021 /* Variables needed for bounds-checking. */
1022 static bool first_len;
1023 static tree first_len_val;
1024 static bool typespec_chararray_ctor;
1027 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1028 tree offset, gfc_se * se, gfc_expr * expr)
1032 gfc_conv_expr (se, expr);
1034 /* Store the value. */
1035 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
1036 tmp = gfc_build_array_ref (tmp, offset, NULL);
1038 if (expr->ts.type == BT_CHARACTER)
1040 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1043 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1044 esize = fold_convert (gfc_charlen_type_node, esize);
1045 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1046 build_int_cst (gfc_charlen_type_node,
1047 gfc_character_kinds[i].bit_size / 8));
1049 gfc_conv_string_parameter (se);
1050 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1052 /* The temporary is an array of pointers. */
1053 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1054 gfc_add_modify (&se->pre, tmp, se->expr);
1058 /* The temporary is an array of string values. */
1059 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1060 /* We know the temporary and the value will be the same length,
1061 so can use memcpy. */
1062 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1063 se->string_length, se->expr, expr->ts.kind);
1065 if (flag_bounds_check && !typespec_chararray_ctor)
1069 gfc_add_modify (&se->pre, first_len_val,
1075 /* Verify that all constructor elements are of the same
1077 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1078 first_len_val, se->string_length);
1079 gfc_trans_runtime_check
1080 (true, false, cond, &se->pre, &expr->where,
1081 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1082 fold_convert (long_integer_type_node, first_len_val),
1083 fold_convert (long_integer_type_node, se->string_length));
1089 /* TODO: Should the frontend already have done this conversion? */
1090 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1091 gfc_add_modify (&se->pre, tmp, se->expr);
1094 gfc_add_block_to_block (pblock, &se->pre);
1095 gfc_add_block_to_block (pblock, &se->post);
1099 /* Add the contents of an array to the constructor. DYNAMIC is as for
1100 gfc_trans_array_constructor_value. */
1103 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1104 tree type ATTRIBUTE_UNUSED,
1105 tree desc, gfc_expr * expr,
1106 tree * poffset, tree * offsetvar,
1117 /* We need this to be a variable so we can increment it. */
1118 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1120 gfc_init_se (&se, NULL);
1122 /* Walk the array expression. */
1123 ss = gfc_walk_expr (expr);
1124 gcc_assert (ss != gfc_ss_terminator);
1126 /* Initialize the scalarizer. */
1127 gfc_init_loopinfo (&loop);
1128 gfc_add_ss_to_loop (&loop, ss);
1130 /* Initialize the loop. */
1131 gfc_conv_ss_startstride (&loop);
1132 gfc_conv_loop_setup (&loop, &expr->where);
1134 /* Make sure the constructed array has room for the new data. */
1137 /* Set SIZE to the total number of elements in the subarray. */
1138 size = gfc_index_one_node;
1139 for (n = 0; n < loop.dimen; n++)
1141 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1142 gfc_index_one_node);
1143 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1146 /* Grow the constructed array by SIZE elements. */
1147 gfc_grow_array (&loop.pre, desc, size);
1150 /* Make the loop body. */
1151 gfc_mark_ss_chain_used (ss, 1);
1152 gfc_start_scalarized_body (&loop, &body);
1153 gfc_copy_loopinfo_to_se (&se, &loop);
1156 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1157 gcc_assert (se.ss == gfc_ss_terminator);
1159 /* Increment the offset. */
1160 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1161 *poffset, gfc_index_one_node);
1162 gfc_add_modify (&body, *poffset, tmp);
1164 /* Finish the loop. */
1165 gfc_trans_scalarizing_loops (&loop, &body);
1166 gfc_add_block_to_block (&loop.pre, &loop.post);
1167 tmp = gfc_finish_block (&loop.pre);
1168 gfc_add_expr_to_block (pblock, tmp);
1170 gfc_cleanup_loop (&loop);
1174 /* Assign the values to the elements of an array constructor. DYNAMIC
1175 is true if descriptor DESC only contains enough data for the static
1176 size calculated by gfc_get_array_constructor_size. When true, memory
1177 for the dynamic parts must be allocated using realloc. */
1180 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1181 tree desc, gfc_constructor * c,
1182 tree * poffset, tree * offsetvar,
1191 for (; c; c = c->next)
1193 /* If this is an iterator or an array, the offset must be a variable. */
1194 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1195 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1197 gfc_start_block (&body);
1199 if (c->expr->expr_type == EXPR_ARRAY)
1201 /* Array constructors can be nested. */
1202 gfc_trans_array_constructor_value (&body, type, desc,
1203 c->expr->value.constructor,
1204 poffset, offsetvar, dynamic);
1206 else if (c->expr->rank > 0)
1208 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1209 poffset, offsetvar, dynamic);
1213 /* This code really upsets the gimplifier so don't bother for now. */
1220 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1227 /* Scalar values. */
1228 gfc_init_se (&se, NULL);
1229 gfc_trans_array_ctor_element (&body, desc, *poffset,
1232 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1233 *poffset, gfc_index_one_node);
1237 /* Collect multiple scalar constants into a constructor. */
1245 /* Count the number of consecutive scalar constants. */
1246 while (p && !(p->iterator
1247 || p->expr->expr_type != EXPR_CONSTANT))
1249 gfc_init_se (&se, NULL);
1250 gfc_conv_constant (&se, p->expr);
1252 /* For constant character array constructors we build
1253 an array of pointers. */
1254 if (p->expr->ts.type == BT_CHARACTER
1255 && POINTER_TYPE_P (type))
1256 se.expr = gfc_build_addr_expr
1257 (gfc_get_pchar_type (p->expr->ts.kind),
1260 list = tree_cons (NULL_TREE, se.expr, list);
1265 bound = build_int_cst (NULL_TREE, n - 1);
1266 /* Create an array type to hold them. */
1267 tmptype = build_range_type (gfc_array_index_type,
1268 gfc_index_zero_node, bound);
1269 tmptype = build_array_type (type, tmptype);
1271 init = build_constructor_from_list (tmptype, nreverse (list));
1272 TREE_CONSTANT (init) = 1;
1273 TREE_STATIC (init) = 1;
1274 /* Create a static variable to hold the data. */
1275 tmp = gfc_create_var (tmptype, "data");
1276 TREE_STATIC (tmp) = 1;
1277 TREE_CONSTANT (tmp) = 1;
1278 TREE_READONLY (tmp) = 1;
1279 DECL_INITIAL (tmp) = init;
1282 /* Use BUILTIN_MEMCPY to assign the values. */
1283 tmp = gfc_conv_descriptor_data_get (desc);
1284 tmp = build_fold_indirect_ref (tmp);
1285 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1286 tmp = build_fold_addr_expr (tmp);
1287 init = build_fold_addr_expr (init);
1289 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1290 bound = build_int_cst (NULL_TREE, n * size);
1291 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1293 gfc_add_expr_to_block (&body, tmp);
1295 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1297 build_int_cst (gfc_array_index_type, n));
1299 if (!INTEGER_CST_P (*poffset))
1301 gfc_add_modify (&body, *offsetvar, *poffset);
1302 *poffset = *offsetvar;
1306 /* The frontend should already have done any expansions
1310 /* Pass the code as is. */
1311 tmp = gfc_finish_block (&body);
1312 gfc_add_expr_to_block (pblock, tmp);
1316 /* Build the implied do-loop. */
1326 loopbody = gfc_finish_block (&body);
1328 if (c->iterator->var->symtree->n.sym->backend_decl)
1330 gfc_init_se (&se, NULL);
1331 gfc_conv_expr (&se, c->iterator->var);
1332 gfc_add_block_to_block (pblock, &se.pre);
1337 /* If the iterator appears in a specification expression in
1338 an interface mapping, we need to make a temp for the loop
1339 variable because it is not declared locally. */
1340 loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
1341 loopvar = gfc_create_var (loopvar, "loopvar");
1344 /* Make a temporary, store the current value in that
1345 and return it, once the loop is done. */
1346 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1347 gfc_add_modify (pblock, tmp_loopvar, loopvar);
1349 /* Initialize the loop. */
1350 gfc_init_se (&se, NULL);
1351 gfc_conv_expr_val (&se, c->iterator->start);
1352 gfc_add_block_to_block (pblock, &se.pre);
1353 gfc_add_modify (pblock, loopvar, se.expr);
1355 gfc_init_se (&se, NULL);
1356 gfc_conv_expr_val (&se, c->iterator->end);
1357 gfc_add_block_to_block (pblock, &se.pre);
1358 end = gfc_evaluate_now (se.expr, pblock);
1360 gfc_init_se (&se, NULL);
1361 gfc_conv_expr_val (&se, c->iterator->step);
1362 gfc_add_block_to_block (pblock, &se.pre);
1363 step = gfc_evaluate_now (se.expr, pblock);
1365 /* If this array expands dynamically, and the number of iterations
1366 is not constant, we won't have allocated space for the static
1367 part of C->EXPR's size. Do that now. */
1368 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1370 /* Get the number of iterations. */
1371 tmp = gfc_get_iteration_count (loopvar, end, step);
1373 /* Get the static part of C->EXPR's size. */
1374 gfc_get_array_constructor_element_size (&size, c->expr);
1375 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1377 /* Grow the array by TMP * TMP2 elements. */
1378 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1379 gfc_grow_array (pblock, desc, tmp);
1382 /* Generate the loop body. */
1383 exit_label = gfc_build_label_decl (NULL_TREE);
1384 gfc_start_block (&body);
1386 /* Generate the exit condition. Depending on the sign of
1387 the step variable we have to generate the correct
1389 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1390 build_int_cst (TREE_TYPE (step), 0));
1391 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1392 fold_build2 (GT_EXPR, boolean_type_node,
1394 fold_build2 (LT_EXPR, boolean_type_node,
1396 tmp = build1_v (GOTO_EXPR, exit_label);
1397 TREE_USED (exit_label) = 1;
1398 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1399 gfc_add_expr_to_block (&body, tmp);
1401 /* The main loop body. */
1402 gfc_add_expr_to_block (&body, loopbody);
1404 /* Increase loop variable by step. */
1405 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1406 gfc_add_modify (&body, loopvar, tmp);
1408 /* Finish the loop. */
1409 tmp = gfc_finish_block (&body);
1410 tmp = build1_v (LOOP_EXPR, tmp);
1411 gfc_add_expr_to_block (pblock, tmp);
1413 /* Add the exit label. */
1414 tmp = build1_v (LABEL_EXPR, exit_label);
1415 gfc_add_expr_to_block (pblock, tmp);
1417 /* Restore the original value of the loop counter. */
1418 gfc_add_modify (pblock, loopvar, tmp_loopvar);
1425 /* Figure out the string length of a variable reference expression.
1426 Used by get_array_ctor_strlen. */
1429 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1435 /* Don't bother if we already know the length is a constant. */
1436 if (*len && INTEGER_CST_P (*len))
1439 ts = &expr->symtree->n.sym->ts;
1440 for (ref = expr->ref; ref; ref = ref->next)
1445 /* Array references don't change the string length. */
1449 /* Use the length of the component. */
1450 ts = &ref->u.c.component->ts;
1454 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1455 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1457 mpz_init_set_ui (char_len, 1);
1458 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1459 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1460 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1461 *len = convert (gfc_charlen_type_node, *len);
1462 mpz_clear (char_len);
1466 /* TODO: Substrings are tricky because we can't evaluate the
1467 expression more than once. For now we just give up, and hope
1468 we can figure it out elsewhere. */
1473 *len = ts->cl->backend_decl;
1477 /* A catch-all to obtain the string length for anything that is not a
1478 constant, array or variable. */
1480 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1485 /* Don't bother if we already know the length is a constant. */
1486 if (*len && INTEGER_CST_P (*len))
1489 if (!e->ref && e->ts.cl && e->ts.cl->length
1490 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1493 gfc_conv_const_charlen (e->ts.cl);
1494 *len = e->ts.cl->backend_decl;
1498 /* Otherwise, be brutal even if inefficient. */
1499 ss = gfc_walk_expr (e);
1500 gfc_init_se (&se, NULL);
1502 /* No function call, in case of side effects. */
1503 se.no_function_call = 1;
1504 if (ss == gfc_ss_terminator)
1505 gfc_conv_expr (&se, e);
1507 gfc_conv_expr_descriptor (&se, e, ss);
1509 /* Fix the value. */
1510 *len = gfc_evaluate_now (se.string_length, &se.pre);
1512 gfc_add_block_to_block (block, &se.pre);
1513 gfc_add_block_to_block (block, &se.post);
1515 e->ts.cl->backend_decl = *len;
1520 /* Figure out the string length of a character array constructor.
1521 If len is NULL, don't calculate the length; this happens for recursive calls
1522 when a sub-array-constructor is an element but not at the first position,
1523 so when we're not interested in the length.
1524 Returns TRUE if all elements are character constants. */
1527 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1536 *len = build_int_cstu (gfc_charlen_type_node, 0);
1540 /* Loop over all constructor elements to find out is_const, but in len we
1541 want to store the length of the first, not the last, element. We can
1542 of course exit the loop as soon as is_const is found to be false. */
1543 for (; c && is_const; c = c->next)
1545 switch (c->expr->expr_type)
1548 if (len && !(*len && INTEGER_CST_P (*len)))
1549 *len = build_int_cstu (gfc_charlen_type_node,
1550 c->expr->value.character.length);
1554 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1561 get_array_ctor_var_strlen (c->expr, len);
1567 get_array_ctor_all_strlen (block, c->expr, len);
1571 /* After the first iteration, we don't want the length modified. */
1578 /* Check whether the array constructor C consists entirely of constant
1579 elements, and if so returns the number of those elements, otherwise
1580 return zero. Note, an empty or NULL array constructor returns zero. */
1582 unsigned HOST_WIDE_INT
1583 gfc_constant_array_constructor_p (gfc_constructor * c)
1585 unsigned HOST_WIDE_INT nelem = 0;
1590 || c->expr->rank > 0
1591 || c->expr->expr_type != EXPR_CONSTANT)
1600 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1601 and the tree type of it's elements, TYPE, return a static constant
1602 variable that is compile-time initialized. */
1605 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1607 tree tmptype, list, init, tmp;
1608 HOST_WIDE_INT nelem;
1614 /* First traverse the constructor list, converting the constants
1615 to tree to build an initializer. */
1618 c = expr->value.constructor;
1621 gfc_init_se (&se, NULL);
1622 gfc_conv_constant (&se, c->expr);
1623 if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
1624 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1626 list = tree_cons (NULL_TREE, se.expr, list);
1631 /* Next determine the tree type for the array. We use the gfortran
1632 front-end's gfc_get_nodesc_array_type in order to create a suitable
1633 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1635 memset (&as, 0, sizeof (gfc_array_spec));
1637 as.rank = expr->rank;
1638 as.type = AS_EXPLICIT;
1641 as.lower[0] = gfc_int_expr (0);
1642 as.upper[0] = gfc_int_expr (nelem - 1);
1645 for (i = 0; i < expr->rank; i++)
1647 int tmp = (int) mpz_get_si (expr->shape[i]);
1648 as.lower[i] = gfc_int_expr (0);
1649 as.upper[i] = gfc_int_expr (tmp - 1);
1652 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1654 init = build_constructor_from_list (tmptype, nreverse (list));
1656 TREE_CONSTANT (init) = 1;
1657 TREE_STATIC (init) = 1;
1659 tmp = gfc_create_var (tmptype, "A");
1660 TREE_STATIC (tmp) = 1;
1661 TREE_CONSTANT (tmp) = 1;
1662 TREE_READONLY (tmp) = 1;
1663 DECL_INITIAL (tmp) = init;
1669 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1670 This mostly initializes the scalarizer state info structure with the
1671 appropriate values to directly use the array created by the function
1672 gfc_build_constant_array_constructor. */
1675 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1676 gfc_ss * ss, tree type)
1682 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1684 info = &ss->data.info;
1686 info->descriptor = tmp;
1687 info->data = build_fold_addr_expr (tmp);
1688 info->offset = gfc_index_zero_node;
1690 for (i = 0; i < info->dimen; i++)
1692 info->delta[i] = gfc_index_zero_node;
1693 info->start[i] = gfc_index_zero_node;
1694 info->end[i] = gfc_index_zero_node;
1695 info->stride[i] = gfc_index_one_node;
1699 if (info->dimen > loop->temp_dim)
1700 loop->temp_dim = info->dimen;
1703 /* Helper routine of gfc_trans_array_constructor to determine if the
1704 bounds of the loop specified by LOOP are constant and simple enough
1705 to use with gfc_trans_constant_array_constructor. Returns the
1706 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1709 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1711 tree size = gfc_index_one_node;
1715 for (i = 0; i < loop->dimen; i++)
1717 /* If the bounds aren't constant, return NULL_TREE. */
1718 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1720 if (!integer_zerop (loop->from[i]))
1722 /* Only allow nonzero "from" in one-dimensional arrays. */
1723 if (loop->dimen != 1)
1725 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1726 loop->to[i], loop->from[i]);
1730 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1731 tmp, gfc_index_one_node);
1732 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1739 /* Array constructors are handled by constructing a temporary, then using that
1740 within the scalarization loop. This is not optimal, but seems by far the
1744 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1752 bool old_first_len, old_typespec_chararray_ctor;
1753 tree old_first_len_val;
1755 /* Save the old values for nested checking. */
1756 old_first_len = first_len;
1757 old_first_len_val = first_len_val;
1758 old_typespec_chararray_ctor = typespec_chararray_ctor;
1760 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1761 typespec was given for the array constructor. */
1762 typespec_chararray_ctor = (ss->expr->ts.cl
1763 && ss->expr->ts.cl->length_from_typespec);
1765 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
1766 && !typespec_chararray_ctor)
1768 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1772 ss->data.info.dimen = loop->dimen;
1774 c = ss->expr->value.constructor;
1775 if (ss->expr->ts.type == BT_CHARACTER)
1779 /* get_array_ctor_strlen walks the elements of the constructor, if a
1780 typespec was given, we already know the string length and want the one
1782 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1783 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1787 const_string = false;
1788 gfc_init_se (&length_se, NULL);
1789 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1790 gfc_charlen_type_node);
1791 ss->string_length = length_se.expr;
1792 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1793 gfc_add_block_to_block (&loop->post, &length_se.post);
1796 const_string = get_array_ctor_strlen (&loop->pre, c,
1797 &ss->string_length);
1799 /* Complex character array constructors should have been taken care of
1800 and not end up here. */
1801 gcc_assert (ss->string_length);
1803 ss->expr->ts.cl->backend_decl = ss->string_length;
1805 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1807 type = build_pointer_type (type);
1810 type = gfc_typenode_for_spec (&ss->expr->ts);
1812 /* See if the constructor determines the loop bounds. */
1815 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1817 /* We have a multidimensional parameter. */
1819 for (n = 0; n < ss->expr->rank; n++)
1821 loop->from[n] = gfc_index_zero_node;
1822 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1823 gfc_index_integer_kind);
1824 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1825 loop->to[n], gfc_index_one_node);
1829 if (loop->to[0] == NULL_TREE)
1833 /* We should have a 1-dimensional, zero-based loop. */
1834 gcc_assert (loop->dimen == 1);
1835 gcc_assert (integer_zerop (loop->from[0]));
1837 /* Split the constructor size into a static part and a dynamic part.
1838 Allocate the static size up-front and record whether the dynamic
1839 size might be nonzero. */
1841 dynamic = gfc_get_array_constructor_size (&size, c);
1842 mpz_sub_ui (size, size, 1);
1843 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1847 /* Special case constant array constructors. */
1850 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1853 tree size = constant_array_constructor_loop_size (loop);
1854 if (size && compare_tree_int (size, nelem) == 0)
1856 gfc_trans_constant_array_constructor (loop, ss, type);
1862 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1863 type, NULL_TREE, dynamic, true, false, where);
1865 desc = ss->data.info.descriptor;
1866 offset = gfc_index_zero_node;
1867 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1868 TREE_NO_WARNING (offsetvar) = 1;
1869 TREE_USED (offsetvar) = 0;
1870 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1871 &offset, &offsetvar, dynamic);
1873 /* If the array grows dynamically, the upper bound of the loop variable
1874 is determined by the array's final upper bound. */
1876 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1878 if (TREE_USED (offsetvar))
1879 pushdecl (offsetvar);
1881 gcc_assert (INTEGER_CST_P (offset));
1883 /* Disable bound checking for now because it's probably broken. */
1884 if (flag_bounds_check)
1891 /* Restore old values of globals. */
1892 first_len = old_first_len;
1893 first_len_val = old_first_len_val;
1894 typespec_chararray_ctor = old_typespec_chararray_ctor;
1898 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1899 called after evaluating all of INFO's vector dimensions. Go through
1900 each such vector dimension and see if we can now fill in any missing
1904 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1913 for (n = 0; n < loop->dimen; n++)
1916 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1917 && loop->to[n] == NULL)
1919 /* Loop variable N indexes vector dimension DIM, and we don't
1920 yet know the upper bound of loop variable N. Set it to the
1921 difference between the vector's upper and lower bounds. */
1922 gcc_assert (loop->from[n] == gfc_index_zero_node);
1923 gcc_assert (info->subscript[dim]
1924 && info->subscript[dim]->type == GFC_SS_VECTOR);
1926 gfc_init_se (&se, NULL);
1927 desc = info->subscript[dim]->data.info.descriptor;
1928 zero = gfc_rank_cst[0];
1929 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1930 gfc_conv_descriptor_ubound (desc, zero),
1931 gfc_conv_descriptor_lbound (desc, zero));
1932 tmp = gfc_evaluate_now (tmp, &loop->pre);
1939 /* Add the pre and post chains for all the scalar expressions in a SS chain
1940 to loop. This is called after the loop parameters have been calculated,
1941 but before the actual scalarizing loops. */
1944 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1950 /* TODO: This can generate bad code if there are ordering dependencies,
1951 e.g., a callee allocated function and an unknown size constructor. */
1952 gcc_assert (ss != NULL);
1954 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1961 /* Scalar expression. Evaluate this now. This includes elemental
1962 dimension indices, but not array section bounds. */
1963 gfc_init_se (&se, NULL);
1964 gfc_conv_expr (&se, ss->expr);
1965 gfc_add_block_to_block (&loop->pre, &se.pre);
1967 if (ss->expr->ts.type != BT_CHARACTER)
1969 /* Move the evaluation of scalar expressions outside the
1970 scalarization loop, except for WHERE assignments. */
1972 se.expr = convert(gfc_array_index_type, se.expr);
1974 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1975 gfc_add_block_to_block (&loop->pre, &se.post);
1978 gfc_add_block_to_block (&loop->post, &se.post);
1980 ss->data.scalar.expr = se.expr;
1981 ss->string_length = se.string_length;
1984 case GFC_SS_REFERENCE:
1985 /* Scalar reference. Evaluate this now. */
1986 gfc_init_se (&se, NULL);
1987 gfc_conv_expr_reference (&se, ss->expr);
1988 gfc_add_block_to_block (&loop->pre, &se.pre);
1989 gfc_add_block_to_block (&loop->post, &se.post);
1991 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1992 ss->string_length = se.string_length;
1995 case GFC_SS_SECTION:
1996 /* Add the expressions for scalar and vector subscripts. */
1997 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1998 if (ss->data.info.subscript[n])
1999 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2002 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2006 /* Get the vector's descriptor and store it in SS. */
2007 gfc_init_se (&se, NULL);
2008 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2009 gfc_add_block_to_block (&loop->pre, &se.pre);
2010 gfc_add_block_to_block (&loop->post, &se.post);
2011 ss->data.info.descriptor = se.expr;
2014 case GFC_SS_INTRINSIC:
2015 gfc_add_intrinsic_ss_code (loop, ss);
2018 case GFC_SS_FUNCTION:
2019 /* Array function return value. We call the function and save its
2020 result in a temporary for use inside the loop. */
2021 gfc_init_se (&se, NULL);
2024 gfc_conv_expr (&se, ss->expr);
2025 gfc_add_block_to_block (&loop->pre, &se.pre);
2026 gfc_add_block_to_block (&loop->post, &se.post);
2027 ss->string_length = se.string_length;
2030 case GFC_SS_CONSTRUCTOR:
2031 if (ss->expr->ts.type == BT_CHARACTER
2032 && ss->string_length == NULL
2034 && ss->expr->ts.cl->length)
2036 gfc_init_se (&se, NULL);
2037 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
2038 gfc_charlen_type_node);
2039 ss->string_length = se.expr;
2040 gfc_add_block_to_block (&loop->pre, &se.pre);
2041 gfc_add_block_to_block (&loop->post, &se.post);
2043 gfc_trans_array_constructor (loop, ss, where);
2047 case GFC_SS_COMPONENT:
2048 /* Do nothing. These are handled elsewhere. */
2058 /* Translate expressions for the descriptor and data pointer of a SS. */
2062 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2067 /* Get the descriptor for the array to be scalarized. */
2068 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2069 gfc_init_se (&se, NULL);
2070 se.descriptor_only = 1;
2071 gfc_conv_expr_lhs (&se, ss->expr);
2072 gfc_add_block_to_block (block, &se.pre);
2073 ss->data.info.descriptor = se.expr;
2074 ss->string_length = se.string_length;
2078 /* Also the data pointer. */
2079 tmp = gfc_conv_array_data (se.expr);
2080 /* If this is a variable or address of a variable we use it directly.
2081 Otherwise we must evaluate it now to avoid breaking dependency
2082 analysis by pulling the expressions for elemental array indices
2085 || (TREE_CODE (tmp) == ADDR_EXPR
2086 && DECL_P (TREE_OPERAND (tmp, 0)))))
2087 tmp = gfc_evaluate_now (tmp, block);
2088 ss->data.info.data = tmp;
2090 tmp = gfc_conv_array_offset (se.expr);
2091 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2096 /* Initialize a gfc_loopinfo structure. */
2099 gfc_init_loopinfo (gfc_loopinfo * loop)
2103 memset (loop, 0, sizeof (gfc_loopinfo));
2104 gfc_init_block (&loop->pre);
2105 gfc_init_block (&loop->post);
2107 /* Initially scalarize in order. */
2108 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2111 loop->ss = gfc_ss_terminator;
2115 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2119 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2125 /* Return an expression for the data pointer of an array. */
2128 gfc_conv_array_data (tree descriptor)
2132 type = TREE_TYPE (descriptor);
2133 if (GFC_ARRAY_TYPE_P (type))
2135 if (TREE_CODE (type) == POINTER_TYPE)
2139 /* Descriptorless arrays. */
2140 return build_fold_addr_expr (descriptor);
2144 return gfc_conv_descriptor_data_get (descriptor);
2148 /* Return an expression for the base offset of an array. */
2151 gfc_conv_array_offset (tree descriptor)
2155 type = TREE_TYPE (descriptor);
2156 if (GFC_ARRAY_TYPE_P (type))
2157 return GFC_TYPE_ARRAY_OFFSET (type);
2159 return gfc_conv_descriptor_offset (descriptor);
2163 /* Get an expression for the array stride. */
2166 gfc_conv_array_stride (tree descriptor, int dim)
2171 type = TREE_TYPE (descriptor);
2173 /* For descriptorless arrays use the array size. */
2174 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2175 if (tmp != NULL_TREE)
2178 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2183 /* Like gfc_conv_array_stride, but for the lower bound. */
2186 gfc_conv_array_lbound (tree descriptor, int dim)
2191 type = TREE_TYPE (descriptor);
2193 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2194 if (tmp != NULL_TREE)
2197 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2202 /* Like gfc_conv_array_stride, but for the upper bound. */
2205 gfc_conv_array_ubound (tree descriptor, int dim)
2210 type = TREE_TYPE (descriptor);
2212 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2213 if (tmp != NULL_TREE)
2216 /* This should only ever happen when passing an assumed shape array
2217 as an actual parameter. The value will never be used. */
2218 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2219 return gfc_index_zero_node;
2221 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2226 /* Generate code to perform an array index bound check. */
2229 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2230 locus * where, bool check_upper)
2235 const char * name = NULL;
2237 if (!flag_bounds_check)
2240 index = gfc_evaluate_now (index, &se->pre);
2242 /* We find a name for the error message. */
2244 name = se->ss->expr->symtree->name;
2246 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2247 && se->loop->ss->expr->symtree)
2248 name = se->loop->ss->expr->symtree->name;
2250 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2251 && se->loop->ss->loop_chain->expr
2252 && se->loop->ss->loop_chain->expr->symtree)
2253 name = se->loop->ss->loop_chain->expr->symtree->name;
2255 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2256 && se->loop->ss->loop_chain->expr->symtree)
2257 name = se->loop->ss->loop_chain->expr->symtree->name;
2259 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2261 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2262 && se->loop->ss->expr->value.function.name)
2263 name = se->loop->ss->expr->value.function.name;
2265 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2266 || se->loop->ss->type == GFC_SS_SCALAR)
2267 name = "unnamed constant";
2270 /* Check lower bound. */
2271 tmp = gfc_conv_array_lbound (descriptor, n);
2272 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2274 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2275 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2277 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2278 gfc_msg_fault, n+1);
2279 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2280 fold_convert (long_integer_type_node, index),
2281 fold_convert (long_integer_type_node, tmp));
2284 /* Check upper bound. */
2287 tmp = gfc_conv_array_ubound (descriptor, n);
2288 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2290 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2291 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2293 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2294 gfc_msg_fault, n+1);
2295 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2296 fold_convert (long_integer_type_node, index),
2297 fold_convert (long_integer_type_node, tmp));
2305 /* Return the offset for an index. Performs bound checking for elemental
2306 dimensions. Single element references are processed separately. */
2309 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2310 gfc_array_ref * ar, tree stride)
2316 /* Get the index into the array for this dimension. */
2319 gcc_assert (ar->type != AR_ELEMENT);
2320 switch (ar->dimen_type[dim])
2323 /* Elemental dimension. */
2324 gcc_assert (info->subscript[dim]
2325 && info->subscript[dim]->type == GFC_SS_SCALAR);
2326 /* We've already translated this value outside the loop. */
2327 index = info->subscript[dim]->data.scalar.expr;
2329 index = gfc_trans_array_bound_check (se, info->descriptor,
2330 index, dim, &ar->where,
2331 (ar->as->type != AS_ASSUMED_SIZE
2332 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2336 gcc_assert (info && se->loop);
2337 gcc_assert (info->subscript[dim]
2338 && info->subscript[dim]->type == GFC_SS_VECTOR);
2339 desc = info->subscript[dim]->data.info.descriptor;
2341 /* Get a zero-based index into the vector. */
2342 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2343 se->loop->loopvar[i], se->loop->from[i]);
2345 /* Multiply the index by the stride. */
2346 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2347 index, gfc_conv_array_stride (desc, 0));
2349 /* Read the vector to get an index into info->descriptor. */
2350 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2351 index = gfc_build_array_ref (data, index, NULL);
2352 index = gfc_evaluate_now (index, &se->pre);
2354 /* Do any bounds checking on the final info->descriptor index. */
2355 index = gfc_trans_array_bound_check (se, info->descriptor,
2356 index, dim, &ar->where,
2357 (ar->as->type != AS_ASSUMED_SIZE
2358 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2362 /* Scalarized dimension. */
2363 gcc_assert (info && se->loop);
2365 /* Multiply the loop variable by the stride and delta. */
2366 index = se->loop->loopvar[i];
2367 if (!integer_onep (info->stride[i]))
2368 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2370 if (!integer_zerop (info->delta[i]))
2371 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2381 /* Temporary array or derived type component. */
2382 gcc_assert (se->loop);
2383 index = se->loop->loopvar[se->loop->order[i]];
2384 if (!integer_zerop (info->delta[i]))
2385 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2386 index, info->delta[i]);
2389 /* Multiply by the stride. */
2390 if (!integer_onep (stride))
2391 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2397 /* Build a scalarized reference to an array. */
2400 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2403 tree decl = NULL_TREE;
2408 info = &se->ss->data.info;
2410 n = se->loop->order[0];
2414 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2416 /* Add the offset for this dimension to the stored offset for all other
2418 if (!integer_zerop (info->offset))
2419 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2421 if (se->ss->expr && is_subref_array (se->ss->expr))
2422 decl = se->ss->expr->symtree->n.sym->backend_decl;
2424 tmp = build_fold_indirect_ref (info->data);
2425 se->expr = gfc_build_array_ref (tmp, index, decl);
2429 /* Translate access of temporary array. */
2432 gfc_conv_tmp_array_ref (gfc_se * se)
2434 se->string_length = se->ss->string_length;
2435 gfc_conv_scalarized_array_ref (se, NULL);
2439 /* Build an array reference. se->expr already holds the array descriptor.
2440 This should be either a variable, indirect variable reference or component
2441 reference. For arrays which do not have a descriptor, se->expr will be
2443 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2446 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2455 /* Handle scalarized references separately. */
2456 if (ar->type != AR_ELEMENT)
2458 gfc_conv_scalarized_array_ref (se, ar);
2459 gfc_advance_se_ss_chain (se);
2463 index = gfc_index_zero_node;
2465 /* Calculate the offsets from all the dimensions. */
2466 for (n = 0; n < ar->dimen; n++)
2468 /* Calculate the index for this dimension. */
2469 gfc_init_se (&indexse, se);
2470 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2471 gfc_add_block_to_block (&se->pre, &indexse.pre);
2473 if (flag_bounds_check)
2475 /* Check array bounds. */
2479 /* Evaluate the indexse.expr only once. */
2480 indexse.expr = save_expr (indexse.expr);
2483 tmp = gfc_conv_array_lbound (se->expr, n);
2484 cond = fold_build2 (LT_EXPR, boolean_type_node,
2486 asprintf (&msg, "%s for array '%s', "
2487 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2488 gfc_msg_fault, sym->name, n+1);
2489 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2490 fold_convert (long_integer_type_node,
2492 fold_convert (long_integer_type_node, tmp));
2495 /* Upper bound, but not for the last dimension of assumed-size
2497 if (n < ar->dimen - 1
2498 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2500 tmp = gfc_conv_array_ubound (se->expr, n);
2501 cond = fold_build2 (GT_EXPR, boolean_type_node,
2503 asprintf (&msg, "%s for array '%s', "
2504 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2505 gfc_msg_fault, sym->name, n+1);
2506 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2507 fold_convert (long_integer_type_node,
2509 fold_convert (long_integer_type_node, tmp));
2514 /* Multiply the index by the stride. */
2515 stride = gfc_conv_array_stride (se->expr, n);
2516 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2519 /* And add it to the total. */
2520 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2523 tmp = gfc_conv_array_offset (se->expr);
2524 if (!integer_zerop (tmp))
2525 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2527 /* Access the calculated element. */
2528 tmp = gfc_conv_array_data (se->expr);
2529 tmp = build_fold_indirect_ref (tmp);
2530 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2534 /* Generate the code to be executed immediately before entering a
2535 scalarization loop. */
2538 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2539 stmtblock_t * pblock)
2548 /* This code will be executed before entering the scalarization loop
2549 for this dimension. */
2550 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2552 if ((ss->useflags & flag) == 0)
2555 if (ss->type != GFC_SS_SECTION
2556 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2557 && ss->type != GFC_SS_COMPONENT)
2560 info = &ss->data.info;
2562 if (dim >= info->dimen)
2565 if (dim == info->dimen - 1)
2567 /* For the outermost loop calculate the offset due to any
2568 elemental dimensions. It will have been initialized with the
2569 base offset of the array. */
2572 for (i = 0; i < info->ref->u.ar.dimen; i++)
2574 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2577 gfc_init_se (&se, NULL);
2579 se.expr = info->descriptor;
2580 stride = gfc_conv_array_stride (info->descriptor, i);
2581 index = gfc_conv_array_index_offset (&se, info, i, -1,
2584 gfc_add_block_to_block (pblock, &se.pre);
2586 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2587 info->offset, index);
2588 info->offset = gfc_evaluate_now (info->offset, pblock);
2592 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2595 stride = gfc_conv_array_stride (info->descriptor, 0);
2597 /* Calculate the stride of the innermost loop. Hopefully this will
2598 allow the backend optimizers to do their stuff more effectively.
2600 info->stride0 = gfc_evaluate_now (stride, pblock);
2604 /* Add the offset for the previous loop dimension. */
2609 ar = &info->ref->u.ar;
2610 i = loop->order[dim + 1];
2618 gfc_init_se (&se, NULL);
2620 se.expr = info->descriptor;
2621 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2622 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2624 gfc_add_block_to_block (pblock, &se.pre);
2625 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2626 info->offset, index);
2627 info->offset = gfc_evaluate_now (info->offset, pblock);
2630 /* Remember this offset for the second loop. */
2631 if (dim == loop->temp_dim - 1)
2632 info->saved_offset = info->offset;
2637 /* Start a scalarized expression. Creates a scope and declares loop
2641 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2647 gcc_assert (!loop->array_parameter);
2649 for (dim = loop->dimen - 1; dim >= 0; dim--)
2651 n = loop->order[dim];
2653 gfc_start_block (&loop->code[n]);
2655 /* Create the loop variable. */
2656 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2658 if (dim < loop->temp_dim)
2662 /* Calculate values that will be constant within this loop. */
2663 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2665 gfc_start_block (pbody);
2669 /* Generates the actual loop code for a scalarization loop. */
2672 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2673 stmtblock_t * pbody)
2681 loopbody = gfc_finish_block (pbody);
2683 /* Initialize the loopvar. */
2684 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2686 exit_label = gfc_build_label_decl (NULL_TREE);
2688 /* Generate the loop body. */
2689 gfc_init_block (&block);
2691 /* The exit condition. */
2692 cond = fold_build2 (GT_EXPR, boolean_type_node,
2693 loop->loopvar[n], loop->to[n]);
2694 tmp = build1_v (GOTO_EXPR, exit_label);
2695 TREE_USED (exit_label) = 1;
2696 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2697 gfc_add_expr_to_block (&block, tmp);
2699 /* The main body. */
2700 gfc_add_expr_to_block (&block, loopbody);
2702 /* Increment the loopvar. */
2703 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2704 loop->loopvar[n], gfc_index_one_node);
2705 gfc_add_modify (&block, loop->loopvar[n], tmp);
2707 /* Build the loop. */
2708 tmp = gfc_finish_block (&block);
2709 tmp = build1_v (LOOP_EXPR, tmp);
2710 gfc_add_expr_to_block (&loop->code[n], tmp);
2712 /* Add the exit label. */
2713 tmp = build1_v (LABEL_EXPR, exit_label);
2714 gfc_add_expr_to_block (&loop->code[n], tmp);
2718 /* Finishes and generates the loops for a scalarized expression. */
2721 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2726 stmtblock_t *pblock;
2730 /* Generate the loops. */
2731 for (dim = 0; dim < loop->dimen; dim++)
2733 n = loop->order[dim];
2734 gfc_trans_scalarized_loop_end (loop, n, pblock);
2735 loop->loopvar[n] = NULL_TREE;
2736 pblock = &loop->code[n];
2739 tmp = gfc_finish_block (pblock);
2740 gfc_add_expr_to_block (&loop->pre, tmp);
2742 /* Clear all the used flags. */
2743 for (ss = loop->ss; ss; ss = ss->loop_chain)
2748 /* Finish the main body of a scalarized expression, and start the secondary
2752 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2756 stmtblock_t *pblock;
2760 /* We finish as many loops as are used by the temporary. */
2761 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2763 n = loop->order[dim];
2764 gfc_trans_scalarized_loop_end (loop, n, pblock);
2765 loop->loopvar[n] = NULL_TREE;
2766 pblock = &loop->code[n];
2769 /* We don't want to finish the outermost loop entirely. */
2770 n = loop->order[loop->temp_dim - 1];
2771 gfc_trans_scalarized_loop_end (loop, n, pblock);
2773 /* Restore the initial offsets. */
2774 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2776 if ((ss->useflags & 2) == 0)
2779 if (ss->type != GFC_SS_SECTION
2780 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2781 && ss->type != GFC_SS_COMPONENT)
2784 ss->data.info.offset = ss->data.info.saved_offset;
2787 /* Restart all the inner loops we just finished. */
2788 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2790 n = loop->order[dim];
2792 gfc_start_block (&loop->code[n]);
2794 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2796 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2799 /* Start a block for the secondary copying code. */
2800 gfc_start_block (body);
2804 /* Calculate the upper bound of an array section. */
2807 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2816 gcc_assert (ss->type == GFC_SS_SECTION);
2818 info = &ss->data.info;
2821 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2822 /* We'll calculate the upper bound once we have access to the
2823 vector's descriptor. */
2826 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2827 desc = info->descriptor;
2828 end = info->ref->u.ar.end[dim];
2832 /* The upper bound was specified. */
2833 gfc_init_se (&se, NULL);
2834 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2835 gfc_add_block_to_block (pblock, &se.pre);
2840 /* No upper bound was specified, so use the bound of the array. */
2841 bound = gfc_conv_array_ubound (desc, dim);
2848 /* Calculate the lower bound of an array section. */
2851 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2861 gcc_assert (ss->type == GFC_SS_SECTION);
2863 info = &ss->data.info;
2866 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2868 /* We use a zero-based index to access the vector. */
2869 info->start[n] = gfc_index_zero_node;
2870 info->end[n] = gfc_index_zero_node;
2871 info->stride[n] = gfc_index_one_node;
2875 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2876 desc = info->descriptor;
2877 start = info->ref->u.ar.start[dim];
2878 end = info->ref->u.ar.end[dim];
2879 stride = info->ref->u.ar.stride[dim];
2881 /* Calculate the start of the range. For vector subscripts this will
2882 be the range of the vector. */
2885 /* Specified section start. */
2886 gfc_init_se (&se, NULL);
2887 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2888 gfc_add_block_to_block (&loop->pre, &se.pre);
2889 info->start[n] = se.expr;
2893 /* No lower bound specified so use the bound of the array. */
2894 info->start[n] = gfc_conv_array_lbound (desc, dim);
2896 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2898 /* Similarly calculate the end. Although this is not used in the
2899 scalarizer, it is needed when checking bounds and where the end
2900 is an expression with side-effects. */
2903 /* Specified section start. */
2904 gfc_init_se (&se, NULL);
2905 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2906 gfc_add_block_to_block (&loop->pre, &se.pre);
2907 info->end[n] = se.expr;
2911 /* No upper bound specified so use the bound of the array. */
2912 info->end[n] = gfc_conv_array_ubound (desc, dim);
2914 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2916 /* Calculate the stride. */
2918 info->stride[n] = gfc_index_one_node;
2921 gfc_init_se (&se, NULL);
2922 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2923 gfc_add_block_to_block (&loop->pre, &se.pre);
2924 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2929 /* Calculates the range start and stride for a SS chain. Also gets the
2930 descriptor and data pointer. The range of vector subscripts is the size
2931 of the vector. Array bounds are also checked. */
2934 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2942 /* Determine the rank of the loop. */
2944 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2948 case GFC_SS_SECTION:
2949 case GFC_SS_CONSTRUCTOR:
2950 case GFC_SS_FUNCTION:
2951 case GFC_SS_COMPONENT:
2952 loop->dimen = ss->data.info.dimen;
2955 /* As usual, lbound and ubound are exceptions!. */
2956 case GFC_SS_INTRINSIC:
2957 switch (ss->expr->value.function.isym->id)
2959 case GFC_ISYM_LBOUND:
2960 case GFC_ISYM_UBOUND:
2961 loop->dimen = ss->data.info.dimen;
2972 /* We should have determined the rank of the expression by now. If
2973 not, that's bad news. */
2974 gcc_assert (loop->dimen != 0);
2976 /* Loop over all the SS in the chain. */
2977 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2979 if (ss->expr && ss->expr->shape && !ss->shape)
2980 ss->shape = ss->expr->shape;
2984 case GFC_SS_SECTION:
2985 /* Get the descriptor for the array. */
2986 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2988 for (n = 0; n < ss->data.info.dimen; n++)
2989 gfc_conv_section_startstride (loop, ss, n);
2992 case GFC_SS_INTRINSIC:
2993 switch (ss->expr->value.function.isym->id)
2995 /* Fall through to supply start and stride. */
2996 case GFC_ISYM_LBOUND:
2997 case GFC_ISYM_UBOUND:
3003 case GFC_SS_CONSTRUCTOR:
3004 case GFC_SS_FUNCTION:
3005 for (n = 0; n < ss->data.info.dimen; n++)
3007 ss->data.info.start[n] = gfc_index_zero_node;
3008 ss->data.info.end[n] = gfc_index_zero_node;
3009 ss->data.info.stride[n] = gfc_index_one_node;
3018 /* The rest is just runtime bound checking. */
3019 if (flag_bounds_check)
3022 tree lbound, ubound;
3024 tree size[GFC_MAX_DIMENSIONS];
3025 tree stride_pos, stride_neg, non_zerosized, tmp2;
3030 gfc_start_block (&block);
3032 for (n = 0; n < loop->dimen; n++)
3033 size[n] = NULL_TREE;
3035 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3039 if (ss->type != GFC_SS_SECTION)
3042 gfc_start_block (&inner);
3044 /* TODO: range checking for mapped dimensions. */
3045 info = &ss->data.info;
3047 /* This code only checks ranges. Elemental and vector
3048 dimensions are checked later. */
3049 for (n = 0; n < loop->dimen; n++)
3054 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3057 if (dim == info->ref->u.ar.dimen - 1
3058 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3059 || info->ref->u.ar.as->cp_was_assumed))
3060 check_upper = false;
3064 /* Zero stride is not allowed. */
3065 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3066 gfc_index_zero_node);
3067 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3068 "of array '%s'", info->dim[n]+1,
3069 ss->expr->symtree->name);
3070 gfc_trans_runtime_check (true, false, tmp, &inner,
3071 &ss->expr->where, msg);
3074 desc = ss->data.info.descriptor;
3076 /* This is the run-time equivalent of resolve.c's
3077 check_dimension(). The logical is more readable there
3078 than it is here, with all the trees. */
3079 lbound = gfc_conv_array_lbound (desc, dim);
3082 ubound = gfc_conv_array_ubound (desc, dim);
3086 /* non_zerosized is true when the selected range is not
3088 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3089 info->stride[n], gfc_index_zero_node);
3090 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3092 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3095 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3096 info->stride[n], gfc_index_zero_node);
3097 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3099 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3101 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3102 stride_pos, stride_neg);
3104 /* Check the start of the range against the lower and upper
3105 bounds of the array, if the range is not empty. */
3106 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3108 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3109 non_zerosized, tmp);
3110 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3111 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3112 info->dim[n]+1, ss->expr->symtree->name);
3113 gfc_trans_runtime_check (true, false, tmp, &inner,
3114 &ss->expr->where, msg,
3115 fold_convert (long_integer_type_node,
3117 fold_convert (long_integer_type_node,
3123 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3124 info->start[n], ubound);
3125 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3126 non_zerosized, tmp);
3127 asprintf (&msg, "%s, upper bound of dimension %d of array "
3128 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3129 info->dim[n]+1, ss->expr->symtree->name);
3130 gfc_trans_runtime_check (true, false, tmp, &inner,
3131 &ss->expr->where, msg,
3132 fold_convert (long_integer_type_node, info->start[n]),
3133 fold_convert (long_integer_type_node, ubound));
3137 /* Compute the last element of the range, which is not
3138 necessarily "end" (think 0:5:3, which doesn't contain 5)
3139 and check it against both lower and upper bounds. */
3140 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3142 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3144 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3147 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3148 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3149 non_zerosized, tmp);
3150 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3151 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3152 info->dim[n]+1, ss->expr->symtree->name);
3153 gfc_trans_runtime_check (true, false, tmp, &inner,
3154 &ss->expr->where, msg,
3155 fold_convert (long_integer_type_node,
3157 fold_convert (long_integer_type_node,
3163 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3164 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3165 non_zerosized, tmp);
3166 asprintf (&msg, "%s, upper bound of dimension %d of array "
3167 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3168 info->dim[n]+1, ss->expr->symtree->name);
3169 gfc_trans_runtime_check (true, false, tmp, &inner,
3170 &ss->expr->where, msg,
3171 fold_convert (long_integer_type_node, tmp2),
3172 fold_convert (long_integer_type_node, ubound));
3176 /* Check the section sizes match. */
3177 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3179 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3181 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3182 build_int_cst (gfc_array_index_type, 0));
3183 /* We remember the size of the first section, and check all the
3184 others against this. */
3189 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3190 asprintf (&msg, "%s, size mismatch for dimension %d "
3191 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3192 info->dim[n]+1, ss->expr->symtree->name);
3193 gfc_trans_runtime_check (true, false, tmp3, &inner,
3194 &ss->expr->where, msg,
3195 fold_convert (long_integer_type_node, tmp),
3196 fold_convert (long_integer_type_node, size[n]));
3200 size[n] = gfc_evaluate_now (tmp, &inner);
3203 tmp = gfc_finish_block (&inner);
3205 /* For optional arguments, only check bounds if the argument is
3207 if (ss->expr->symtree->n.sym->attr.optional
3208 || ss->expr->symtree->n.sym->attr.not_always_present)
3209 tmp = build3_v (COND_EXPR,
3210 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3211 tmp, build_empty_stmt ());
3213 gfc_add_expr_to_block (&block, tmp);
3217 tmp = gfc_finish_block (&block);
3218 gfc_add_expr_to_block (&loop->pre, tmp);
3223 /* Return true if the two SS could be aliased, i.e. both point to the same data
3225 /* TODO: resolve aliases based on frontend expressions. */
3228 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3235 lsym = lss->expr->symtree->n.sym;
3236 rsym = rss->expr->symtree->n.sym;
3237 if (gfc_symbols_could_alias (lsym, rsym))
3240 if (rsym->ts.type != BT_DERIVED
3241 && lsym->ts.type != BT_DERIVED)
3244 /* For derived types we must check all the component types. We can ignore
3245 array references as these will have the same base type as the previous
3247 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3249 if (lref->type != REF_COMPONENT)
3252 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3255 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3258 if (rref->type != REF_COMPONENT)
3261 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3266 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3268 if (rref->type != REF_COMPONENT)
3271 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3279 /* Resolve array data dependencies. Creates a temporary if required. */
3280 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3284 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3294 loop->temp_ss = NULL;
3295 aref = dest->data.info.ref;
3298 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3300 if (ss->type != GFC_SS_SECTION)
3303 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3305 if (gfc_could_be_alias (dest, ss)
3306 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3314 lref = dest->expr->ref;
3315 rref = ss->expr->ref;
3317 nDepend = gfc_dep_resolver (lref, rref);
3321 /* TODO : loop shifting. */
3324 /* Mark the dimensions for LOOP SHIFTING */
3325 for (n = 0; n < loop->dimen; n++)
3327 int dim = dest->data.info.dim[n];
3329 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3331 else if (! gfc_is_same_range (&lref->u.ar,
3332 &rref->u.ar, dim, 0))
3336 /* Put all the dimensions with dependencies in the
3339 for (n = 0; n < loop->dimen; n++)
3341 gcc_assert (loop->order[n] == n);
3343 loop->order[dim++] = n;
3346 for (n = 0; n < loop->dimen; n++)
3349 loop->order[dim++] = n;
3352 gcc_assert (dim == loop->dimen);
3361 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3362 if (GFC_ARRAY_TYPE_P (base_type)
3363 || GFC_DESCRIPTOR_TYPE_P (base_type))
3364 base_type = gfc_get_element_type (base_type);
3365 loop->temp_ss = gfc_get_ss ();
3366 loop->temp_ss->type = GFC_SS_TEMP;
3367 loop->temp_ss->data.temp.type = base_type;
3368 loop->temp_ss->string_length = dest->string_length;
3369 loop->temp_ss->data.temp.dimen = loop->dimen;
3370 loop->temp_ss->next = gfc_ss_terminator;
3371 gfc_add_ss_to_loop (loop, loop->temp_ss);
3374 loop->temp_ss = NULL;
3378 /* Initialize the scalarization loop. Creates the loop variables. Determines
3379 the range of the loop variables. Creates a temporary if required.
3380 Calculates how to transform from loop variables to array indices for each
3381 expression. Also generates code for scalar expressions which have been
3382 moved outside the loop. */
3385 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3390 gfc_ss_info *specinfo;
3394 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3395 bool dynamic[GFC_MAX_DIMENSIONS];
3401 for (n = 0; n < loop->dimen; n++)
3405 /* We use one SS term, and use that to determine the bounds of the
3406 loop for this dimension. We try to pick the simplest term. */
3407 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3411 /* The frontend has worked out the size for us. */
3412 if (!loopspec[n] || !loopspec[n]->shape
3413 || !integer_zerop (loopspec[n]->data.info.start[n]))
3414 /* Prefer zero-based descriptors if possible. */
3419 if (ss->type == GFC_SS_CONSTRUCTOR)
3421 /* An unknown size constructor will always be rank one.
3422 Higher rank constructors will either have known shape,
3423 or still be wrapped in a call to reshape. */
3424 gcc_assert (loop->dimen == 1);
3426 /* Always prefer to use the constructor bounds if the size
3427 can be determined at compile time. Prefer not to otherwise,
3428 since the general case involves realloc, and it's better to
3429 avoid that overhead if possible. */
3430 c = ss->expr->value.constructor;
3431 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3432 if (!dynamic[n] || !loopspec[n])
3437 /* TODO: Pick the best bound if we have a choice between a
3438 function and something else. */
3439 if (ss->type == GFC_SS_FUNCTION)
3445 if (ss->type != GFC_SS_SECTION)
3449 specinfo = &loopspec[n]->data.info;
3452 info = &ss->data.info;
3456 /* Criteria for choosing a loop specifier (most important first):
3457 doesn't need realloc
3463 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3465 else if (integer_onep (info->stride[n])
3466 && !integer_onep (specinfo->stride[n]))
3468 else if (INTEGER_CST_P (info->stride[n])
3469 && !INTEGER_CST_P (specinfo->stride[n]))
3471 else if (INTEGER_CST_P (info->start[n])
3472 && !INTEGER_CST_P (specinfo->start[n]))
3474 /* We don't work out the upper bound.
3475 else if (INTEGER_CST_P (info->finish[n])
3476 && ! INTEGER_CST_P (specinfo->finish[n]))
3477 loopspec[n] = ss; */
3480 /* We should have found the scalarization loop specifier. If not,
3482 gcc_assert (loopspec[n]);
3484 info = &loopspec[n]->data.info;
3486 /* Set the extents of this range. */
3487 cshape = loopspec[n]->shape;
3488 if (cshape && INTEGER_CST_P (info->start[n])
3489 && INTEGER_CST_P (info->stride[n]))
3491 loop->from[n] = info->start[n];
3492 mpz_set (i, cshape[n]);
3493 mpz_sub_ui (i, i, 1);
3494 /* To = from + (size - 1) * stride. */
3495 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3496 if (!integer_onep (info->stride[n]))
3497 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3498 tmp, info->stride[n]);
3499 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3500 loop->from[n], tmp);
3504 loop->from[n] = info->start[n];
3505 switch (loopspec[n]->type)
3507 case GFC_SS_CONSTRUCTOR:
3508 /* The upper bound is calculated when we expand the
3510 gcc_assert (loop->to[n] == NULL_TREE);
3513 case GFC_SS_SECTION:
3514 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3518 case GFC_SS_FUNCTION:
3519 /* The loop bound will be set when we generate the call. */
3520 gcc_assert (loop->to[n] == NULL_TREE);
3528 /* Transform everything so we have a simple incrementing variable. */
3529 if (integer_onep (info->stride[n]))
3530 info->delta[n] = gfc_index_zero_node;
3533 /* Set the delta for this section. */
3534 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3535 /* Number of iterations is (end - start + step) / step.
3536 with start = 0, this simplifies to
3538 for (i = 0; i<=last; i++){...}; */
3539 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3540 loop->to[n], loop->from[n]);
3541 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3542 tmp, info->stride[n]);
3543 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3544 build_int_cst (gfc_array_index_type, -1));
3545 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3546 /* Make the loop variable start at 0. */
3547 loop->from[n] = gfc_index_zero_node;
3551 /* Add all the scalar code that can be taken out of the loops.
3552 This may include calculating the loop bounds, so do it before
3553 allocating the temporary. */
3554 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3556 /* If we want a temporary then create it. */
3557 if (loop->temp_ss != NULL)
3559 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3561 /* Make absolutely sure that this is a complete type. */
3562 if (loop->temp_ss->string_length)
3563 loop->temp_ss->data.temp.type
3564 = gfc_get_character_type_len_for_eltype
3565 (TREE_TYPE (loop->temp_ss->data.temp.type),
3566 loop->temp_ss->string_length);
3568 tmp = loop->temp_ss->data.temp.type;
3569 len = loop->temp_ss->string_length;
3570 n = loop->temp_ss->data.temp.dimen;
3571 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3572 loop->temp_ss->type = GFC_SS_SECTION;
3573 loop->temp_ss->data.info.dimen = n;
3574 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3575 &loop->temp_ss->data.info, tmp, NULL_TREE,
3576 false, true, false, where);
3579 for (n = 0; n < loop->temp_dim; n++)
3580 loopspec[loop->order[n]] = NULL;
3584 /* For array parameters we don't have loop variables, so don't calculate the
3586 if (loop->array_parameter)
3589 /* Calculate the translation from loop variables to array indices. */
3590 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3592 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3593 && ss->type != GFC_SS_CONSTRUCTOR)
3597 info = &ss->data.info;
3599 for (n = 0; n < info->dimen; n++)
3603 /* If we are specifying the range the delta is already set. */
3604 if (loopspec[n] != ss)
3606 /* Calculate the offset relative to the loop variable.
3607 First multiply by the stride. */
3608 tmp = loop->from[n];
3609 if (!integer_onep (info->stride[n]))
3610 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3611 tmp, info->stride[n]);
3613 /* Then subtract this from our starting value. */
3614 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3615 info->start[n], tmp);
3617 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3624 /* Fills in an array descriptor, and returns the size of the array. The size
3625 will be a simple_val, ie a variable or a constant. Also calculates the
3626 offset of the base. Returns the size of the array.
3630 for (n = 0; n < rank; n++)
3632 a.lbound[n] = specified_lower_bound;
3633 offset = offset + a.lbond[n] * stride;
3635 a.ubound[n] = specified_upper_bound;
3636 a.stride[n] = stride;
3637 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3638 stride = stride * size;
3645 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3646 gfc_expr ** lower, gfc_expr ** upper,
3647 stmtblock_t * pblock)
3659 stmtblock_t thenblock;
3660 stmtblock_t elseblock;
3665 type = TREE_TYPE (descriptor);
3667 stride = gfc_index_one_node;
3668 offset = gfc_index_zero_node;
3670 /* Set the dtype. */
3671 tmp = gfc_conv_descriptor_dtype (descriptor);
3672 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3674 or_expr = NULL_TREE;
3676 for (n = 0; n < rank; n++)
3678 /* We have 3 possibilities for determining the size of the array:
3679 lower == NULL => lbound = 1, ubound = upper[n]
3680 upper[n] = NULL => lbound = 1, ubound = lower[n]
3681 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3684 /* Set lower bound. */
3685 gfc_init_se (&se, NULL);
3687 se.expr = gfc_index_one_node;
3690 gcc_assert (lower[n]);
3693 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3694 gfc_add_block_to_block (pblock, &se.pre);
3698 se.expr = gfc_index_one_node;
3702 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3703 gfc_add_modify (pblock, tmp, se.expr);
3705 /* Work out the offset for this component. */
3706 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3707 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3709 /* Start the calculation for the size of this dimension. */
3710 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3711 gfc_index_one_node, se.expr);
3713 /* Set upper bound. */
3714 gfc_init_se (&se, NULL);
3715 gcc_assert (ubound);
3716 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3717 gfc_add_block_to_block (pblock, &se.pre);
3719 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3720 gfc_add_modify (pblock, tmp, se.expr);
3722 /* Store the stride. */
3723 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3724 gfc_add_modify (pblock, tmp, stride);
3726 /* Calculate the size of this dimension. */
3727 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3729 /* Check whether the size for this dimension is negative. */
3730 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3731 gfc_index_zero_node);
3735 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3737 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3738 gfc_index_zero_node, size);
3740 /* Multiply the stride by the number of elements in this dimension. */
3741 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3742 stride = gfc_evaluate_now (stride, pblock);
3745 /* The stride is the number of elements in the array, so multiply by the
3746 size of an element to get the total size. */
3747 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3748 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3749 fold_convert (gfc_array_index_type, tmp));
3751 if (poffset != NULL)
3753 offset = gfc_evaluate_now (offset, pblock);
3757 if (integer_zerop (or_expr))
3759 if (integer_onep (or_expr))
3760 return gfc_index_zero_node;
3762 var = gfc_create_var (TREE_TYPE (size), "size");
3763 gfc_start_block (&thenblock);
3764 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3765 thencase = gfc_finish_block (&thenblock);
3767 gfc_start_block (&elseblock);
3768 gfc_add_modify (&elseblock, var, size);
3769 elsecase = gfc_finish_block (&elseblock);
3771 tmp = gfc_evaluate_now (or_expr, pblock);
3772 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3773 gfc_add_expr_to_block (pblock, tmp);
3779 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3780 the work for an ALLOCATE statement. */
3784 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3792 gfc_ref *ref, *prev_ref = NULL;
3793 bool allocatable_array;
3797 /* Find the last reference in the chain. */
3798 while (ref && ref->next != NULL)
3800 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3805 if (ref == NULL || ref->type != REF_ARRAY)
3809 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3811 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3813 /* Figure out the size of the array. */
3814 switch (ref->u.ar.type)
3818 upper = ref->u.ar.start;
3822 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3824 lower = ref->u.ar.as->lower;
3825 upper = ref->u.ar.as->upper;
3829 lower = ref->u.ar.start;
3830 upper = ref->u.ar.end;
3838 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3839 lower, upper, &se->pre);
3841 /* Allocate memory to store the data. */
3842 pointer = gfc_conv_descriptor_data_get (se->expr);
3843 STRIP_NOPS (pointer);
3845 /* The allocate_array variants take the old pointer as first argument. */
3846 if (allocatable_array)
3847 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3849 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3850 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3851 gfc_add_expr_to_block (&se->pre, tmp);
3853 tmp = gfc_conv_descriptor_offset (se->expr);
3854 gfc_add_modify (&se->pre, tmp, offset);
3856 if (expr->ts.type == BT_DERIVED
3857 && expr->ts.derived->attr.alloc_comp)
3859 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3860 ref->u.ar.as->rank);
3861 gfc_add_expr_to_block (&se->pre, tmp);
3868 /* Deallocate an array variable. Also used when an allocated variable goes
3873 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3879 gfc_start_block (&block);
3880 /* Get a pointer to the data. */
3881 var = gfc_conv_descriptor_data_get (descriptor);
3884 /* Parameter is the address of the data component. */
3885 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3886 gfc_add_expr_to_block (&block, tmp);
3888 /* Zero the data pointer. */
3889 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3890 var, build_int_cst (TREE_TYPE (var), 0));
3891 gfc_add_expr_to_block (&block, tmp);
3893 return gfc_finish_block (&block);
3897 /* Create an array constructor from an initialization expression.
3898 We assume the frontend already did any expansions and conversions. */
3901 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3908 unsigned HOST_WIDE_INT lo;
3910 VEC(constructor_elt,gc) *v = NULL;
3912 switch (expr->expr_type)
3915 case EXPR_STRUCTURE:
3916 /* A single scalar or derived type value. Create an array with all
3917 elements equal to that value. */
3918 gfc_init_se (&se, NULL);
3920 if (expr->expr_type == EXPR_CONSTANT)
3921 gfc_conv_constant (&se, expr);
3923 gfc_conv_structure (&se, expr, 1);
3925 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3926 gcc_assert (tmp && INTEGER_CST_P (tmp));
3927 hi = TREE_INT_CST_HIGH (tmp);
3928 lo = TREE_INT_CST_LOW (tmp);
3932 /* This will probably eat buckets of memory for large arrays. */
3933 while (hi != 0 || lo != 0)
3935 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3943 /* Create a vector of all the elements. */
3944 for (c = expr->value.constructor; c; c = c->next)
3948 /* Problems occur when we get something like
3949 integer :: a(lots) = (/(i, i=1, lots)/) */
3950 gfc_error_now ("The number of elements in the array constructor "
3951 "at %L requires an increase of the allowed %d "
3952 "upper limit. See -fmax-array-constructor "
3953 "option", &expr->where,
3954 gfc_option.flag_max_array_constructor);
3957 if (mpz_cmp_si (c->n.offset, 0) != 0)
3958 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3962 if (mpz_cmp_si (c->repeat, 0) != 0)
3966 mpz_set (maxval, c->repeat);
3967 mpz_add (maxval, c->n.offset, maxval);
3968 mpz_sub_ui (maxval, maxval, 1);
3969 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3970 if (mpz_cmp_si (c->n.offset, 0) != 0)
3972 mpz_add_ui (maxval, c->n.offset, 1);
3973 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3976 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3978 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3984 gfc_init_se (&se, NULL);
3985 switch (c->expr->expr_type)
3988 gfc_conv_constant (&se, c->expr);
3989 if (range == NULL_TREE)
3990 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3993 if (index != NULL_TREE)
3994 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3995 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3999 case EXPR_STRUCTURE:
4000 gfc_conv_structure (&se, c->expr, 1);
4001 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4011 return gfc_build_null_descriptor (type);
4017 /* Create a constructor from the list of elements. */
4018 tmp = build_constructor (type, v);
4019 TREE_CONSTANT (tmp) = 1;
4024 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4025 returns the size (in elements) of the array. */
4028 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4029 stmtblock_t * pblock)
4044 size = gfc_index_one_node;
4045 offset = gfc_index_zero_node;
4046 for (dim = 0; dim < as->rank; dim++)
4048 /* Evaluate non-constant array bound expressions. */
4049 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4050 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4052 gfc_init_se (&se, NULL);
4053 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4054 gfc_add_block_to_block (pblock, &se.pre);
4055 gfc_add_modify (pblock, lbound, se.expr);
4057 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4058 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4060 gfc_init_se (&se, NULL);
4061 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4062 gfc_add_block_to_block (pblock, &se.pre);
4063 gfc_add_modify (pblock, ubound, se.expr);
4065 /* The offset of this dimension. offset = offset - lbound * stride. */
4066 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4067 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4069 /* The size of this dimension, and the stride of the next. */
4070 if (dim + 1 < as->rank)
4071 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4073 stride = GFC_TYPE_ARRAY_SIZE (type);
4075 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4077 /* Calculate stride = size * (ubound + 1 - lbound). */
4078 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4079 gfc_index_one_node, lbound);
4080 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4081 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4083 gfc_add_modify (pblock, stride, tmp);
4085 stride = gfc_evaluate_now (tmp, pblock);
4087 /* Make sure that negative size arrays are translated
4088 to being zero size. */
4089 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4090 stride, gfc_index_zero_node);
4091 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4092 stride, gfc_index_zero_node);
4093 gfc_add_modify (pblock, stride, tmp);
4099 gfc_trans_vla_type_sizes (sym, pblock);
4106 /* Generate code to initialize/allocate an array variable. */
4109 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4118 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4120 /* Do nothing for USEd variables. */
4121 if (sym->attr.use_assoc)
4124 type = TREE_TYPE (decl);
4125 gcc_assert (GFC_ARRAY_TYPE_P (type));
4126 onstack = TREE_CODE (type) != POINTER_TYPE;
4128 gfc_start_block (&block);
4130 /* Evaluate character string length. */
4131 if (sym->ts.type == BT_CHARACTER
4132 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4134 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4136 gfc_trans_vla_type_sizes (sym, &block);
4138 /* Emit a DECL_EXPR for this variable, which will cause the
4139 gimplifier to allocate storage, and all that good stuff. */
4140 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4141 gfc_add_expr_to_block (&block, tmp);
4146 gfc_add_expr_to_block (&block, fnbody);
4147 return gfc_finish_block (&block);
4150 type = TREE_TYPE (type);
4152 gcc_assert (!sym->attr.use_assoc);
4153 gcc_assert (!TREE_STATIC (decl));
4154 gcc_assert (!sym->module);
4156 if (sym->ts.type == BT_CHARACTER
4157 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4158 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4160 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4162 /* Don't actually allocate space for Cray Pointees. */
4163 if (sym->attr.cray_pointee)
4165 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4166 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4167 gfc_add_expr_to_block (&block, fnbody);
4168 return gfc_finish_block (&block);
4171 /* The size is the number of elements in the array, so multiply by the
4172 size of an element to get the total size. */
4173 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4174 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4175 fold_convert (gfc_array_index_type, tmp));
4177 /* Allocate memory to hold the data. */
4178 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4179 gfc_add_modify (&block, decl, tmp);
4181 /* Set offset of the array. */
4182 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4183 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4186 /* Automatic arrays should not have initializers. */
4187 gcc_assert (!sym->value);
4189 gfc_add_expr_to_block (&block, fnbody);
4191 /* Free the temporary. */
4192 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4193 gfc_add_expr_to_block (&block, tmp);
4195 return gfc_finish_block (&block);
4199 /* Generate entry and exit code for g77 calling convention arrays. */
4202 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4212 gfc_get_backend_locus (&loc);
4213 gfc_set_backend_locus (&sym->declared_at);
4215 /* Descriptor type. */
4216 parm = sym->backend_decl;
4217 type = TREE_TYPE (parm);
4218 gcc_assert (GFC_ARRAY_TYPE_P (type));
4220 gfc_start_block (&block);
4222 if (sym->ts.type == BT_CHARACTER
4223 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4224 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4226 /* Evaluate the bounds of the array. */
4227 gfc_trans_array_bounds (type, sym, &offset, &block);
4229 /* Set the offset. */
4230 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4231 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4233 /* Set the pointer itself if we aren't using the parameter directly. */
4234 if (TREE_CODE (parm) != PARM_DECL)
4236 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4237 gfc_add_modify (&block, parm, tmp);
4239 stmt = gfc_finish_block (&block);
4241 gfc_set_backend_locus (&loc);
4243 gfc_start_block (&block);
4245 /* Add the initialization code to the start of the function. */
4247 if (sym->attr.optional || sym->attr.not_always_present)
4249 tmp = gfc_conv_expr_present (sym);
4250 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4253 gfc_add_expr_to_block (&block, stmt);
4254 gfc_add_expr_to_block (&block, body);
4256 return gfc_finish_block (&block);
4260 /* Modify the descriptor of an array parameter so that it has the
4261 correct lower bound. Also move the upper bound accordingly.
4262 If the array is not packed, it will be copied into a temporary.
4263 For each dimension we set the new lower and upper bounds. Then we copy the
4264 stride and calculate the offset for this dimension. We also work out
4265 what the stride of a packed array would be, and see it the two match.
4266 If the array need repacking, we set the stride to the values we just
4267 calculated, recalculate the offset and copy the array data.
4268 Code is also added to copy the data back at the end of the function.
4272 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4279 stmtblock_t cleanup;
4287 tree stride, stride2;
4297 /* Do nothing for pointer and allocatable arrays. */
4298 if (sym->attr.pointer || sym->attr.allocatable)
4301 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4302 return gfc_trans_g77_array (sym, body);
4304 gfc_get_backend_locus (&loc);
4305 gfc_set_backend_locus (&sym->declared_at);
4307 /* Descriptor type. */
4308 type = TREE_TYPE (tmpdesc);
4309 gcc_assert (GFC_ARRAY_TYPE_P (type));
4310 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4311 dumdesc = build_fold_indirect_ref (dumdesc);
4312 gfc_start_block (&block);
4314 if (sym->ts.type == BT_CHARACTER
4315 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4316 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4318 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4320 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4321 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4323 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4325 /* For non-constant shape arrays we only check if the first dimension
4326 is contiguous. Repacking higher dimensions wouldn't gain us
4327 anything as we still don't know the array stride. */
4328 partial = gfc_create_var (boolean_type_node, "partial");
4329 TREE_USED (partial) = 1;
4330 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4331 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4332 gfc_add_modify (&block, partial, tmp);
4336 partial = NULL_TREE;
4339 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4340 here, however I think it does the right thing. */
4343 /* Set the first stride. */
4344 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4345 stride = gfc_evaluate_now (stride, &block);
4347 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4348 stride, gfc_index_zero_node);
4349 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4350 gfc_index_one_node, stride);
4351 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4352 gfc_add_modify (&block, stride, tmp);
4354 /* Allow the user to disable array repacking. */
4355 stmt_unpacked = NULL_TREE;
4359 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4360 /* A library call to repack the array if necessary. */
4361 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4362 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4364 stride = gfc_index_one_node;
4366 if (gfc_option.warn_array_temp)
4367 gfc_warning ("Creating array temporary at %L", &loc);
4370 /* This is for the case where the array data is used directly without
4371 calling the repack function. */
4372 if (no_repack || partial != NULL_TREE)
4373 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4375 stmt_packed = NULL_TREE;
4377 /* Assign the data pointer. */
4378 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4380 /* Don't repack unknown shape arrays when the first stride is 1. */
4381 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4382 partial, stmt_packed, stmt_unpacked);
4385 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4386 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4388 offset = gfc_index_zero_node;
4389 size = gfc_index_one_node;
4391 /* Evaluate the bounds of the array. */
4392 for (n = 0; n < sym->as->rank; n++)
4394 if (checkparm || !sym->as->upper[n])
4396 /* Get the bounds of the actual parameter. */
4397 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4398 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4402 dubound = NULL_TREE;
4403 dlbound = NULL_TREE;
4406 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4407 if (!INTEGER_CST_P (lbound))
4409 gfc_init_se (&se, NULL);
4410 gfc_conv_expr_type (&se, sym->as->lower[n],
4411 gfc_array_index_type);
4412 gfc_add_block_to_block (&block, &se.pre);
4413 gfc_add_modify (&block, lbound, se.expr);
4416 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4417 /* Set the desired upper bound. */
4418 if (sym->as->upper[n])
4420 /* We know what we want the upper bound to be. */
4421 if (!INTEGER_CST_P (ubound))
4423 gfc_init_se (&se, NULL);
4424 gfc_conv_expr_type (&se, sym->as->upper[n],
4425 gfc_array_index_type);
4426 gfc_add_block_to_block (&block, &se.pre);
4427 gfc_add_modify (&block, ubound, se.expr);
4430 /* Check the sizes match. */
4433 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4436 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4438 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4440 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4441 asprintf (&msg, "%s for dimension %d of array '%s'",
4442 gfc_msg_bounds, n+1, sym->name);
4443 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4449 /* For assumed shape arrays move the upper bound by the same amount
4450 as the lower bound. */
4451 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4453 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4454 gfc_add_modify (&block, ubound, tmp);
4456 /* The offset of this dimension. offset = offset - lbound * stride. */
4457 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4458 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4460 /* The size of this dimension, and the stride of the next. */
4461 if (n + 1 < sym->as->rank)
4463 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4465 if (no_repack || partial != NULL_TREE)
4468 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4471 /* Figure out the stride if not a known constant. */
4472 if (!INTEGER_CST_P (stride))
4475 stmt_packed = NULL_TREE;
4478 /* Calculate stride = size * (ubound + 1 - lbound). */
4479 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4480 gfc_index_one_node, lbound);
4481 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4483 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4488 /* Assign the stride. */
4489 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4490 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4491 stmt_unpacked, stmt_packed);
4493 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4494 gfc_add_modify (&block, stride, tmp);
4499 stride = GFC_TYPE_ARRAY_SIZE (type);
4501 if (stride && !INTEGER_CST_P (stride))
4503 /* Calculate size = stride * (ubound + 1 - lbound). */
4504 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4505 gfc_index_one_node, lbound);
4506 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4508 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4509 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4510 gfc_add_modify (&block, stride, tmp);
4515 /* Set the offset. */
4516 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4517 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4519 gfc_trans_vla_type_sizes (sym, &block);
4521 stmt = gfc_finish_block (&block);
4523 gfc_start_block (&block);
4525 /* Only do the entry/initialization code if the arg is present. */
4526 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4527 optional_arg = (sym->attr.optional
4528 || (sym->ns->proc_name->attr.entry_master
4529 && sym->attr.dummy));
4532 tmp = gfc_conv_expr_present (sym);
4533 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4535 gfc_add_expr_to_block (&block, stmt);
4537 /* Add the main function body. */
4538 gfc_add_expr_to_block (&block, body);
4543 gfc_start_block (&cleanup);
4545 if (sym->attr.intent != INTENT_IN)
4547 /* Copy the data back. */
4548 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4549 gfc_add_expr_to_block (&cleanup, tmp);
4552 /* Free the temporary. */
4553 tmp = gfc_call_free (tmpdesc);
4554 gfc_add_expr_to_block (&cleanup, tmp);
4556 stmt = gfc_finish_block (&cleanup);
4558 /* Only do the cleanup if the array was repacked. */
4559 tmp = build_fold_indirect_ref (dumdesc);
4560 tmp = gfc_conv_descriptor_data_get (tmp);
4561 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4562 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4566 tmp = gfc_conv_expr_present (sym);
4567 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4569 gfc_add_expr_to_block (&block, stmt);
4571 /* We don't need to free any memory allocated by internal_pack as it will
4572 be freed at the end of the function by pop_context. */
4573 return gfc_finish_block (&block);
4577 /* Calculate the overall offset, including subreferences. */
4579 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4580 bool subref, gfc_expr *expr)
4590 /* If offset is NULL and this is not a subreferenced array, there is
4592 if (offset == NULL_TREE)
4595 offset = gfc_index_zero_node;
4600 tmp = gfc_conv_array_data (desc);
4601 tmp = build_fold_indirect_ref (tmp);
4602 tmp = gfc_build_array_ref (tmp, offset, NULL);
4604 /* Offset the data pointer for pointer assignments from arrays with
4605 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4608 /* Go past the array reference. */
4609 for (ref = expr->ref; ref; ref = ref->next)
4610 if (ref->type == REF_ARRAY &&
4611 ref->u.ar.type != AR_ELEMENT)
4617 /* Calculate the offset for each subsequent subreference. */
4618 for (; ref; ref = ref->next)
4623 field = ref->u.c.component->backend_decl;
4624 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4625 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4626 tmp, field, NULL_TREE);
4630 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4631 gfc_init_se (&start, NULL);
4632 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4633 gfc_add_block_to_block (block, &start.pre);
4634 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4638 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4639 && ref->u.ar.type == AR_ELEMENT);
4641 /* TODO - Add bounds checking. */
4642 stride = gfc_index_one_node;
4643 index = gfc_index_zero_node;
4644 for (n = 0; n < ref->u.ar.dimen; n++)
4649 /* Update the index. */
4650 gfc_init_se (&start, NULL);
4651 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4652 itmp = gfc_evaluate_now (start.expr, block);
4653 gfc_init_se (&start, NULL);
4654 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4655 jtmp = gfc_evaluate_now (start.expr, block);
4656 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4657 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4658 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4659 index = gfc_evaluate_now (index, block);
4661 /* Update the stride. */
4662 gfc_init_se (&start, NULL);
4663 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4664 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4665 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4666 gfc_index_one_node, itmp);
4667 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4668 stride = gfc_evaluate_now (stride, block);
4671 /* Apply the index to obtain the array element. */
4672 tmp = gfc_build_array_ref (tmp, index, NULL);
4682 /* Set the target data pointer. */
4683 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4684 gfc_conv_descriptor_data_set (block, parm, offset);
4688 /* gfc_conv_expr_descriptor needs the character length of elemental
4689 functions before the function is called so that the size of the
4690 temporary can be obtained. The only way to do this is to convert
4691 the expression, mapping onto the actual arguments. */
4693 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4695 gfc_interface_mapping mapping;
4696 gfc_formal_arglist *formal;
4697 gfc_actual_arglist *arg;
4700 formal = expr->symtree->n.sym->formal;
4701 arg = expr->value.function.actual;
4702 gfc_init_interface_mapping (&mapping);
4704 /* Set se = NULL in the calls to the interface mapping, to suppress any
4706 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4711 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4714 gfc_init_se (&tse, NULL);
4716 /* Build the expression for the character length and convert it. */
4717 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4719 gfc_add_block_to_block (&se->pre, &tse.pre);
4720 gfc_add_block_to_block (&se->post, &tse.post);
4721 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4722 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4723 build_int_cst (gfc_charlen_type_node, 0));
4724 expr->ts.cl->backend_decl = tse.expr;
4725 gfc_free_interface_mapping (&mapping);
4729 /* Convert an array for passing as an actual argument. Expressions and
4730 vector subscripts are evaluated and stored in a temporary, which is then
4731 passed. For whole arrays the descriptor is passed. For array sections
4732 a modified copy of the descriptor is passed, but using the original data.
4734 This function is also used for array pointer assignments, and there
4737 - se->want_pointer && !se->direct_byref
4738 EXPR is an actual argument. On exit, se->expr contains a
4739 pointer to the array descriptor.
4741 - !se->want_pointer && !se->direct_byref
4742 EXPR is an actual argument to an intrinsic function or the
4743 left-hand side of a pointer assignment. On exit, se->expr
4744 contains the descriptor for EXPR.
4746 - !se->want_pointer && se->direct_byref
4747 EXPR is the right-hand side of a pointer assignment and
4748 se->expr is the descriptor for the previously-evaluated
4749 left-hand side. The function creates an assignment from
4750 EXPR to se->expr. */
4753 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4766 bool subref_array_target = false;
4768 gcc_assert (ss != gfc_ss_terminator);
4770 /* Special case things we know we can pass easily. */
4771 switch (expr->expr_type)
4774 /* If we have a linear array section, we can pass it directly.
4775 Otherwise we need to copy it into a temporary. */
4777 /* Find the SS for the array section. */
4779 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4780 secss = secss->next;
4782 gcc_assert (secss != gfc_ss_terminator);
4783 info = &secss->data.info;
4785 /* Get the descriptor for the array. */
4786 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4787 desc = info->descriptor;
4789 subref_array_target = se->direct_byref && is_subref_array (expr);
4790 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4791 && !subref_array_target;
4795 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4797 /* Create a new descriptor if the array doesn't have one. */
4800 else if (info->ref->u.ar.type == AR_FULL)
4802 else if (se->direct_byref)
4805 full = gfc_full_array_ref_p (info->ref);
4809 if (se->direct_byref)
4811 /* Copy the descriptor for pointer assignments. */
4812 gfc_add_modify (&se->pre, se->expr, desc);
4814 /* Add any offsets from subreferences. */
4815 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4816 subref_array_target, expr);
4818 else if (se->want_pointer)
4820 /* We pass full arrays directly. This means that pointers and
4821 allocatable arrays should also work. */
4822 se->expr = build_fold_addr_expr (desc);
4829 if (expr->ts.type == BT_CHARACTER)
4830 se->string_length = gfc_get_expr_charlen (expr);
4837 /* A transformational function return value will be a temporary
4838 array descriptor. We still need to go through the scalarizer
4839 to create the descriptor. Elemental functions ar handled as
4840 arbitrary expressions, i.e. copy to a temporary. */
4842 /* Look for the SS for this function. */
4843 while (secss != gfc_ss_terminator
4844 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4845 secss = secss->next;
4847 if (se->direct_byref)
4849 gcc_assert (secss != gfc_ss_terminator);
4851 /* For pointer assignments pass the descriptor directly. */
4853 se->expr = build_fold_addr_expr (se->expr);
4854 gfc_conv_expr (se, expr);
4858 if (secss == gfc_ss_terminator)
4860 /* Elemental function. */
4862 if (expr->ts.type == BT_CHARACTER
4863 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4864 get_elemental_fcn_charlen (expr, se);
4870 /* Transformational function. */
4871 info = &secss->data.info;
4877 /* Constant array constructors don't need a temporary. */
4878 if (ss->type == GFC_SS_CONSTRUCTOR
4879 && expr->ts.type != BT_CHARACTER
4880 && gfc_constant_array_constructor_p (expr->value.constructor))
4883 info = &ss->data.info;
4895 /* Something complicated. Copy it into a temporary. */
4902 gfc_init_loopinfo (&loop);
4904 /* Associate the SS with the loop. */
4905 gfc_add_ss_to_loop (&loop, ss);
4907 /* Tell the scalarizer not to bother creating loop variables, etc. */
4909 loop.array_parameter = 1;
4911 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4912 gcc_assert (!se->direct_byref);
4914 /* Setup the scalarizing loops and bounds. */
4915 gfc_conv_ss_startstride (&loop);
4919 /* Tell the scalarizer to make a temporary. */
4920 loop.temp_ss = gfc_get_ss ();
4921 loop.temp_ss->type = GFC_SS_TEMP;
4922 loop.temp_ss->next = gfc_ss_terminator;
4924 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4925 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4927 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4929 if (expr->ts.type == BT_CHARACTER)
4930 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4932 loop.temp_ss->string_length = NULL;
4934 se->string_length = loop.temp_ss->string_length;
4935 loop.temp_ss->data.temp.dimen = loop.dimen;
4936 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4939 gfc_conv_loop_setup (&loop, & expr->where);
4943 /* Copy into a temporary and pass that. We don't need to copy the data
4944 back because expressions and vector subscripts must be INTENT_IN. */
4945 /* TODO: Optimize passing function return values. */
4949 /* Start the copying loops. */
4950 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4951 gfc_mark_ss_chain_used (ss, 1);
4952 gfc_start_scalarized_body (&loop, &block);
4954 /* Copy each data element. */
4955 gfc_init_se (&lse, NULL);
4956 gfc_copy_loopinfo_to_se (&lse, &loop);
4957 gfc_init_se (&rse, NULL);
4958 gfc_copy_loopinfo_to_se (&rse, &loop);
4960 lse.ss = loop.temp_ss;
4963 gfc_conv_scalarized_array_ref (&lse, NULL);
4964 if (expr->ts.type == BT_CHARACTER)
4966 gfc_conv_expr (&rse, expr);
4967 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4968 rse.expr = build_fold_indirect_ref (rse.expr);
4971 gfc_conv_expr_val (&rse, expr);
4973 gfc_add_block_to_block (&block, &rse.pre);
4974 gfc_add_block_to_block (&block, &lse.pre);
4976 lse.string_length = rse.string_length;
4977 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4978 expr->expr_type == EXPR_VARIABLE);
4979 gfc_add_expr_to_block (&block, tmp);
4981 /* Finish the copying loops. */
4982 gfc_trans_scalarizing_loops (&loop, &block);
4984 desc = loop.temp_ss->data.info.descriptor;
4986 gcc_assert (is_gimple_lvalue (desc));
4988 else if (expr->expr_type == EXPR_FUNCTION)
4990 desc = info->descriptor;
4991 se->string_length = ss->string_length;
4995 /* We pass sections without copying to a temporary. Make a new
4996 descriptor and point it at the section we want. The loop variable
4997 limits will be the limits of the section.
4998 A function may decide to repack the array to speed up access, but
4999 we're not bothered about that here. */
5008 /* Set the string_length for a character array. */
5009 if (expr->ts.type == BT_CHARACTER)
5010 se->string_length = gfc_get_expr_charlen (expr);
5012 desc = info->descriptor;
5013 gcc_assert (secss && secss != gfc_ss_terminator);
5014 if (se->direct_byref)
5016 /* For pointer assignments we fill in the destination. */
5018 parmtype = TREE_TYPE (parm);
5022 /* Otherwise make a new one. */
5023 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5024 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5025 loop.from, loop.to, 0,
5027 parm = gfc_create_var (parmtype, "parm");
5030 offset = gfc_index_zero_node;
5033 /* The following can be somewhat confusing. We have two
5034 descriptors, a new one and the original array.
5035 {parm, parmtype, dim} refer to the new one.
5036 {desc, type, n, secss, loop} refer to the original, which maybe
5037 a descriptorless array.
5038 The bounds of the scalarization are the bounds of the section.
5039 We don't have to worry about numeric overflows when calculating
5040 the offsets because all elements are within the array data. */
5042 /* Set the dtype. */
5043 tmp = gfc_conv_descriptor_dtype (parm);
5044 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5046 /* Set offset for assignments to pointer only to zero if it is not
5048 if (se->direct_byref
5049 && info->ref && info->ref->u.ar.type != AR_FULL)
5050 base = gfc_index_zero_node;
5051 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5052 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5056 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5057 for (n = 0; n < ndim; n++)
5059 stride = gfc_conv_array_stride (desc, n);
5061 /* Work out the offset. */
5063 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5065 gcc_assert (info->subscript[n]
5066 && info->subscript[n]->type == GFC_SS_SCALAR);
5067 start = info->subscript[n]->data.scalar.expr;
5071 /* Check we haven't somehow got out of sync. */
5072 gcc_assert (info->dim[dim] == n);
5074 /* Evaluate and remember the start of the section. */
5075 start = info->start[dim];
5076 stride = gfc_evaluate_now (stride, &loop.pre);
5079 tmp = gfc_conv_array_lbound (desc, n);
5080 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5082 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5083 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5086 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5088 /* For elemental dimensions, we only need the offset. */
5092 /* Vector subscripts need copying and are handled elsewhere. */
5094 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5096 /* Set the new lower bound. */
5097 from = loop.from[dim];
5100 /* If we have an array section or are assigning make sure that
5101 the lower bound is 1. References to the full
5102 array should otherwise keep the original bounds. */
5104 || info->ref->u.ar.type != AR_FULL)
5105 && !integer_onep (from))
5107 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5108 gfc_index_one_node, from);
5109 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5110 from = gfc_index_one_node;
5112 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5113 gfc_add_modify (&loop.pre, tmp, from);
5115 /* Set the new upper bound. */
5116 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5117 gfc_add_modify (&loop.pre, tmp, to);
5119 /* Multiply the stride by the section stride to get the
5121 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5122 stride, info->stride[dim]);
5124 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5126 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5129 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5131 tmp = gfc_conv_array_lbound (desc, n);
5132 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5133 tmp, loop.from[dim]);
5134 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5135 tmp, gfc_conv_array_stride (desc, n));
5136 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5140 /* Store the new stride. */
5141 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5142 gfc_add_modify (&loop.pre, tmp, stride);
5147 if (se->data_not_needed)
5148 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5150 /* Point the data pointer at the first element in the section. */
5151 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5152 subref_array_target, expr);
5154 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5155 && !se->data_not_needed)
5157 /* Set the offset. */
5158 tmp = gfc_conv_descriptor_offset (parm);
5159 gfc_add_modify (&loop.pre, tmp, base);
5163 /* Only the callee knows what the correct offset it, so just set
5165 tmp = gfc_conv_descriptor_offset (parm);
5166 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5171 if (!se->direct_byref)
5173 /* Get a pointer to the new descriptor. */
5174 if (se->want_pointer)
5175 se->expr = build_fold_addr_expr (desc);
5180 gfc_add_block_to_block (&se->pre, &loop.pre);
5181 gfc_add_block_to_block (&se->post, &loop.post);
5183 /* Cleanup the scalarizer. */
5184 gfc_cleanup_loop (&loop);
5188 /* Convert an array for passing as an actual parameter. */
5189 /* TODO: Optimize passing g77 arrays. */
5192 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5193 const gfc_symbol *fsym, const char *proc_name)
5197 tree tmp = NULL_TREE;
5199 tree parent = DECL_CONTEXT (current_function_decl);
5200 bool full_array_var, this_array_result;
5204 full_array_var = (expr->expr_type == EXPR_VARIABLE
5205 && expr->ref->u.ar.type == AR_FULL);
5206 sym = full_array_var ? expr->symtree->n.sym : NULL;
5208 /* The symbol should have an array specification. */
5209 gcc_assert (!sym || sym->as);
5211 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5213 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5214 expr->ts.cl->backend_decl = tmp;
5215 se->string_length = tmp;
5218 /* Is this the result of the enclosing procedure? */
5219 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5220 if (this_array_result
5221 && (sym->backend_decl != current_function_decl)
5222 && (sym->backend_decl != parent))
5223 this_array_result = false;
5225 /* Passing address of the array if it is not pointer or assumed-shape. */
5226 if (full_array_var && g77 && !this_array_result)
5228 tmp = gfc_get_symbol_decl (sym);
5230 if (sym->ts.type == BT_CHARACTER)
5231 se->string_length = sym->ts.cl->backend_decl;
5232 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5233 && !sym->attr.allocatable)
5235 /* Some variables are declared directly, others are declared as
5236 pointers and allocated on the heap. */
5237 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5240 se->expr = build_fold_addr_expr (tmp);
5243 if (sym->attr.allocatable)
5245 if (sym->attr.dummy || sym->attr.result)
5247 gfc_conv_expr_descriptor (se, expr, ss);
5248 se->expr = gfc_conv_array_data (se->expr);
5251 se->expr = gfc_conv_array_data (tmp);
5256 if (this_array_result)
5258 /* Result of the enclosing function. */
5259 gfc_conv_expr_descriptor (se, expr, ss);
5260 se->expr = build_fold_addr_expr (se->expr);
5262 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5263 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5264 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5270 /* Every other type of array. */
5271 se->want_pointer = 1;
5272 gfc_conv_expr_descriptor (se, expr, ss);
5276 /* Deallocate the allocatable components of structures that are
5278 if (expr->ts.type == BT_DERIVED
5279 && expr->ts.derived->attr.alloc_comp
5280 && expr->expr_type != EXPR_VARIABLE)
5282 tmp = build_fold_indirect_ref (se->expr);
5283 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5284 gfc_add_expr_to_block (&se->post, tmp);
5290 /* Repack the array. */
5292 if (gfc_option.warn_array_temp)
5295 gfc_warning ("Creating array temporary at %L for argument '%s'",
5296 &expr->where, fsym->name);
5298 gfc_warning ("Creating array temporary at %L", &expr->where);
5301 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5303 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5305 tmp = gfc_conv_expr_present (sym);
5306 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5307 fold_convert (TREE_TYPE (se->expr), ptr),
5308 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5311 ptr = gfc_evaluate_now (ptr, &se->pre);
5315 if (gfc_option.flag_check_array_temporaries)
5319 if (fsym && proc_name)
5320 asprintf (&msg, "An array temporary was created for argument "
5321 "'%s' of procedure '%s'", fsym->name, proc_name);
5323 asprintf (&msg, "An array temporary was created");
5325 tmp = build_fold_indirect_ref (desc);
5326 tmp = gfc_conv_array_data (tmp);
5327 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5328 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5330 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5331 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5332 gfc_conv_expr_present (sym), tmp);
5334 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5339 gfc_start_block (&block);
5341 /* Copy the data back. */
5342 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5344 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5345 gfc_add_expr_to_block (&block, tmp);
5348 /* Free the temporary. */
5349 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5350 gfc_add_expr_to_block (&block, tmp);
5352 stmt = gfc_finish_block (&block);
5354 gfc_init_block (&block);
5355 /* Only if it was repacked. This code needs to be executed before the
5356 loop cleanup code. */
5357 tmp = build_fold_indirect_ref (desc);
5358 tmp = gfc_conv_array_data (tmp);
5359 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5360 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5362 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5363 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5364 gfc_conv_expr_present (sym), tmp);
5366 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5368 gfc_add_expr_to_block (&block, tmp);
5369 gfc_add_block_to_block (&block, &se->post);
5371 gfc_init_block (&se->post);
5372 gfc_add_block_to_block (&se->post, &block);
5377 /* Generate code to deallocate an array, if it is allocated. */
5380 gfc_trans_dealloc_allocated (tree descriptor)
5386 gfc_start_block (&block);
5388 var = gfc_conv_descriptor_data_get (descriptor);
5391 /* Call array_deallocate with an int * present in the second argument.
5392 Although it is ignored here, it's presence ensures that arrays that
5393 are already deallocated are ignored. */
5394 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5395 gfc_add_expr_to_block (&block, tmp);
5397 /* Zero the data pointer. */
5398 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5399 var, build_int_cst (TREE_TYPE (var), 0));
5400 gfc_add_expr_to_block (&block, tmp);
5402 return gfc_finish_block (&block);
5406 /* This helper function calculates the size in words of a full array. */
5409 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5414 idx = gfc_rank_cst[rank - 1];
5415 nelems = gfc_conv_descriptor_ubound (decl, idx);
5416 tmp = gfc_conv_descriptor_lbound (decl, idx);
5417 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5418 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5419 tmp, gfc_index_one_node);
5420 tmp = gfc_evaluate_now (tmp, block);
5422 nelems = gfc_conv_descriptor_stride (decl, idx);
5423 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5424 return gfc_evaluate_now (tmp, block);
5428 /* Allocate dest to the same size as src, and copy src -> dest. */
5431 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5440 /* If the source is null, set the destination to null. */
5441 gfc_init_block (&block);
5442 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5443 null_data = gfc_finish_block (&block);
5445 gfc_init_block (&block);
5447 nelems = get_full_array_size (&block, src, rank);
5448 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5449 fold_convert (gfc_array_index_type,
5450 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5452 /* Allocate memory to the destination. */
5453 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5455 gfc_conv_descriptor_data_set (&block, dest, tmp);
5457 /* We know the temporary and the value will be the same length,
5458 so can use memcpy. */
5459 tmp = built_in_decls[BUILT_IN_MEMCPY];
5460 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5461 gfc_conv_descriptor_data_get (src), size);
5462 gfc_add_expr_to_block (&block, tmp);
5463 tmp = gfc_finish_block (&block);
5465 /* Null the destination if the source is null; otherwise do
5466 the allocate and copy. */
5467 null_cond = gfc_conv_descriptor_data_get (src);
5468 null_cond = convert (pvoid_type_node, null_cond);
5469 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5470 null_cond, null_pointer_node);
5471 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5475 /* Recursively traverse an object of derived type, generating code to
5476 deallocate, nullify or copy allocatable components. This is the work horse
5477 function for the functions named in this enum. */
5479 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5482 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5483 tree dest, int rank, int purpose)
5487 stmtblock_t fnblock;
5488 stmtblock_t loopbody;
5498 tree null_cond = NULL_TREE;
5500 gfc_init_block (&fnblock);
5502 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5503 decl = build_fold_indirect_ref (decl);
5505 /* If this an array of derived types with allocatable components
5506 build a loop and recursively call this function. */
5507 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5508 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5510 tmp = gfc_conv_array_data (decl);
5511 var = build_fold_indirect_ref (tmp);
5513 /* Get the number of elements - 1 and set the counter. */
5514 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5516 /* Use the descriptor for an allocatable array. Since this
5517 is a full array reference, we only need the descriptor
5518 information from dimension = rank. */
5519 tmp = get_full_array_size (&fnblock, decl, rank);
5520 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5521 tmp, gfc_index_one_node);
5523 null_cond = gfc_conv_descriptor_data_get (decl);
5524 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5525 build_int_cst (TREE_TYPE (null_cond), 0));
5529 /* Otherwise use the TYPE_DOMAIN information. */
5530 tmp = array_type_nelts (TREE_TYPE (decl));
5531 tmp = fold_convert (gfc_array_index_type, tmp);
5534 /* Remember that this is, in fact, the no. of elements - 1. */
5535 nelems = gfc_evaluate_now (tmp, &fnblock);
5536 index = gfc_create_var (gfc_array_index_type, "S");
5538 /* Build the body of the loop. */
5539 gfc_init_block (&loopbody);
5541 vref = gfc_build_array_ref (var, index, NULL);
5543 if (purpose == COPY_ALLOC_COMP)
5545 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5546 gfc_add_expr_to_block (&fnblock, tmp);
5548 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5549 dref = gfc_build_array_ref (tmp, index, NULL);
5550 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5553 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5555 gfc_add_expr_to_block (&loopbody, tmp);
5557 /* Build the loop and return. */
5558 gfc_init_loopinfo (&loop);
5560 loop.from[0] = gfc_index_zero_node;
5561 loop.loopvar[0] = index;
5562 loop.to[0] = nelems;
5563 gfc_trans_scalarizing_loops (&loop, &loopbody);
5564 gfc_add_block_to_block (&fnblock, &loop.pre);
5566 tmp = gfc_finish_block (&fnblock);
5567 if (null_cond != NULL_TREE)
5568 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5573 /* Otherwise, act on the components or recursively call self to
5574 act on a chain of components. */
5575 for (c = der_type->components; c; c = c->next)
5577 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5578 && c->ts.derived->attr.alloc_comp;
5579 cdecl = c->backend_decl;
5580 ctype = TREE_TYPE (cdecl);
5584 case DEALLOCATE_ALLOC_COMP:
5585 /* Do not deallocate the components of ultimate pointer
5587 if (cmp_has_alloc_comps && !c->attr.pointer)
5589 comp = fold_build3 (COMPONENT_REF, ctype,
5590 decl, cdecl, NULL_TREE);
5591 rank = c->as ? c->as->rank : 0;
5592 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5594 gfc_add_expr_to_block (&fnblock, tmp);
5597 if (c->attr.allocatable)
5599 comp = fold_build3 (COMPONENT_REF, ctype,
5600 decl, cdecl, NULL_TREE);
5601 tmp = gfc_trans_dealloc_allocated (comp);
5602 gfc_add_expr_to_block (&fnblock, tmp);
5606 case NULLIFY_ALLOC_COMP:
5607 if (c->attr.pointer)
5609 else if (c->attr.allocatable)
5611 comp = fold_build3 (COMPONENT_REF, ctype,
5612 decl, cdecl, NULL_TREE);
5613 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5615 else if (cmp_has_alloc_comps)
5617 comp = fold_build3 (COMPONENT_REF, ctype,
5618 decl, cdecl, NULL_TREE);
5619 rank = c->as ? c->as->rank : 0;
5620 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5622 gfc_add_expr_to_block (&fnblock, tmp);
5626 case COPY_ALLOC_COMP:
5627 if (c->attr.pointer)
5630 /* We need source and destination components. */
5631 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5632 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5633 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5635 if (c->attr.allocatable && !cmp_has_alloc_comps)
5637 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5638 gfc_add_expr_to_block (&fnblock, tmp);
5641 if (cmp_has_alloc_comps)
5643 rank = c->as ? c->as->rank : 0;
5644 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5645 gfc_add_modify (&fnblock, dcmp, tmp);
5646 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5648 gfc_add_expr_to_block (&fnblock, tmp);
5658 return gfc_finish_block (&fnblock);
5661 /* Recursively traverse an object of derived type, generating code to
5662 nullify allocatable components. */
5665 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5667 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5668 NULLIFY_ALLOC_COMP);
5672 /* Recursively traverse an object of derived type, generating code to
5673 deallocate allocatable components. */
5676 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5678 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5679 DEALLOCATE_ALLOC_COMP);
5683 /* Recursively traverse an object of derived type, generating code to
5684 copy its allocatable components. */
5687 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5689 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5693 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5694 Do likewise, recursively if necessary, with the allocatable components of
5698 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5703 stmtblock_t fnblock;
5706 bool sym_has_alloc_comp;
5708 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5709 && sym->ts.derived->attr.alloc_comp;
5711 /* Make sure the frontend gets these right. */
5712 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5713 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5714 "allocatable attribute or derived type without allocatable "
5717 gfc_init_block (&fnblock);
5719 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5720 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5722 if (sym->ts.type == BT_CHARACTER
5723 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5725 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5726 gfc_trans_vla_type_sizes (sym, &fnblock);
5729 /* Dummy and use associated variables don't need anything special. */
5730 if (sym->attr.dummy || sym->attr.use_assoc)
5732 gfc_add_expr_to_block (&fnblock, body);
5734 return gfc_finish_block (&fnblock);
5737 gfc_get_backend_locus (&loc);
5738 gfc_set_backend_locus (&sym->declared_at);
5739 descriptor = sym->backend_decl;
5741 /* Although static, derived types with default initializers and
5742 allocatable components must not be nulled wholesale; instead they
5743 are treated component by component. */
5744 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5746 /* SAVEd variables are not freed on exit. */
5747 gfc_trans_static_array_pointer (sym);
5751 /* Get the descriptor type. */
5752 type = TREE_TYPE (sym->backend_decl);
5754 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5756 if (!sym->attr.save)
5758 rank = sym->as ? sym->as->rank : 0;
5759 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5760 gfc_add_expr_to_block (&fnblock, tmp);
5763 tmp = gfc_init_default_dt (sym, NULL);
5764 gfc_add_expr_to_block (&fnblock, tmp);
5768 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5770 /* If the backend_decl is not a descriptor, we must have a pointer
5772 descriptor = build_fold_indirect_ref (sym->backend_decl);
5773 type = TREE_TYPE (descriptor);
5776 /* NULLIFY the data pointer. */
5777 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5778 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5780 gfc_add_expr_to_block (&fnblock, body);
5782 gfc_set_backend_locus (&loc);
5784 /* Allocatable arrays need to be freed when they go out of scope.
5785 The allocatable components of pointers must not be touched. */
5786 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5787 && !sym->attr.pointer && !sym->attr.save)
5790 rank = sym->as ? sym->as->rank : 0;
5791 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5792 gfc_add_expr_to_block (&fnblock, tmp);
5795 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5797 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5798 gfc_add_expr_to_block (&fnblock, tmp);
5801 return gfc_finish_block (&fnblock);
5804 /************ Expression Walking Functions ******************/
5806 /* Walk a variable reference.
5808 Possible extension - multiple component subscripts.
5809 x(:,:) = foo%a(:)%b(:)
5811 forall (i=..., j=...)
5812 x(i,j) = foo%a(j)%b(i)
5814 This adds a fair amount of complexity because you need to deal with more
5815 than one ref. Maybe handle in a similar manner to vector subscripts.
5816 Maybe not worth the effort. */
5820 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5828 for (ref = expr->ref; ref; ref = ref->next)
5829 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5832 for (; ref; ref = ref->next)
5834 if (ref->type == REF_SUBSTRING)
5836 newss = gfc_get_ss ();
5837 newss->type = GFC_SS_SCALAR;
5838 newss->expr = ref->u.ss.start;
5842 newss = gfc_get_ss ();
5843 newss->type = GFC_SS_SCALAR;
5844 newss->expr = ref->u.ss.end;
5849 /* We're only interested in array sections from now on. */
5850 if (ref->type != REF_ARRAY)
5857 for (n = 0; n < ar->dimen; n++)
5859 newss = gfc_get_ss ();
5860 newss->type = GFC_SS_SCALAR;
5861 newss->expr = ar->start[n];
5868 newss = gfc_get_ss ();
5869 newss->type = GFC_SS_SECTION;
5872 newss->data.info.dimen = ar->as->rank;
5873 newss->data.info.ref = ref;
5875 /* Make sure array is the same as array(:,:), this way
5876 we don't need to special case all the time. */
5877 ar->dimen = ar->as->rank;
5878 for (n = 0; n < ar->dimen; n++)
5880 newss->data.info.dim[n] = n;
5881 ar->dimen_type[n] = DIMEN_RANGE;
5883 gcc_assert (ar->start[n] == NULL);
5884 gcc_assert (ar->end[n] == NULL);
5885 gcc_assert (ar->stride[n] == NULL);
5891 newss = gfc_get_ss ();
5892 newss->type = GFC_SS_SECTION;
5895 newss->data.info.dimen = 0;
5896 newss->data.info.ref = ref;
5900 /* We add SS chains for all the subscripts in the section. */
5901 for (n = 0; n < ar->dimen; n++)
5905 switch (ar->dimen_type[n])
5908 /* Add SS for elemental (scalar) subscripts. */
5909 gcc_assert (ar->start[n]);
5910 indexss = gfc_get_ss ();
5911 indexss->type = GFC_SS_SCALAR;
5912 indexss->expr = ar->start[n];
5913 indexss->next = gfc_ss_terminator;
5914 indexss->loop_chain = gfc_ss_terminator;
5915 newss->data.info.subscript[n] = indexss;
5919 /* We don't add anything for sections, just remember this
5920 dimension for later. */
5921 newss->data.info.dim[newss->data.info.dimen] = n;
5922 newss->data.info.dimen++;
5926 /* Create a GFC_SS_VECTOR index in which we can store
5927 the vector's descriptor. */
5928 indexss = gfc_get_ss ();
5929 indexss->type = GFC_SS_VECTOR;
5930 indexss->expr = ar->start[n];
5931 indexss->next = gfc_ss_terminator;
5932 indexss->loop_chain = gfc_ss_terminator;
5933 newss->data.info.subscript[n] = indexss;
5934 newss->data.info.dim[newss->data.info.dimen] = n;
5935 newss->data.info.dimen++;
5939 /* We should know what sort of section it is by now. */
5943 /* We should have at least one non-elemental dimension. */
5944 gcc_assert (newss->data.info.dimen > 0);
5949 /* We should know what sort of section it is by now. */
5958 /* Walk an expression operator. If only one operand of a binary expression is
5959 scalar, we must also add the scalar term to the SS chain. */
5962 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5968 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5969 if (expr->value.op.op2 == NULL)
5972 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5974 /* All operands are scalar. Pass back and let the caller deal with it. */
5978 /* All operands require scalarization. */
5979 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5982 /* One of the operands needs scalarization, the other is scalar.
5983 Create a gfc_ss for the scalar expression. */
5984 newss = gfc_get_ss ();
5985 newss->type = GFC_SS_SCALAR;
5988 /* First operand is scalar. We build the chain in reverse order, so
5989 add the scalar SS after the second operand. */
5991 while (head && head->next != ss)
5993 /* Check we haven't somehow broken the chain. */
5997 newss->expr = expr->value.op.op1;
5999 else /* head2 == head */
6001 gcc_assert (head2 == head);
6002 /* Second operand is scalar. */
6003 newss->next = head2;
6005 newss->expr = expr->value.op.op2;
6012 /* Reverse a SS chain. */
6015 gfc_reverse_ss (gfc_ss * ss)
6020 gcc_assert (ss != NULL);
6022 head = gfc_ss_terminator;
6023 while (ss != gfc_ss_terminator)
6026 /* Check we didn't somehow break the chain. */
6027 gcc_assert (next != NULL);
6037 /* Walk the arguments of an elemental function. */
6040 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6048 head = gfc_ss_terminator;
6051 for (; arg; arg = arg->next)
6056 newss = gfc_walk_subexpr (head, arg->expr);
6059 /* Scalar argument. */
6060 newss = gfc_get_ss ();
6062 newss->expr = arg->expr;
6072 while (tail->next != gfc_ss_terminator)
6079 /* If all the arguments are scalar we don't need the argument SS. */
6080 gfc_free_ss_chain (head);
6085 /* Add it onto the existing chain. */
6091 /* Walk a function call. Scalar functions are passed back, and taken out of
6092 scalarization loops. For elemental functions we walk their arguments.
6093 The result of functions returning arrays is stored in a temporary outside
6094 the loop, so that the function is only called once. Hence we do not need
6095 to walk their arguments. */
6098 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6101 gfc_intrinsic_sym *isym;
6104 isym = expr->value.function.isym;
6106 /* Handle intrinsic functions separately. */
6108 return gfc_walk_intrinsic_function (ss, expr, isym);
6110 sym = expr->value.function.esym;
6112 sym = expr->symtree->n.sym;
6114 /* A function that returns arrays. */
6115 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6117 newss = gfc_get_ss ();
6118 newss->type = GFC_SS_FUNCTION;
6121 newss->data.info.dimen = expr->rank;
6125 /* Walk the parameters of an elemental function. For now we always pass
6127 if (sym->attr.elemental)
6128 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6131 /* Scalar functions are OK as these are evaluated outside the scalarization
6132 loop. Pass back and let the caller deal with it. */
6137 /* An array temporary is constructed for array constructors. */
6140 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6145 newss = gfc_get_ss ();
6146 newss->type = GFC_SS_CONSTRUCTOR;
6149 newss->data.info.dimen = expr->rank;
6150 for (n = 0; n < expr->rank; n++)
6151 newss->data.info.dim[n] = n;
6157 /* Walk an expression. Add walked expressions to the head of the SS chain.
6158 A wholly scalar expression will not be added. */
6161 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6165 switch (expr->expr_type)
6168 head = gfc_walk_variable_expr (ss, expr);
6172 head = gfc_walk_op_expr (ss, expr);
6176 head = gfc_walk_function_expr (ss, expr);
6181 case EXPR_STRUCTURE:
6182 /* Pass back and let the caller deal with it. */
6186 head = gfc_walk_array_constructor (ss, expr);
6189 case EXPR_SUBSTRING:
6190 /* Pass back and let the caller deal with it. */
6194 internal_error ("bad expression type during walk (%d)",
6201 /* Entry point for expression walking.
6202 A return value equal to the passed chain means this is
6203 a scalar expression. It is up to the caller to take whatever action is
6204 necessary to translate these. */
6207 gfc_walk_expr (gfc_expr * expr)
6211 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6212 return gfc_reverse_ss (res);