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