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,
1186 tree shadow_loopvar = NULL_TREE;
1187 gfc_saved_var saved_loopvar;
1190 for (; c; c = c->next)
1192 /* If this is an iterator or an array, the offset must be a variable. */
1193 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1194 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1196 /* Shadowing the iterator avoids changing its value and saves us from
1197 keeping track of it. Further, it makes sure that there's always a
1198 backend-decl for the symbol, even if there wasn't one before,
1199 e.g. in the case of an iterator that appears in a specification
1200 expression in an interface mapping. */
1203 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1204 tree type = gfc_typenode_for_spec (&sym->ts);
1206 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1207 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1210 gfc_start_block (&body);
1212 if (c->expr->expr_type == EXPR_ARRAY)
1214 /* Array constructors can be nested. */
1215 gfc_trans_array_constructor_value (&body, type, desc,
1216 c->expr->value.constructor,
1217 poffset, offsetvar, dynamic);
1219 else if (c->expr->rank > 0)
1221 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1222 poffset, offsetvar, dynamic);
1226 /* This code really upsets the gimplifier so don't bother for now. */
1233 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1240 /* Scalar values. */
1241 gfc_init_se (&se, NULL);
1242 gfc_trans_array_ctor_element (&body, desc, *poffset,
1245 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1246 *poffset, gfc_index_one_node);
1250 /* Collect multiple scalar constants into a constructor. */
1255 HOST_WIDE_INT idx = 0;
1259 /* Count the number of consecutive scalar constants. */
1260 while (p && !(p->iterator
1261 || p->expr->expr_type != EXPR_CONSTANT))
1263 gfc_init_se (&se, NULL);
1264 gfc_conv_constant (&se, p->expr);
1266 /* For constant character array constructors we build
1267 an array of pointers. */
1268 if (p->expr->ts.type == BT_CHARACTER
1269 && POINTER_TYPE_P (type))
1270 se.expr = gfc_build_addr_expr
1271 (gfc_get_pchar_type (p->expr->ts.kind),
1274 list = tree_cons (build_int_cst (gfc_array_index_type,
1275 idx++), se.expr, list);
1280 bound = build_int_cst (NULL_TREE, n - 1);
1281 /* Create an array type to hold them. */
1282 tmptype = build_range_type (gfc_array_index_type,
1283 gfc_index_zero_node, bound);
1284 tmptype = build_array_type (type, tmptype);
1286 init = build_constructor_from_list (tmptype, nreverse (list));
1287 TREE_CONSTANT (init) = 1;
1288 TREE_STATIC (init) = 1;
1289 /* Create a static variable to hold the data. */
1290 tmp = gfc_create_var (tmptype, "data");
1291 TREE_STATIC (tmp) = 1;
1292 TREE_CONSTANT (tmp) = 1;
1293 TREE_READONLY (tmp) = 1;
1294 DECL_INITIAL (tmp) = init;
1297 /* Use BUILTIN_MEMCPY to assign the values. */
1298 tmp = gfc_conv_descriptor_data_get (desc);
1299 tmp = build_fold_indirect_ref (tmp);
1300 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1301 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1302 init = gfc_build_addr_expr (NULL_TREE, init);
1304 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1305 bound = build_int_cst (NULL_TREE, n * size);
1306 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1308 gfc_add_expr_to_block (&body, tmp);
1310 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1312 build_int_cst (gfc_array_index_type, n));
1314 if (!INTEGER_CST_P (*poffset))
1316 gfc_add_modify (&body, *offsetvar, *poffset);
1317 *poffset = *offsetvar;
1321 /* The frontend should already have done any expansions
1325 /* Pass the code as is. */
1326 tmp = gfc_finish_block (&body);
1327 gfc_add_expr_to_block (pblock, tmp);
1331 /* Build the implied do-loop. */
1332 stmtblock_t implied_do_block;
1340 loopbody = gfc_finish_block (&body);
1342 /* Create a new block that holds the implied-do loop. A temporary
1343 loop-variable is used. */
1344 gfc_start_block(&implied_do_block);
1346 /* Initialize the loop. */
1347 gfc_init_se (&se, NULL);
1348 gfc_conv_expr_val (&se, c->iterator->start);
1349 gfc_add_block_to_block (&implied_do_block, &se.pre);
1350 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1352 gfc_init_se (&se, NULL);
1353 gfc_conv_expr_val (&se, c->iterator->end);
1354 gfc_add_block_to_block (&implied_do_block, &se.pre);
1355 end = gfc_evaluate_now (se.expr, &implied_do_block);
1357 gfc_init_se (&se, NULL);
1358 gfc_conv_expr_val (&se, c->iterator->step);
1359 gfc_add_block_to_block (&implied_do_block, &se.pre);
1360 step = gfc_evaluate_now (se.expr, &implied_do_block);
1362 /* If this array expands dynamically, and the number of iterations
1363 is not constant, we won't have allocated space for the static
1364 part of C->EXPR's size. Do that now. */
1365 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1367 /* Get the number of iterations. */
1368 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1370 /* Get the static part of C->EXPR's size. */
1371 gfc_get_array_constructor_element_size (&size, c->expr);
1372 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1374 /* Grow the array by TMP * TMP2 elements. */
1375 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1376 gfc_grow_array (&implied_do_block, desc, tmp);
1379 /* Generate the loop body. */
1380 exit_label = gfc_build_label_decl (NULL_TREE);
1381 gfc_start_block (&body);
1383 /* Generate the exit condition. Depending on the sign of
1384 the step variable we have to generate the correct
1386 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1387 build_int_cst (TREE_TYPE (step), 0));
1388 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1389 fold_build2 (GT_EXPR, boolean_type_node,
1390 shadow_loopvar, end),
1391 fold_build2 (LT_EXPR, boolean_type_node,
1392 shadow_loopvar, end));
1393 tmp = build1_v (GOTO_EXPR, exit_label);
1394 TREE_USED (exit_label) = 1;
1395 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1396 gfc_add_expr_to_block (&body, tmp);
1398 /* The main loop body. */
1399 gfc_add_expr_to_block (&body, loopbody);
1401 /* Increase loop variable by step. */
1402 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1403 gfc_add_modify (&body, shadow_loopvar, tmp);
1405 /* Finish the loop. */
1406 tmp = gfc_finish_block (&body);
1407 tmp = build1_v (LOOP_EXPR, tmp);
1408 gfc_add_expr_to_block (&implied_do_block, tmp);
1410 /* Add the exit label. */
1411 tmp = build1_v (LABEL_EXPR, exit_label);
1412 gfc_add_expr_to_block (&implied_do_block, tmp);
1414 /* Finishe the implied-do loop. */
1415 tmp = gfc_finish_block(&implied_do_block);
1416 gfc_add_expr_to_block(pblock, tmp);
1418 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1425 /* Figure out the string length of a variable reference expression.
1426 Used by get_array_ctor_strlen. */
1429 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1435 /* Don't bother if we already know the length is a constant. */
1436 if (*len && INTEGER_CST_P (*len))
1439 ts = &expr->symtree->n.sym->ts;
1440 for (ref = expr->ref; ref; ref = ref->next)
1445 /* Array references don't change the string length. */
1449 /* Use the length of the component. */
1450 ts = &ref->u.c.component->ts;
1454 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1455 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1457 mpz_init_set_ui (char_len, 1);
1458 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1459 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1460 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1461 *len = convert (gfc_charlen_type_node, *len);
1462 mpz_clear (char_len);
1466 /* TODO: Substrings are tricky because we can't evaluate the
1467 expression more than once. For now we just give up, and hope
1468 we can figure it out elsewhere. */
1473 *len = ts->cl->backend_decl;
1477 /* A catch-all to obtain the string length for anything that is not a
1478 constant, array or variable. */
1480 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1485 /* Don't bother if we already know the length is a constant. */
1486 if (*len && INTEGER_CST_P (*len))
1489 if (!e->ref && e->ts.cl && e->ts.cl->length
1490 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1493 gfc_conv_const_charlen (e->ts.cl);
1494 *len = e->ts.cl->backend_decl;
1498 /* Otherwise, be brutal even if inefficient. */
1499 ss = gfc_walk_expr (e);
1500 gfc_init_se (&se, NULL);
1502 /* No function call, in case of side effects. */
1503 se.no_function_call = 1;
1504 if (ss == gfc_ss_terminator)
1505 gfc_conv_expr (&se, e);
1507 gfc_conv_expr_descriptor (&se, e, ss);
1509 /* Fix the value. */
1510 *len = gfc_evaluate_now (se.string_length, &se.pre);
1512 gfc_add_block_to_block (block, &se.pre);
1513 gfc_add_block_to_block (block, &se.post);
1515 e->ts.cl->backend_decl = *len;
1520 /* Figure out the string length of a character array constructor.
1521 If len is NULL, don't calculate the length; this happens for recursive calls
1522 when a sub-array-constructor is an element but not at the first position,
1523 so when we're not interested in the length.
1524 Returns TRUE if all elements are character constants. */
1527 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1536 *len = build_int_cstu (gfc_charlen_type_node, 0);
1540 /* Loop over all constructor elements to find out is_const, but in len we
1541 want to store the length of the first, not the last, element. We can
1542 of course exit the loop as soon as is_const is found to be false. */
1543 for (; c && is_const; c = c->next)
1545 switch (c->expr->expr_type)
1548 if (len && !(*len && INTEGER_CST_P (*len)))
1549 *len = build_int_cstu (gfc_charlen_type_node,
1550 c->expr->value.character.length);
1554 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1561 get_array_ctor_var_strlen (c->expr, len);
1567 get_array_ctor_all_strlen (block, c->expr, len);
1571 /* After the first iteration, we don't want the length modified. */
1578 /* Check whether the array constructor C consists entirely of constant
1579 elements, and if so returns the number of those elements, otherwise
1580 return zero. Note, an empty or NULL array constructor returns zero. */
1582 unsigned HOST_WIDE_INT
1583 gfc_constant_array_constructor_p (gfc_constructor * c)
1585 unsigned HOST_WIDE_INT nelem = 0;
1590 || c->expr->rank > 0
1591 || c->expr->expr_type != EXPR_CONSTANT)
1600 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1601 and the tree type of it's elements, TYPE, return a static constant
1602 variable that is compile-time initialized. */
1605 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1607 tree tmptype, list, init, tmp;
1608 HOST_WIDE_INT nelem;
1614 /* First traverse the constructor list, converting the constants
1615 to tree to build an initializer. */
1618 c = expr->value.constructor;
1621 gfc_init_se (&se, NULL);
1622 gfc_conv_constant (&se, c->expr);
1623 if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
1624 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1626 list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1632 /* Next determine the tree type for the array. We use the gfortran
1633 front-end's gfc_get_nodesc_array_type in order to create a suitable
1634 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1636 memset (&as, 0, sizeof (gfc_array_spec));
1638 as.rank = expr->rank;
1639 as.type = AS_EXPLICIT;
1642 as.lower[0] = gfc_int_expr (0);
1643 as.upper[0] = gfc_int_expr (nelem - 1);
1646 for (i = 0; i < expr->rank; i++)
1648 int tmp = (int) mpz_get_si (expr->shape[i]);
1649 as.lower[i] = gfc_int_expr (0);
1650 as.upper[i] = gfc_int_expr (tmp - 1);
1653 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1655 init = build_constructor_from_list (tmptype, nreverse (list));
1657 TREE_CONSTANT (init) = 1;
1658 TREE_STATIC (init) = 1;
1660 tmp = gfc_create_var (tmptype, "A");
1661 TREE_STATIC (tmp) = 1;
1662 TREE_CONSTANT (tmp) = 1;
1663 TREE_READONLY (tmp) = 1;
1664 DECL_INITIAL (tmp) = init;
1670 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1671 This mostly initializes the scalarizer state info structure with the
1672 appropriate values to directly use the array created by the function
1673 gfc_build_constant_array_constructor. */
1676 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1677 gfc_ss * ss, tree type)
1683 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1685 info = &ss->data.info;
1687 info->descriptor = tmp;
1688 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1689 info->offset = gfc_index_zero_node;
1691 for (i = 0; i < info->dimen; i++)
1693 info->delta[i] = gfc_index_zero_node;
1694 info->start[i] = gfc_index_zero_node;
1695 info->end[i] = gfc_index_zero_node;
1696 info->stride[i] = gfc_index_one_node;
1700 if (info->dimen > loop->temp_dim)
1701 loop->temp_dim = info->dimen;
1704 /* Helper routine of gfc_trans_array_constructor to determine if the
1705 bounds of the loop specified by LOOP are constant and simple enough
1706 to use with gfc_trans_constant_array_constructor. Returns the
1707 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1710 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1712 tree size = gfc_index_one_node;
1716 for (i = 0; i < loop->dimen; i++)
1718 /* If the bounds aren't constant, return NULL_TREE. */
1719 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1721 if (!integer_zerop (loop->from[i]))
1723 /* Only allow nonzero "from" in one-dimensional arrays. */
1724 if (loop->dimen != 1)
1726 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1727 loop->to[i], loop->from[i]);
1731 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1732 tmp, gfc_index_one_node);
1733 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1740 /* Array constructors are handled by constructing a temporary, then using that
1741 within the scalarization loop. This is not optimal, but seems by far the
1745 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1753 bool old_first_len, old_typespec_chararray_ctor;
1754 tree old_first_len_val;
1756 /* Save the old values for nested checking. */
1757 old_first_len = first_len;
1758 old_first_len_val = first_len_val;
1759 old_typespec_chararray_ctor = typespec_chararray_ctor;
1761 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1762 typespec was given for the array constructor. */
1763 typespec_chararray_ctor = (ss->expr->ts.cl
1764 && ss->expr->ts.cl->length_from_typespec);
1766 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1767 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1769 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1773 ss->data.info.dimen = loop->dimen;
1775 c = ss->expr->value.constructor;
1776 if (ss->expr->ts.type == BT_CHARACTER)
1780 /* get_array_ctor_strlen walks the elements of the constructor, if a
1781 typespec was given, we already know the string length and want the one
1783 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1784 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1788 const_string = false;
1789 gfc_init_se (&length_se, NULL);
1790 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1791 gfc_charlen_type_node);
1792 ss->string_length = length_se.expr;
1793 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1794 gfc_add_block_to_block (&loop->post, &length_se.post);
1797 const_string = get_array_ctor_strlen (&loop->pre, c,
1798 &ss->string_length);
1800 /* Complex character array constructors should have been taken care of
1801 and not end up here. */
1802 gcc_assert (ss->string_length);
1804 ss->expr->ts.cl->backend_decl = ss->string_length;
1806 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1808 type = build_pointer_type (type);
1811 type = gfc_typenode_for_spec (&ss->expr->ts);
1813 /* See if the constructor determines the loop bounds. */
1816 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1818 /* We have a multidimensional parameter. */
1820 for (n = 0; n < ss->expr->rank; n++)
1822 loop->from[n] = gfc_index_zero_node;
1823 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1824 gfc_index_integer_kind);
1825 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1826 loop->to[n], gfc_index_one_node);
1830 if (loop->to[0] == NULL_TREE)
1834 /* We should have a 1-dimensional, zero-based loop. */
1835 gcc_assert (loop->dimen == 1);
1836 gcc_assert (integer_zerop (loop->from[0]));
1838 /* Split the constructor size into a static part and a dynamic part.
1839 Allocate the static size up-front and record whether the dynamic
1840 size might be nonzero. */
1842 dynamic = gfc_get_array_constructor_size (&size, c);
1843 mpz_sub_ui (size, size, 1);
1844 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1848 /* Special case constant array constructors. */
1851 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1854 tree size = constant_array_constructor_loop_size (loop);
1855 if (size && compare_tree_int (size, nelem) == 0)
1857 gfc_trans_constant_array_constructor (loop, ss, type);
1863 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1864 type, NULL_TREE, dynamic, true, false, where);
1866 desc = ss->data.info.descriptor;
1867 offset = gfc_index_zero_node;
1868 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1869 TREE_NO_WARNING (offsetvar) = 1;
1870 TREE_USED (offsetvar) = 0;
1871 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1872 &offset, &offsetvar, dynamic);
1874 /* If the array grows dynamically, the upper bound of the loop variable
1875 is determined by the array's final upper bound. */
1877 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1879 if (TREE_USED (offsetvar))
1880 pushdecl (offsetvar);
1882 gcc_assert (INTEGER_CST_P (offset));
1884 /* Disable bound checking for now because it's probably broken. */
1885 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1892 /* Restore old values of globals. */
1893 first_len = old_first_len;
1894 first_len_val = old_first_len_val;
1895 typespec_chararray_ctor = old_typespec_chararray_ctor;
1899 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1900 called after evaluating all of INFO's vector dimensions. Go through
1901 each such vector dimension and see if we can now fill in any missing
1905 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1914 for (n = 0; n < loop->dimen; n++)
1917 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1918 && loop->to[n] == NULL)
1920 /* Loop variable N indexes vector dimension DIM, and we don't
1921 yet know the upper bound of loop variable N. Set it to the
1922 difference between the vector's upper and lower bounds. */
1923 gcc_assert (loop->from[n] == gfc_index_zero_node);
1924 gcc_assert (info->subscript[dim]
1925 && info->subscript[dim]->type == GFC_SS_VECTOR);
1927 gfc_init_se (&se, NULL);
1928 desc = info->subscript[dim]->data.info.descriptor;
1929 zero = gfc_rank_cst[0];
1930 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1931 gfc_conv_descriptor_ubound (desc, zero),
1932 gfc_conv_descriptor_lbound (desc, zero));
1933 tmp = gfc_evaluate_now (tmp, &loop->pre);
1940 /* Add the pre and post chains for all the scalar expressions in a SS chain
1941 to loop. This is called after the loop parameters have been calculated,
1942 but before the actual scalarizing loops. */
1945 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1951 /* TODO: This can generate bad code if there are ordering dependencies,
1952 e.g., a callee allocated function and an unknown size constructor. */
1953 gcc_assert (ss != NULL);
1955 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1962 /* Scalar expression. Evaluate this now. This includes elemental
1963 dimension indices, but not array section bounds. */
1964 gfc_init_se (&se, NULL);
1965 gfc_conv_expr (&se, ss->expr);
1966 gfc_add_block_to_block (&loop->pre, &se.pre);
1968 if (ss->expr->ts.type != BT_CHARACTER)
1970 /* Move the evaluation of scalar expressions outside the
1971 scalarization loop, except for WHERE assignments. */
1973 se.expr = convert(gfc_array_index_type, se.expr);
1975 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1976 gfc_add_block_to_block (&loop->pre, &se.post);
1979 gfc_add_block_to_block (&loop->post, &se.post);
1981 ss->data.scalar.expr = se.expr;
1982 ss->string_length = se.string_length;
1985 case GFC_SS_REFERENCE:
1986 /* Scalar reference. Evaluate this now. */
1987 gfc_init_se (&se, NULL);
1988 gfc_conv_expr_reference (&se, ss->expr);
1989 gfc_add_block_to_block (&loop->pre, &se.pre);
1990 gfc_add_block_to_block (&loop->post, &se.post);
1992 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1993 ss->string_length = se.string_length;
1996 case GFC_SS_SECTION:
1997 /* Add the expressions for scalar and vector subscripts. */
1998 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1999 if (ss->data.info.subscript[n])
2000 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2003 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2007 /* Get the vector's descriptor and store it in SS. */
2008 gfc_init_se (&se, NULL);
2009 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2010 gfc_add_block_to_block (&loop->pre, &se.pre);
2011 gfc_add_block_to_block (&loop->post, &se.post);
2012 ss->data.info.descriptor = se.expr;
2015 case GFC_SS_INTRINSIC:
2016 gfc_add_intrinsic_ss_code (loop, ss);
2019 case GFC_SS_FUNCTION:
2020 /* Array function return value. We call the function and save its
2021 result in a temporary for use inside the loop. */
2022 gfc_init_se (&se, NULL);
2025 gfc_conv_expr (&se, ss->expr);
2026 gfc_add_block_to_block (&loop->pre, &se.pre);
2027 gfc_add_block_to_block (&loop->post, &se.post);
2028 ss->string_length = se.string_length;
2031 case GFC_SS_CONSTRUCTOR:
2032 if (ss->expr->ts.type == BT_CHARACTER
2033 && ss->string_length == NULL
2035 && ss->expr->ts.cl->length)
2037 gfc_init_se (&se, NULL);
2038 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
2039 gfc_charlen_type_node);
2040 ss->string_length = se.expr;
2041 gfc_add_block_to_block (&loop->pre, &se.pre);
2042 gfc_add_block_to_block (&loop->post, &se.post);
2044 gfc_trans_array_constructor (loop, ss, where);
2048 case GFC_SS_COMPONENT:
2049 /* Do nothing. These are handled elsewhere. */
2059 /* Translate expressions for the descriptor and data pointer of a SS. */
2063 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2068 /* Get the descriptor for the array to be scalarized. */
2069 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2070 gfc_init_se (&se, NULL);
2071 se.descriptor_only = 1;
2072 gfc_conv_expr_lhs (&se, ss->expr);
2073 gfc_add_block_to_block (block, &se.pre);
2074 ss->data.info.descriptor = se.expr;
2075 ss->string_length = se.string_length;
2079 /* Also the data pointer. */
2080 tmp = gfc_conv_array_data (se.expr);
2081 /* If this is a variable or address of a variable we use it directly.
2082 Otherwise we must evaluate it now to avoid breaking dependency
2083 analysis by pulling the expressions for elemental array indices
2086 || (TREE_CODE (tmp) == ADDR_EXPR
2087 && DECL_P (TREE_OPERAND (tmp, 0)))))
2088 tmp = gfc_evaluate_now (tmp, block);
2089 ss->data.info.data = tmp;
2091 tmp = gfc_conv_array_offset (se.expr);
2092 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2097 /* Initialize a gfc_loopinfo structure. */
2100 gfc_init_loopinfo (gfc_loopinfo * loop)
2104 memset (loop, 0, sizeof (gfc_loopinfo));
2105 gfc_init_block (&loop->pre);
2106 gfc_init_block (&loop->post);
2108 /* Initially scalarize in order. */
2109 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2112 loop->ss = gfc_ss_terminator;
2116 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2120 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2126 /* Return an expression for the data pointer of an array. */
2129 gfc_conv_array_data (tree descriptor)
2133 type = TREE_TYPE (descriptor);
2134 if (GFC_ARRAY_TYPE_P (type))
2136 if (TREE_CODE (type) == POINTER_TYPE)
2140 /* Descriptorless arrays. */
2141 return gfc_build_addr_expr (NULL_TREE, descriptor);
2145 return gfc_conv_descriptor_data_get (descriptor);
2149 /* Return an expression for the base offset of an array. */
2152 gfc_conv_array_offset (tree descriptor)
2156 type = TREE_TYPE (descriptor);
2157 if (GFC_ARRAY_TYPE_P (type))
2158 return GFC_TYPE_ARRAY_OFFSET (type);
2160 return gfc_conv_descriptor_offset (descriptor);
2164 /* Get an expression for the array stride. */
2167 gfc_conv_array_stride (tree descriptor, int dim)
2172 type = TREE_TYPE (descriptor);
2174 /* For descriptorless arrays use the array size. */
2175 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2176 if (tmp != NULL_TREE)
2179 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2184 /* Like gfc_conv_array_stride, but for the lower bound. */
2187 gfc_conv_array_lbound (tree descriptor, int dim)
2192 type = TREE_TYPE (descriptor);
2194 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2195 if (tmp != NULL_TREE)
2198 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2203 /* Like gfc_conv_array_stride, but for the upper bound. */
2206 gfc_conv_array_ubound (tree descriptor, int dim)
2211 type = TREE_TYPE (descriptor);
2213 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2214 if (tmp != NULL_TREE)
2217 /* This should only ever happen when passing an assumed shape array
2218 as an actual parameter. The value will never be used. */
2219 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2220 return gfc_index_zero_node;
2222 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2227 /* Generate code to perform an array index bound check. */
2230 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2231 locus * where, bool check_upper)
2236 const char * name = NULL;
2238 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2241 index = gfc_evaluate_now (index, &se->pre);
2243 /* We find a name for the error message. */
2245 name = se->ss->expr->symtree->name;
2247 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2248 && se->loop->ss->expr->symtree)
2249 name = se->loop->ss->expr->symtree->name;
2251 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2252 && se->loop->ss->loop_chain->expr
2253 && se->loop->ss->loop_chain->expr->symtree)
2254 name = se->loop->ss->loop_chain->expr->symtree->name;
2256 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2257 && se->loop->ss->loop_chain->expr->symtree)
2258 name = se->loop->ss->loop_chain->expr->symtree->name;
2260 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2262 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2263 && se->loop->ss->expr->value.function.name)
2264 name = se->loop->ss->expr->value.function.name;
2266 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2267 || se->loop->ss->type == GFC_SS_SCALAR)
2268 name = "unnamed constant";
2271 /* Check lower bound. */
2272 tmp = gfc_conv_array_lbound (descriptor, n);
2273 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2275 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2276 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2278 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2279 gfc_msg_fault, n+1);
2280 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2281 fold_convert (long_integer_type_node, index),
2282 fold_convert (long_integer_type_node, tmp));
2285 /* Check upper bound. */
2288 tmp = gfc_conv_array_ubound (descriptor, n);
2289 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2291 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2292 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2294 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2295 gfc_msg_fault, n+1);
2296 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2297 fold_convert (long_integer_type_node, index),
2298 fold_convert (long_integer_type_node, tmp));
2306 /* Return the offset for an index. Performs bound checking for elemental
2307 dimensions. Single element references are processed separately. */
2310 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2311 gfc_array_ref * ar, tree stride)
2317 /* Get the index into the array for this dimension. */
2320 gcc_assert (ar->type != AR_ELEMENT);
2321 switch (ar->dimen_type[dim])
2324 /* Elemental dimension. */
2325 gcc_assert (info->subscript[dim]
2326 && info->subscript[dim]->type == GFC_SS_SCALAR);
2327 /* We've already translated this value outside the loop. */
2328 index = info->subscript[dim]->data.scalar.expr;
2330 index = gfc_trans_array_bound_check (se, info->descriptor,
2331 index, dim, &ar->where,
2332 (ar->as->type != AS_ASSUMED_SIZE
2333 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2337 gcc_assert (info && se->loop);
2338 gcc_assert (info->subscript[dim]
2339 && info->subscript[dim]->type == GFC_SS_VECTOR);
2340 desc = info->subscript[dim]->data.info.descriptor;
2342 /* Get a zero-based index into the vector. */
2343 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2344 se->loop->loopvar[i], se->loop->from[i]);
2346 /* Multiply the index by the stride. */
2347 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2348 index, gfc_conv_array_stride (desc, 0));
2350 /* Read the vector to get an index into info->descriptor. */
2351 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2352 index = gfc_build_array_ref (data, index, NULL);
2353 index = gfc_evaluate_now (index, &se->pre);
2355 /* Do any bounds checking on the final info->descriptor index. */
2356 index = gfc_trans_array_bound_check (se, info->descriptor,
2357 index, dim, &ar->where,
2358 (ar->as->type != AS_ASSUMED_SIZE
2359 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2363 /* Scalarized dimension. */
2364 gcc_assert (info && se->loop);
2366 /* Multiply the loop variable by the stride and delta. */
2367 index = se->loop->loopvar[i];
2368 if (!integer_onep (info->stride[i]))
2369 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2371 if (!integer_zerop (info->delta[i]))
2372 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2382 /* Temporary array or derived type component. */
2383 gcc_assert (se->loop);
2384 index = se->loop->loopvar[se->loop->order[i]];
2385 if (!integer_zerop (info->delta[i]))
2386 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2387 index, info->delta[i]);
2390 /* Multiply by the stride. */
2391 if (!integer_onep (stride))
2392 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2398 /* Build a scalarized reference to an array. */
2401 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2404 tree decl = NULL_TREE;
2409 info = &se->ss->data.info;
2411 n = se->loop->order[0];
2415 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2417 /* Add the offset for this dimension to the stored offset for all other
2419 if (!integer_zerop (info->offset))
2420 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2422 if (se->ss->expr && is_subref_array (se->ss->expr))
2423 decl = se->ss->expr->symtree->n.sym->backend_decl;
2425 tmp = build_fold_indirect_ref (info->data);
2426 se->expr = gfc_build_array_ref (tmp, index, decl);
2430 /* Translate access of temporary array. */
2433 gfc_conv_tmp_array_ref (gfc_se * se)
2435 se->string_length = se->ss->string_length;
2436 gfc_conv_scalarized_array_ref (se, NULL);
2440 /* Build an array reference. se->expr already holds the array descriptor.
2441 This should be either a variable, indirect variable reference or component
2442 reference. For arrays which do not have a descriptor, se->expr will be
2444 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2447 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2457 /* Handle scalarized references separately. */
2458 if (ar->type != AR_ELEMENT)
2460 gfc_conv_scalarized_array_ref (se, ar);
2461 gfc_advance_se_ss_chain (se);
2465 index = gfc_index_zero_node;
2467 /* Calculate the offsets from all the dimensions. */
2468 for (n = 0; n < ar->dimen; n++)
2470 /* Calculate the index for this dimension. */
2471 gfc_init_se (&indexse, se);
2472 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2473 gfc_add_block_to_block (&se->pre, &indexse.pre);
2475 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2477 /* Check array bounds. */
2481 /* Evaluate the indexse.expr only once. */
2482 indexse.expr = save_expr (indexse.expr);
2485 tmp = gfc_conv_array_lbound (se->expr, n);
2486 if (sym->attr.temporary)
2488 gfc_init_se (&tmpse, se);
2489 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2490 gfc_array_index_type);
2491 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2495 cond = fold_build2 (LT_EXPR, boolean_type_node,
2497 asprintf (&msg, "%s for array '%s', "
2498 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2499 gfc_msg_fault, sym->name, n+1);
2500 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2501 fold_convert (long_integer_type_node,
2503 fold_convert (long_integer_type_node, tmp));
2506 /* Upper bound, but not for the last dimension of assumed-size
2508 if (n < ar->dimen - 1
2509 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2511 tmp = gfc_conv_array_ubound (se->expr, n);
2512 if (sym->attr.temporary)
2514 gfc_init_se (&tmpse, se);
2515 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2516 gfc_array_index_type);
2517 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2521 cond = fold_build2 (GT_EXPR, boolean_type_node,
2523 asprintf (&msg, "%s for array '%s', "
2524 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2525 gfc_msg_fault, sym->name, n+1);
2526 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2527 fold_convert (long_integer_type_node,
2529 fold_convert (long_integer_type_node, tmp));
2534 /* Multiply the index by the stride. */
2535 stride = gfc_conv_array_stride (se->expr, n);
2536 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2539 /* And add it to the total. */
2540 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2543 tmp = gfc_conv_array_offset (se->expr);
2544 if (!integer_zerop (tmp))
2545 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2547 /* Access the calculated element. */
2548 tmp = gfc_conv_array_data (se->expr);
2549 tmp = build_fold_indirect_ref (tmp);
2550 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2554 /* Generate the code to be executed immediately before entering a
2555 scalarization loop. */
2558 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2559 stmtblock_t * pblock)
2568 /* This code will be executed before entering the scalarization loop
2569 for this dimension. */
2570 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2572 if ((ss->useflags & flag) == 0)
2575 if (ss->type != GFC_SS_SECTION
2576 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2577 && ss->type != GFC_SS_COMPONENT)
2580 info = &ss->data.info;
2582 if (dim >= info->dimen)
2585 if (dim == info->dimen - 1)
2587 /* For the outermost loop calculate the offset due to any
2588 elemental dimensions. It will have been initialized with the
2589 base offset of the array. */
2592 for (i = 0; i < info->ref->u.ar.dimen; i++)
2594 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2597 gfc_init_se (&se, NULL);
2599 se.expr = info->descriptor;
2600 stride = gfc_conv_array_stride (info->descriptor, i);
2601 index = gfc_conv_array_index_offset (&se, info, i, -1,
2604 gfc_add_block_to_block (pblock, &se.pre);
2606 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2607 info->offset, index);
2608 info->offset = gfc_evaluate_now (info->offset, pblock);
2612 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2615 stride = gfc_conv_array_stride (info->descriptor, 0);
2617 /* Calculate the stride of the innermost loop. Hopefully this will
2618 allow the backend optimizers to do their stuff more effectively.
2620 info->stride0 = gfc_evaluate_now (stride, pblock);
2624 /* Add the offset for the previous loop dimension. */
2629 ar = &info->ref->u.ar;
2630 i = loop->order[dim + 1];
2638 gfc_init_se (&se, NULL);
2640 se.expr = info->descriptor;
2641 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2642 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2644 gfc_add_block_to_block (pblock, &se.pre);
2645 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2646 info->offset, index);
2647 info->offset = gfc_evaluate_now (info->offset, pblock);
2650 /* Remember this offset for the second loop. */
2651 if (dim == loop->temp_dim - 1)
2652 info->saved_offset = info->offset;
2657 /* Start a scalarized expression. Creates a scope and declares loop
2661 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2667 gcc_assert (!loop->array_parameter);
2669 for (dim = loop->dimen - 1; dim >= 0; dim--)
2671 n = loop->order[dim];
2673 gfc_start_block (&loop->code[n]);
2675 /* Create the loop variable. */
2676 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2678 if (dim < loop->temp_dim)
2682 /* Calculate values that will be constant within this loop. */
2683 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2685 gfc_start_block (pbody);
2689 /* Generates the actual loop code for a scalarization loop. */
2692 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2693 stmtblock_t * pbody)
2704 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2705 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2706 && n == loop->dimen - 1)
2708 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2709 init = make_tree_vec (1);
2710 cond = make_tree_vec (1);
2711 incr = make_tree_vec (1);
2713 /* Cycle statement is implemented with a goto. Exit statement must not
2714 be present for this loop. */
2715 exit_label = gfc_build_label_decl (NULL_TREE);
2716 TREE_USED (exit_label) = 1;
2718 /* Label for cycle statements (if needed). */
2719 tmp = build1_v (LABEL_EXPR, exit_label);
2720 gfc_add_expr_to_block (pbody, tmp);
2722 stmt = make_node (OMP_FOR);
2724 TREE_TYPE (stmt) = void_type_node;
2725 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2727 OMP_FOR_CLAUSES (stmt) = build_omp_clause (OMP_CLAUSE_SCHEDULE);
2728 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2729 = OMP_CLAUSE_SCHEDULE_STATIC;
2730 if (ompws_flags & OMPWS_NOWAIT)
2731 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2732 = build_omp_clause (OMP_CLAUSE_NOWAIT);
2734 /* Initialize the loopvar. */
2735 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2737 OMP_FOR_INIT (stmt) = init;
2738 /* The exit condition. */
2739 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2740 loop->loopvar[n], loop->to[n]);
2741 OMP_FOR_COND (stmt) = cond;
2742 /* Increment the loopvar. */
2743 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2744 loop->loopvar[n], gfc_index_one_node);
2745 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2746 void_type_node, loop->loopvar[n], tmp);
2747 OMP_FOR_INCR (stmt) = incr;
2749 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2750 gfc_add_expr_to_block (&loop->code[n], stmt);
2754 loopbody = gfc_finish_block (pbody);
2756 /* Initialize the loopvar. */
2757 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2759 exit_label = gfc_build_label_decl (NULL_TREE);
2761 /* Generate the loop body. */
2762 gfc_init_block (&block);
2764 /* The exit condition. */
2765 cond = fold_build2 (GT_EXPR, boolean_type_node,
2766 loop->loopvar[n], loop->to[n]);
2767 tmp = build1_v (GOTO_EXPR, exit_label);
2768 TREE_USED (exit_label) = 1;
2769 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2770 gfc_add_expr_to_block (&block, tmp);
2772 /* The main body. */
2773 gfc_add_expr_to_block (&block, loopbody);
2775 /* Increment the loopvar. */
2776 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2777 loop->loopvar[n], gfc_index_one_node);
2778 gfc_add_modify (&block, loop->loopvar[n], tmp);
2780 /* Build the loop. */
2781 tmp = gfc_finish_block (&block);
2782 tmp = build1_v (LOOP_EXPR, tmp);
2783 gfc_add_expr_to_block (&loop->code[n], tmp);
2785 /* Add the exit label. */
2786 tmp = build1_v (LABEL_EXPR, exit_label);
2787 gfc_add_expr_to_block (&loop->code[n], tmp);
2793 /* Finishes and generates the loops for a scalarized expression. */
2796 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2801 stmtblock_t *pblock;
2805 /* Generate the loops. */
2806 for (dim = 0; dim < loop->dimen; dim++)
2808 n = loop->order[dim];
2809 gfc_trans_scalarized_loop_end (loop, n, pblock);
2810 loop->loopvar[n] = NULL_TREE;
2811 pblock = &loop->code[n];
2814 tmp = gfc_finish_block (pblock);
2815 gfc_add_expr_to_block (&loop->pre, tmp);
2817 /* Clear all the used flags. */
2818 for (ss = loop->ss; ss; ss = ss->loop_chain)
2823 /* Finish the main body of a scalarized expression, and start the secondary
2827 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2831 stmtblock_t *pblock;
2835 /* We finish as many loops as are used by the temporary. */
2836 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2838 n = loop->order[dim];
2839 gfc_trans_scalarized_loop_end (loop, n, pblock);
2840 loop->loopvar[n] = NULL_TREE;
2841 pblock = &loop->code[n];
2844 /* We don't want to finish the outermost loop entirely. */
2845 n = loop->order[loop->temp_dim - 1];
2846 gfc_trans_scalarized_loop_end (loop, n, pblock);
2848 /* Restore the initial offsets. */
2849 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2851 if ((ss->useflags & 2) == 0)
2854 if (ss->type != GFC_SS_SECTION
2855 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2856 && ss->type != GFC_SS_COMPONENT)
2859 ss->data.info.offset = ss->data.info.saved_offset;
2862 /* Restart all the inner loops we just finished. */
2863 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2865 n = loop->order[dim];
2867 gfc_start_block (&loop->code[n]);
2869 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2871 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2874 /* Start a block for the secondary copying code. */
2875 gfc_start_block (body);
2879 /* Calculate the upper bound of an array section. */
2882 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2891 gcc_assert (ss->type == GFC_SS_SECTION);
2893 info = &ss->data.info;
2896 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2897 /* We'll calculate the upper bound once we have access to the
2898 vector's descriptor. */
2901 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2902 desc = info->descriptor;
2903 end = info->ref->u.ar.end[dim];
2907 /* The upper bound was specified. */
2908 gfc_init_se (&se, NULL);
2909 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2910 gfc_add_block_to_block (pblock, &se.pre);
2915 /* No upper bound was specified, so use the bound of the array. */
2916 bound = gfc_conv_array_ubound (desc, dim);
2923 /* Calculate the lower bound of an array section. */
2926 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2936 gcc_assert (ss->type == GFC_SS_SECTION);
2938 info = &ss->data.info;
2941 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2943 /* We use a zero-based index to access the vector. */
2944 info->start[n] = gfc_index_zero_node;
2945 info->end[n] = gfc_index_zero_node;
2946 info->stride[n] = gfc_index_one_node;
2950 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2951 desc = info->descriptor;
2952 start = info->ref->u.ar.start[dim];
2953 end = info->ref->u.ar.end[dim];
2954 stride = info->ref->u.ar.stride[dim];
2956 /* Calculate the start of the range. For vector subscripts this will
2957 be the range of the vector. */
2960 /* Specified section start. */
2961 gfc_init_se (&se, NULL);
2962 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2963 gfc_add_block_to_block (&loop->pre, &se.pre);
2964 info->start[n] = se.expr;
2968 /* No lower bound specified so use the bound of the array. */
2969 info->start[n] = gfc_conv_array_lbound (desc, dim);
2971 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2973 /* Similarly calculate the end. Although this is not used in the
2974 scalarizer, it is needed when checking bounds and where the end
2975 is an expression with side-effects. */
2978 /* Specified section start. */
2979 gfc_init_se (&se, NULL);
2980 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2981 gfc_add_block_to_block (&loop->pre, &se.pre);
2982 info->end[n] = se.expr;
2986 /* No upper bound specified so use the bound of the array. */
2987 info->end[n] = gfc_conv_array_ubound (desc, dim);
2989 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2991 /* Calculate the stride. */
2993 info->stride[n] = gfc_index_one_node;
2996 gfc_init_se (&se, NULL);
2997 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2998 gfc_add_block_to_block (&loop->pre, &se.pre);
2999 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3004 /* Calculates the range start and stride for a SS chain. Also gets the
3005 descriptor and data pointer. The range of vector subscripts is the size
3006 of the vector. Array bounds are also checked. */
3009 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3017 /* Determine the rank of the loop. */
3019 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3023 case GFC_SS_SECTION:
3024 case GFC_SS_CONSTRUCTOR:
3025 case GFC_SS_FUNCTION:
3026 case GFC_SS_COMPONENT:
3027 loop->dimen = ss->data.info.dimen;
3030 /* As usual, lbound and ubound are exceptions!. */
3031 case GFC_SS_INTRINSIC:
3032 switch (ss->expr->value.function.isym->id)
3034 case GFC_ISYM_LBOUND:
3035 case GFC_ISYM_UBOUND:
3036 loop->dimen = ss->data.info.dimen;
3047 /* We should have determined the rank of the expression by now. If
3048 not, that's bad news. */
3049 gcc_assert (loop->dimen != 0);
3051 /* Loop over all the SS in the chain. */
3052 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3054 if (ss->expr && ss->expr->shape && !ss->shape)
3055 ss->shape = ss->expr->shape;
3059 case GFC_SS_SECTION:
3060 /* Get the descriptor for the array. */
3061 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3063 for (n = 0; n < ss->data.info.dimen; n++)
3064 gfc_conv_section_startstride (loop, ss, n);
3067 case GFC_SS_INTRINSIC:
3068 switch (ss->expr->value.function.isym->id)
3070 /* Fall through to supply start and stride. */
3071 case GFC_ISYM_LBOUND:
3072 case GFC_ISYM_UBOUND:
3078 case GFC_SS_CONSTRUCTOR:
3079 case GFC_SS_FUNCTION:
3080 for (n = 0; n < ss->data.info.dimen; n++)
3082 ss->data.info.start[n] = gfc_index_zero_node;
3083 ss->data.info.end[n] = gfc_index_zero_node;
3084 ss->data.info.stride[n] = gfc_index_one_node;
3093 /* The rest is just runtime bound checking. */
3094 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3097 tree lbound, ubound;
3099 tree size[GFC_MAX_DIMENSIONS];
3100 tree stride_pos, stride_neg, non_zerosized, tmp2;
3105 gfc_start_block (&block);
3107 for (n = 0; n < loop->dimen; n++)
3108 size[n] = NULL_TREE;
3110 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3114 if (ss->type != GFC_SS_SECTION)
3117 gfc_start_block (&inner);
3119 /* TODO: range checking for mapped dimensions. */
3120 info = &ss->data.info;
3122 /* This code only checks ranges. Elemental and vector
3123 dimensions are checked later. */
3124 for (n = 0; n < loop->dimen; n++)
3129 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3132 if (dim == info->ref->u.ar.dimen - 1
3133 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3134 || info->ref->u.ar.as->cp_was_assumed))
3135 check_upper = false;
3139 /* Zero stride is not allowed. */
3140 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3141 gfc_index_zero_node);
3142 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3143 "of array '%s'", info->dim[n]+1,
3144 ss->expr->symtree->name);
3145 gfc_trans_runtime_check (true, false, tmp, &inner,
3146 &ss->expr->where, msg);
3149 desc = ss->data.info.descriptor;
3151 /* This is the run-time equivalent of resolve.c's
3152 check_dimension(). The logical is more readable there
3153 than it is here, with all the trees. */
3154 lbound = gfc_conv_array_lbound (desc, dim);
3157 ubound = gfc_conv_array_ubound (desc, dim);
3161 /* non_zerosized is true when the selected range is not
3163 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3164 info->stride[n], gfc_index_zero_node);
3165 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3167 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3170 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3171 info->stride[n], gfc_index_zero_node);
3172 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3174 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3176 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3177 stride_pos, stride_neg);
3179 /* Check the start of the range against the lower and upper
3180 bounds of the array, if the range is not empty. */
3181 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3183 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3184 non_zerosized, tmp);
3185 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3186 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3187 info->dim[n]+1, ss->expr->symtree->name);
3188 gfc_trans_runtime_check (true, false, tmp, &inner,
3189 &ss->expr->where, msg,
3190 fold_convert (long_integer_type_node,
3192 fold_convert (long_integer_type_node,
3198 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3199 info->start[n], ubound);
3200 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3201 non_zerosized, tmp);
3202 asprintf (&msg, "%s, upper bound of dimension %d of array "
3203 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3204 info->dim[n]+1, ss->expr->symtree->name);
3205 gfc_trans_runtime_check (true, false, tmp, &inner,
3206 &ss->expr->where, msg,
3207 fold_convert (long_integer_type_node, info->start[n]),
3208 fold_convert (long_integer_type_node, ubound));
3212 /* Compute the last element of the range, which is not
3213 necessarily "end" (think 0:5:3, which doesn't contain 5)
3214 and check it against both lower and upper bounds. */
3215 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3217 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3219 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3222 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3223 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3224 non_zerosized, tmp);
3225 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3226 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3227 info->dim[n]+1, ss->expr->symtree->name);
3228 gfc_trans_runtime_check (true, false, tmp, &inner,
3229 &ss->expr->where, msg,
3230 fold_convert (long_integer_type_node,
3232 fold_convert (long_integer_type_node,
3238 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3239 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3240 non_zerosized, tmp);
3241 asprintf (&msg, "%s, upper bound of dimension %d of array "
3242 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3243 info->dim[n]+1, ss->expr->symtree->name);
3244 gfc_trans_runtime_check (true, false, tmp, &inner,
3245 &ss->expr->where, msg,
3246 fold_convert (long_integer_type_node, tmp2),
3247 fold_convert (long_integer_type_node, ubound));
3251 /* Check the section sizes match. */
3252 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3254 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3256 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3257 build_int_cst (gfc_array_index_type, 0));
3258 /* We remember the size of the first section, and check all the
3259 others against this. */
3264 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3265 asprintf (&msg, "%s, size mismatch for dimension %d "
3266 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3267 info->dim[n]+1, ss->expr->symtree->name);
3268 gfc_trans_runtime_check (true, false, tmp3, &inner,
3269 &ss->expr->where, msg,
3270 fold_convert (long_integer_type_node, tmp),
3271 fold_convert (long_integer_type_node, size[n]));
3275 size[n] = gfc_evaluate_now (tmp, &inner);
3278 tmp = gfc_finish_block (&inner);
3280 /* For optional arguments, only check bounds if the argument is
3282 if (ss->expr->symtree->n.sym->attr.optional
3283 || ss->expr->symtree->n.sym->attr.not_always_present)
3284 tmp = build3_v (COND_EXPR,
3285 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3286 tmp, build_empty_stmt ());
3288 gfc_add_expr_to_block (&block, tmp);
3292 tmp = gfc_finish_block (&block);
3293 gfc_add_expr_to_block (&loop->pre, tmp);
3298 /* Return true if the two SS could be aliased, i.e. both point to the same data
3300 /* TODO: resolve aliases based on frontend expressions. */
3303 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3310 lsym = lss->expr->symtree->n.sym;
3311 rsym = rss->expr->symtree->n.sym;
3312 if (gfc_symbols_could_alias (lsym, rsym))
3315 if (rsym->ts.type != BT_DERIVED
3316 && lsym->ts.type != BT_DERIVED)
3319 /* For derived types we must check all the component types. We can ignore
3320 array references as these will have the same base type as the previous
3322 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3324 if (lref->type != REF_COMPONENT)
3327 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3330 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3333 if (rref->type != REF_COMPONENT)
3336 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3341 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3343 if (rref->type != REF_COMPONENT)
3346 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3354 /* Resolve array data dependencies. Creates a temporary if required. */
3355 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3359 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3369 loop->temp_ss = NULL;
3370 aref = dest->data.info.ref;
3373 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3375 if (ss->type != GFC_SS_SECTION)
3378 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3380 if (gfc_could_be_alias (dest, ss)
3381 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3389 lref = dest->expr->ref;
3390 rref = ss->expr->ref;
3392 nDepend = gfc_dep_resolver (lref, rref);
3396 /* TODO : loop shifting. */
3399 /* Mark the dimensions for LOOP SHIFTING */
3400 for (n = 0; n < loop->dimen; n++)
3402 int dim = dest->data.info.dim[n];
3404 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3406 else if (! gfc_is_same_range (&lref->u.ar,
3407 &rref->u.ar, dim, 0))
3411 /* Put all the dimensions with dependencies in the
3414 for (n = 0; n < loop->dimen; n++)
3416 gcc_assert (loop->order[n] == n);
3418 loop->order[dim++] = n;
3421 for (n = 0; n < loop->dimen; n++)
3424 loop->order[dim++] = n;
3427 gcc_assert (dim == loop->dimen);
3436 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3437 if (GFC_ARRAY_TYPE_P (base_type)
3438 || GFC_DESCRIPTOR_TYPE_P (base_type))
3439 base_type = gfc_get_element_type (base_type);
3440 loop->temp_ss = gfc_get_ss ();
3441 loop->temp_ss->type = GFC_SS_TEMP;
3442 loop->temp_ss->data.temp.type = base_type;
3443 loop->temp_ss->string_length = dest->string_length;
3444 loop->temp_ss->data.temp.dimen = loop->dimen;
3445 loop->temp_ss->next = gfc_ss_terminator;
3446 gfc_add_ss_to_loop (loop, loop->temp_ss);
3449 loop->temp_ss = NULL;
3453 /* Initialize the scalarization loop. Creates the loop variables. Determines
3454 the range of the loop variables. Creates a temporary if required.
3455 Calculates how to transform from loop variables to array indices for each
3456 expression. Also generates code for scalar expressions which have been
3457 moved outside the loop. */
3460 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3465 gfc_ss_info *specinfo;
3469 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3470 bool dynamic[GFC_MAX_DIMENSIONS];
3476 for (n = 0; n < loop->dimen; n++)
3480 /* We use one SS term, and use that to determine the bounds of the
3481 loop for this dimension. We try to pick the simplest term. */
3482 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3486 /* The frontend has worked out the size for us. */
3487 if (!loopspec[n] || !loopspec[n]->shape
3488 || !integer_zerop (loopspec[n]->data.info.start[n]))
3489 /* Prefer zero-based descriptors if possible. */
3494 if (ss->type == GFC_SS_CONSTRUCTOR)
3496 /* An unknown size constructor will always be rank one.
3497 Higher rank constructors will either have known shape,
3498 or still be wrapped in a call to reshape. */
3499 gcc_assert (loop->dimen == 1);
3501 /* Always prefer to use the constructor bounds if the size
3502 can be determined at compile time. Prefer not to otherwise,
3503 since the general case involves realloc, and it's better to
3504 avoid that overhead if possible. */
3505 c = ss->expr->value.constructor;
3506 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3507 if (!dynamic[n] || !loopspec[n])
3512 /* TODO: Pick the best bound if we have a choice between a
3513 function and something else. */
3514 if (ss->type == GFC_SS_FUNCTION)
3520 if (ss->type != GFC_SS_SECTION)
3524 specinfo = &loopspec[n]->data.info;
3527 info = &ss->data.info;
3531 /* Criteria for choosing a loop specifier (most important first):
3532 doesn't need realloc
3538 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3540 else if (integer_onep (info->stride[n])
3541 && !integer_onep (specinfo->stride[n]))
3543 else if (INTEGER_CST_P (info->stride[n])
3544 && !INTEGER_CST_P (specinfo->stride[n]))
3546 else if (INTEGER_CST_P (info->start[n])
3547 && !INTEGER_CST_P (specinfo->start[n]))
3549 /* We don't work out the upper bound.
3550 else if (INTEGER_CST_P (info->finish[n])
3551 && ! INTEGER_CST_P (specinfo->finish[n]))
3552 loopspec[n] = ss; */
3555 /* We should have found the scalarization loop specifier. If not,
3557 gcc_assert (loopspec[n]);
3559 info = &loopspec[n]->data.info;
3561 /* Set the extents of this range. */
3562 cshape = loopspec[n]->shape;
3563 if (cshape && INTEGER_CST_P (info->start[n])
3564 && INTEGER_CST_P (info->stride[n]))
3566 loop->from[n] = info->start[n];
3567 mpz_set (i, cshape[n]);
3568 mpz_sub_ui (i, i, 1);
3569 /* To = from + (size - 1) * stride. */
3570 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3571 if (!integer_onep (info->stride[n]))
3572 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3573 tmp, info->stride[n]);
3574 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3575 loop->from[n], tmp);
3579 loop->from[n] = info->start[n];
3580 switch (loopspec[n]->type)
3582 case GFC_SS_CONSTRUCTOR:
3583 /* The upper bound is calculated when we expand the
3585 gcc_assert (loop->to[n] == NULL_TREE);
3588 case GFC_SS_SECTION:
3589 /* Use the end expression if it exists and is not constant,
3590 so that it is only evaluated once. */
3591 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3592 loop->to[n] = info->end[n];
3594 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3598 case GFC_SS_FUNCTION:
3599 /* The loop bound will be set when we generate the call. */
3600 gcc_assert (loop->to[n] == NULL_TREE);
3608 /* Transform everything so we have a simple incrementing variable. */
3609 if (integer_onep (info->stride[n]))
3610 info->delta[n] = gfc_index_zero_node;
3613 /* Set the delta for this section. */
3614 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3615 /* Number of iterations is (end - start + step) / step.
3616 with start = 0, this simplifies to
3618 for (i = 0; i<=last; i++){...}; */
3619 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3620 loop->to[n], loop->from[n]);
3621 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3622 tmp, info->stride[n]);
3623 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3624 build_int_cst (gfc_array_index_type, -1));
3625 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3626 /* Make the loop variable start at 0. */
3627 loop->from[n] = gfc_index_zero_node;
3631 /* Add all the scalar code that can be taken out of the loops.
3632 This may include calculating the loop bounds, so do it before
3633 allocating the temporary. */
3634 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3636 /* If we want a temporary then create it. */
3637 if (loop->temp_ss != NULL)
3639 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3641 /* Make absolutely sure that this is a complete type. */
3642 if (loop->temp_ss->string_length)
3643 loop->temp_ss->data.temp.type
3644 = gfc_get_character_type_len_for_eltype
3645 (TREE_TYPE (loop->temp_ss->data.temp.type),
3646 loop->temp_ss->string_length);
3648 tmp = loop->temp_ss->data.temp.type;
3649 len = loop->temp_ss->string_length;
3650 n = loop->temp_ss->data.temp.dimen;
3651 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3652 loop->temp_ss->type = GFC_SS_SECTION;
3653 loop->temp_ss->data.info.dimen = n;
3654 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3655 &loop->temp_ss->data.info, tmp, NULL_TREE,
3656 false, true, false, where);
3659 for (n = 0; n < loop->temp_dim; n++)
3660 loopspec[loop->order[n]] = NULL;
3664 /* For array parameters we don't have loop variables, so don't calculate the
3666 if (loop->array_parameter)
3669 /* Calculate the translation from loop variables to array indices. */
3670 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3672 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3673 && ss->type != GFC_SS_CONSTRUCTOR)
3677 info = &ss->data.info;
3679 for (n = 0; n < info->dimen; n++)
3683 /* If we are specifying the range the delta is already set. */
3684 if (loopspec[n] != ss)
3686 /* Calculate the offset relative to the loop variable.
3687 First multiply by the stride. */
3688 tmp = loop->from[n];
3689 if (!integer_onep (info->stride[n]))
3690 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3691 tmp, info->stride[n]);
3693 /* Then subtract this from our starting value. */
3694 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3695 info->start[n], tmp);
3697 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3704 /* Fills in an array descriptor, and returns the size of the array. The size
3705 will be a simple_val, ie a variable or a constant. Also calculates the
3706 offset of the base. Returns the size of the array.
3710 for (n = 0; n < rank; n++)
3712 a.lbound[n] = specified_lower_bound;
3713 offset = offset + a.lbond[n] * stride;
3715 a.ubound[n] = specified_upper_bound;
3716 a.stride[n] = stride;
3717 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3718 stride = stride * size;
3725 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3726 gfc_expr ** lower, gfc_expr ** upper,
3727 stmtblock_t * pblock)
3739 stmtblock_t thenblock;
3740 stmtblock_t elseblock;
3745 type = TREE_TYPE (descriptor);
3747 stride = gfc_index_one_node;
3748 offset = gfc_index_zero_node;
3750 /* Set the dtype. */
3751 tmp = gfc_conv_descriptor_dtype (descriptor);
3752 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3754 or_expr = NULL_TREE;
3756 for (n = 0; n < rank; n++)
3758 /* We have 3 possibilities for determining the size of the array:
3759 lower == NULL => lbound = 1, ubound = upper[n]
3760 upper[n] = NULL => lbound = 1, ubound = lower[n]
3761 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3764 /* Set lower bound. */
3765 gfc_init_se (&se, NULL);
3767 se.expr = gfc_index_one_node;
3770 gcc_assert (lower[n]);
3773 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3774 gfc_add_block_to_block (pblock, &se.pre);
3778 se.expr = gfc_index_one_node;
3782 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3783 gfc_add_modify (pblock, tmp, se.expr);
3785 /* Work out the offset for this component. */
3786 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3787 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3789 /* Start the calculation for the size of this dimension. */
3790 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3791 gfc_index_one_node, se.expr);
3793 /* Set upper bound. */
3794 gfc_init_se (&se, NULL);
3795 gcc_assert (ubound);
3796 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3797 gfc_add_block_to_block (pblock, &se.pre);
3799 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3800 gfc_add_modify (pblock, tmp, se.expr);
3802 /* Store the stride. */
3803 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3804 gfc_add_modify (pblock, tmp, stride);
3806 /* Calculate the size of this dimension. */
3807 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3809 /* Check whether the size for this dimension is negative. */
3810 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3811 gfc_index_zero_node);
3815 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3817 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3818 gfc_index_zero_node, size);
3820 /* Multiply the stride by the number of elements in this dimension. */
3821 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3822 stride = gfc_evaluate_now (stride, pblock);
3825 /* The stride is the number of elements in the array, so multiply by the
3826 size of an element to get the total size. */
3827 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3828 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3829 fold_convert (gfc_array_index_type, tmp));
3831 if (poffset != NULL)
3833 offset = gfc_evaluate_now (offset, pblock);
3837 if (integer_zerop (or_expr))
3839 if (integer_onep (or_expr))
3840 return gfc_index_zero_node;
3842 var = gfc_create_var (TREE_TYPE (size), "size");
3843 gfc_start_block (&thenblock);
3844 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3845 thencase = gfc_finish_block (&thenblock);
3847 gfc_start_block (&elseblock);
3848 gfc_add_modify (&elseblock, var, size);
3849 elsecase = gfc_finish_block (&elseblock);
3851 tmp = gfc_evaluate_now (or_expr, pblock);
3852 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3853 gfc_add_expr_to_block (pblock, tmp);
3859 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3860 the work for an ALLOCATE statement. */
3864 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3872 gfc_ref *ref, *prev_ref = NULL;
3873 bool allocatable_array;
3877 /* Find the last reference in the chain. */
3878 while (ref && ref->next != NULL)
3880 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3885 if (ref == NULL || ref->type != REF_ARRAY)
3889 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3891 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3893 /* Figure out the size of the array. */
3894 switch (ref->u.ar.type)
3898 upper = ref->u.ar.start;
3902 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3904 lower = ref->u.ar.as->lower;
3905 upper = ref->u.ar.as->upper;
3909 lower = ref->u.ar.start;
3910 upper = ref->u.ar.end;
3918 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3919 lower, upper, &se->pre);
3921 /* Allocate memory to store the data. */
3922 pointer = gfc_conv_descriptor_data_get (se->expr);
3923 STRIP_NOPS (pointer);
3925 /* The allocate_array variants take the old pointer as first argument. */
3926 if (allocatable_array)
3927 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3929 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3930 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3931 gfc_add_expr_to_block (&se->pre, tmp);
3933 tmp = gfc_conv_descriptor_offset (se->expr);
3934 gfc_add_modify (&se->pre, tmp, offset);
3936 if (expr->ts.type == BT_DERIVED
3937 && expr->ts.derived->attr.alloc_comp)
3939 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3940 ref->u.ar.as->rank);
3941 gfc_add_expr_to_block (&se->pre, tmp);
3948 /* Deallocate an array variable. Also used when an allocated variable goes
3953 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3959 gfc_start_block (&block);
3960 /* Get a pointer to the data. */
3961 var = gfc_conv_descriptor_data_get (descriptor);
3964 /* Parameter is the address of the data component. */
3965 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3966 gfc_add_expr_to_block (&block, tmp);
3968 /* Zero the data pointer. */
3969 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3970 var, build_int_cst (TREE_TYPE (var), 0));
3971 gfc_add_expr_to_block (&block, tmp);
3973 return gfc_finish_block (&block);
3977 /* Create an array constructor from an initialization expression.
3978 We assume the frontend already did any expansions and conversions. */
3981 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3988 unsigned HOST_WIDE_INT lo;
3990 VEC(constructor_elt,gc) *v = NULL;
3992 switch (expr->expr_type)
3995 case EXPR_STRUCTURE:
3996 /* A single scalar or derived type value. Create an array with all
3997 elements equal to that value. */
3998 gfc_init_se (&se, NULL);
4000 if (expr->expr_type == EXPR_CONSTANT)
4001 gfc_conv_constant (&se, expr);
4003 gfc_conv_structure (&se, expr, 1);
4005 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4006 gcc_assert (tmp && INTEGER_CST_P (tmp));
4007 hi = TREE_INT_CST_HIGH (tmp);
4008 lo = TREE_INT_CST_LOW (tmp);
4012 /* This will probably eat buckets of memory for large arrays. */
4013 while (hi != 0 || lo != 0)
4015 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4023 /* Create a vector of all the elements. */
4024 for (c = expr->value.constructor; c; c = c->next)
4028 /* Problems occur when we get something like
4029 integer :: a(lots) = (/(i, i=1, lots)/) */
4030 gfc_error_now ("The number of elements in the array constructor "
4031 "at %L requires an increase of the allowed %d "
4032 "upper limit. See -fmax-array-constructor "
4033 "option", &expr->where,
4034 gfc_option.flag_max_array_constructor);
4037 if (mpz_cmp_si (c->n.offset, 0) != 0)
4038 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4042 if (mpz_cmp_si (c->repeat, 0) != 0)
4046 mpz_set (maxval, c->repeat);
4047 mpz_add (maxval, c->n.offset, maxval);
4048 mpz_sub_ui (maxval, maxval, 1);
4049 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4050 if (mpz_cmp_si (c->n.offset, 0) != 0)
4052 mpz_add_ui (maxval, c->n.offset, 1);
4053 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4056 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4058 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
4064 gfc_init_se (&se, NULL);
4065 switch (c->expr->expr_type)
4068 gfc_conv_constant (&se, c->expr);
4069 if (range == NULL_TREE)
4070 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4073 if (index != NULL_TREE)
4074 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4075 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4079 case EXPR_STRUCTURE:
4080 gfc_conv_structure (&se, c->expr, 1);
4081 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4086 /* Catch those occasional beasts that do not simplify
4087 for one reason or another, assuming that if they are
4088 standard defying the frontend will catch them. */
4089 gfc_conv_expr (&se, c->expr);
4090 if (range == NULL_TREE)
4091 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4094 if (index != NULL_TREE)
4095 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4096 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4104 return gfc_build_null_descriptor (type);
4110 /* Create a constructor from the list of elements. */
4111 tmp = build_constructor (type, v);
4112 TREE_CONSTANT (tmp) = 1;
4117 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4118 returns the size (in elements) of the array. */
4121 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4122 stmtblock_t * pblock)
4137 size = gfc_index_one_node;
4138 offset = gfc_index_zero_node;
4139 for (dim = 0; dim < as->rank; dim++)
4141 /* Evaluate non-constant array bound expressions. */
4142 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4143 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4145 gfc_init_se (&se, NULL);
4146 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4147 gfc_add_block_to_block (pblock, &se.pre);
4148 gfc_add_modify (pblock, lbound, se.expr);
4150 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4151 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4153 gfc_init_se (&se, NULL);
4154 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4155 gfc_add_block_to_block (pblock, &se.pre);
4156 gfc_add_modify (pblock, ubound, se.expr);
4158 /* The offset of this dimension. offset = offset - lbound * stride. */
4159 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4160 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4162 /* The size of this dimension, and the stride of the next. */
4163 if (dim + 1 < as->rank)
4164 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4166 stride = GFC_TYPE_ARRAY_SIZE (type);
4168 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4170 /* Calculate stride = size * (ubound + 1 - lbound). */
4171 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4172 gfc_index_one_node, lbound);
4173 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4174 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4176 gfc_add_modify (pblock, stride, tmp);
4178 stride = gfc_evaluate_now (tmp, pblock);
4180 /* Make sure that negative size arrays are translated
4181 to being zero size. */
4182 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4183 stride, gfc_index_zero_node);
4184 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4185 stride, gfc_index_zero_node);
4186 gfc_add_modify (pblock, stride, tmp);
4192 gfc_trans_vla_type_sizes (sym, pblock);
4199 /* Generate code to initialize/allocate an array variable. */
4202 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4211 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4213 /* Do nothing for USEd variables. */
4214 if (sym->attr.use_assoc)
4217 type = TREE_TYPE (decl);
4218 gcc_assert (GFC_ARRAY_TYPE_P (type));
4219 onstack = TREE_CODE (type) != POINTER_TYPE;
4221 gfc_start_block (&block);
4223 /* Evaluate character string length. */
4224 if (sym->ts.type == BT_CHARACTER
4225 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4227 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4229 gfc_trans_vla_type_sizes (sym, &block);
4231 /* Emit a DECL_EXPR for this variable, which will cause the
4232 gimplifier to allocate storage, and all that good stuff. */
4233 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4234 gfc_add_expr_to_block (&block, tmp);
4239 gfc_add_expr_to_block (&block, fnbody);
4240 return gfc_finish_block (&block);
4243 type = TREE_TYPE (type);
4245 gcc_assert (!sym->attr.use_assoc);
4246 gcc_assert (!TREE_STATIC (decl));
4247 gcc_assert (!sym->module);
4249 if (sym->ts.type == BT_CHARACTER
4250 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4251 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4253 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4255 /* Don't actually allocate space for Cray Pointees. */
4256 if (sym->attr.cray_pointee)
4258 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4259 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4260 gfc_add_expr_to_block (&block, fnbody);
4261 return gfc_finish_block (&block);
4264 /* The size is the number of elements in the array, so multiply by the
4265 size of an element to get the total size. */
4266 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4267 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4268 fold_convert (gfc_array_index_type, tmp));
4270 /* Allocate memory to hold the data. */
4271 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4272 gfc_add_modify (&block, decl, tmp);
4274 /* Set offset of the array. */
4275 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4276 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4279 /* Automatic arrays should not have initializers. */
4280 gcc_assert (!sym->value);
4282 gfc_add_expr_to_block (&block, fnbody);
4284 /* Free the temporary. */
4285 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4286 gfc_add_expr_to_block (&block, tmp);
4288 return gfc_finish_block (&block);
4292 /* Generate entry and exit code for g77 calling convention arrays. */
4295 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4305 gfc_get_backend_locus (&loc);
4306 gfc_set_backend_locus (&sym->declared_at);
4308 /* Descriptor type. */
4309 parm = sym->backend_decl;
4310 type = TREE_TYPE (parm);
4311 gcc_assert (GFC_ARRAY_TYPE_P (type));
4313 gfc_start_block (&block);
4315 if (sym->ts.type == BT_CHARACTER
4316 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4317 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4319 /* Evaluate the bounds of the array. */
4320 gfc_trans_array_bounds (type, sym, &offset, &block);
4322 /* Set the offset. */
4323 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4324 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4326 /* Set the pointer itself if we aren't using the parameter directly. */
4327 if (TREE_CODE (parm) != PARM_DECL)
4329 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4330 gfc_add_modify (&block, parm, tmp);
4332 stmt = gfc_finish_block (&block);
4334 gfc_set_backend_locus (&loc);
4336 gfc_start_block (&block);
4338 /* Add the initialization code to the start of the function. */
4340 if (sym->attr.optional || sym->attr.not_always_present)
4342 tmp = gfc_conv_expr_present (sym);
4343 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4346 gfc_add_expr_to_block (&block, stmt);
4347 gfc_add_expr_to_block (&block, body);
4349 return gfc_finish_block (&block);
4353 /* Modify the descriptor of an array parameter so that it has the
4354 correct lower bound. Also move the upper bound accordingly.
4355 If the array is not packed, it will be copied into a temporary.
4356 For each dimension we set the new lower and upper bounds. Then we copy the
4357 stride and calculate the offset for this dimension. We also work out
4358 what the stride of a packed array would be, and see it the two match.
4359 If the array need repacking, we set the stride to the values we just
4360 calculated, recalculate the offset and copy the array data.
4361 Code is also added to copy the data back at the end of the function.
4365 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4372 stmtblock_t cleanup;
4380 tree stride, stride2;
4390 /* Do nothing for pointer and allocatable arrays. */
4391 if (sym->attr.pointer || sym->attr.allocatable)
4394 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4395 return gfc_trans_g77_array (sym, body);
4397 gfc_get_backend_locus (&loc);
4398 gfc_set_backend_locus (&sym->declared_at);
4400 /* Descriptor type. */
4401 type = TREE_TYPE (tmpdesc);
4402 gcc_assert (GFC_ARRAY_TYPE_P (type));
4403 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4404 dumdesc = build_fold_indirect_ref (dumdesc);
4405 gfc_start_block (&block);
4407 if (sym->ts.type == BT_CHARACTER
4408 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4409 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4411 checkparm = (sym->as->type == AS_EXPLICIT
4412 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4414 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4415 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4417 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4419 /* For non-constant shape arrays we only check if the first dimension
4420 is contiguous. Repacking higher dimensions wouldn't gain us
4421 anything as we still don't know the array stride. */
4422 partial = gfc_create_var (boolean_type_node, "partial");
4423 TREE_USED (partial) = 1;
4424 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4425 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4426 gfc_add_modify (&block, partial, tmp);
4430 partial = NULL_TREE;
4433 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4434 here, however I think it does the right thing. */
4437 /* Set the first stride. */
4438 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4439 stride = gfc_evaluate_now (stride, &block);
4441 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4442 stride, gfc_index_zero_node);
4443 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4444 gfc_index_one_node, stride);
4445 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4446 gfc_add_modify (&block, stride, tmp);
4448 /* Allow the user to disable array repacking. */
4449 stmt_unpacked = NULL_TREE;
4453 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4454 /* A library call to repack the array if necessary. */
4455 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4456 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4458 stride = gfc_index_one_node;
4460 if (gfc_option.warn_array_temp)
4461 gfc_warning ("Creating array temporary at %L", &loc);
4464 /* This is for the case where the array data is used directly without
4465 calling the repack function. */
4466 if (no_repack || partial != NULL_TREE)
4467 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4469 stmt_packed = NULL_TREE;
4471 /* Assign the data pointer. */
4472 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4474 /* Don't repack unknown shape arrays when the first stride is 1. */
4475 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4476 partial, stmt_packed, stmt_unpacked);
4479 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4480 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4482 offset = gfc_index_zero_node;
4483 size = gfc_index_one_node;
4485 /* Evaluate the bounds of the array. */
4486 for (n = 0; n < sym->as->rank; n++)
4488 if (checkparm || !sym->as->upper[n])
4490 /* Get the bounds of the actual parameter. */
4491 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4492 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4496 dubound = NULL_TREE;
4497 dlbound = NULL_TREE;
4500 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4501 if (!INTEGER_CST_P (lbound))
4503 gfc_init_se (&se, NULL);
4504 gfc_conv_expr_type (&se, sym->as->lower[n],
4505 gfc_array_index_type);
4506 gfc_add_block_to_block (&block, &se.pre);
4507 gfc_add_modify (&block, lbound, se.expr);
4510 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4511 /* Set the desired upper bound. */
4512 if (sym->as->upper[n])
4514 /* We know what we want the upper bound to be. */
4515 if (!INTEGER_CST_P (ubound))
4517 gfc_init_se (&se, NULL);
4518 gfc_conv_expr_type (&se, sym->as->upper[n],
4519 gfc_array_index_type);
4520 gfc_add_block_to_block (&block, &se.pre);
4521 gfc_add_modify (&block, ubound, se.expr);
4524 /* Check the sizes match. */
4527 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4530 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4532 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4534 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4535 asprintf (&msg, "%s for dimension %d of array '%s'",
4536 gfc_msg_bounds, n+1, sym->name);
4537 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4543 /* For assumed shape arrays move the upper bound by the same amount
4544 as the lower bound. */
4545 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4547 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4548 gfc_add_modify (&block, ubound, tmp);
4550 /* The offset of this dimension. offset = offset - lbound * stride. */
4551 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4552 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4554 /* The size of this dimension, and the stride of the next. */
4555 if (n + 1 < sym->as->rank)
4557 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4559 if (no_repack || partial != NULL_TREE)
4562 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4565 /* Figure out the stride if not a known constant. */
4566 if (!INTEGER_CST_P (stride))
4569 stmt_packed = NULL_TREE;
4572 /* Calculate stride = size * (ubound + 1 - lbound). */
4573 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4574 gfc_index_one_node, lbound);
4575 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4577 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4582 /* Assign the stride. */
4583 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4584 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4585 stmt_unpacked, stmt_packed);
4587 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4588 gfc_add_modify (&block, stride, tmp);
4593 stride = GFC_TYPE_ARRAY_SIZE (type);
4595 if (stride && !INTEGER_CST_P (stride))
4597 /* Calculate size = stride * (ubound + 1 - lbound). */
4598 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4599 gfc_index_one_node, lbound);
4600 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4602 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4603 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4604 gfc_add_modify (&block, stride, tmp);
4609 /* Set the offset. */
4610 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4611 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4613 gfc_trans_vla_type_sizes (sym, &block);
4615 stmt = gfc_finish_block (&block);
4617 gfc_start_block (&block);
4619 /* Only do the entry/initialization code if the arg is present. */
4620 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4621 optional_arg = (sym->attr.optional
4622 || (sym->ns->proc_name->attr.entry_master
4623 && sym->attr.dummy));
4626 tmp = gfc_conv_expr_present (sym);
4627 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4629 gfc_add_expr_to_block (&block, stmt);
4631 /* Add the main function body. */
4632 gfc_add_expr_to_block (&block, body);
4637 gfc_start_block (&cleanup);
4639 if (sym->attr.intent != INTENT_IN)
4641 /* Copy the data back. */
4642 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4643 gfc_add_expr_to_block (&cleanup, tmp);
4646 /* Free the temporary. */
4647 tmp = gfc_call_free (tmpdesc);
4648 gfc_add_expr_to_block (&cleanup, tmp);
4650 stmt = gfc_finish_block (&cleanup);
4652 /* Only do the cleanup if the array was repacked. */
4653 tmp = build_fold_indirect_ref (dumdesc);
4654 tmp = gfc_conv_descriptor_data_get (tmp);
4655 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4656 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4660 tmp = gfc_conv_expr_present (sym);
4661 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4663 gfc_add_expr_to_block (&block, stmt);
4665 /* We don't need to free any memory allocated by internal_pack as it will
4666 be freed at the end of the function by pop_context. */
4667 return gfc_finish_block (&block);
4671 /* Calculate the overall offset, including subreferences. */
4673 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4674 bool subref, gfc_expr *expr)
4684 /* If offset is NULL and this is not a subreferenced array, there is
4686 if (offset == NULL_TREE)
4689 offset = gfc_index_zero_node;
4694 tmp = gfc_conv_array_data (desc);
4695 tmp = build_fold_indirect_ref (tmp);
4696 tmp = gfc_build_array_ref (tmp, offset, NULL);
4698 /* Offset the data pointer for pointer assignments from arrays with
4699 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4702 /* Go past the array reference. */
4703 for (ref = expr->ref; ref; ref = ref->next)
4704 if (ref->type == REF_ARRAY &&
4705 ref->u.ar.type != AR_ELEMENT)
4711 /* Calculate the offset for each subsequent subreference. */
4712 for (; ref; ref = ref->next)
4717 field = ref->u.c.component->backend_decl;
4718 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4719 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4720 tmp, field, NULL_TREE);
4724 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4725 gfc_init_se (&start, NULL);
4726 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4727 gfc_add_block_to_block (block, &start.pre);
4728 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4732 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4733 && ref->u.ar.type == AR_ELEMENT);
4735 /* TODO - Add bounds checking. */
4736 stride = gfc_index_one_node;
4737 index = gfc_index_zero_node;
4738 for (n = 0; n < ref->u.ar.dimen; n++)
4743 /* Update the index. */
4744 gfc_init_se (&start, NULL);
4745 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4746 itmp = gfc_evaluate_now (start.expr, block);
4747 gfc_init_se (&start, NULL);
4748 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4749 jtmp = gfc_evaluate_now (start.expr, block);
4750 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4751 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4752 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4753 index = gfc_evaluate_now (index, block);
4755 /* Update the stride. */
4756 gfc_init_se (&start, NULL);
4757 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4758 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4759 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4760 gfc_index_one_node, itmp);
4761 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4762 stride = gfc_evaluate_now (stride, block);
4765 /* Apply the index to obtain the array element. */
4766 tmp = gfc_build_array_ref (tmp, index, NULL);
4776 /* Set the target data pointer. */
4777 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4778 gfc_conv_descriptor_data_set (block, parm, offset);
4782 /* gfc_conv_expr_descriptor needs the string length an expression
4783 so that the size of the temporary can be obtained. This is done
4784 by adding up the string lengths of all the elements in the
4785 expression. Function with non-constant expressions have their
4786 string lengths mapped onto the actual arguments using the
4787 interface mapping machinery in trans-expr.c. */
4789 get_array_charlen (gfc_expr *expr, gfc_se *se)
4791 gfc_interface_mapping mapping;
4792 gfc_formal_arglist *formal;
4793 gfc_actual_arglist *arg;
4796 if (expr->ts.cl->length
4797 && gfc_is_constant_expr (expr->ts.cl->length))
4799 if (!expr->ts.cl->backend_decl)
4800 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4804 switch (expr->expr_type)
4807 get_array_charlen (expr->value.op.op1, se);
4809 /* For parentheses the expression ts.cl is identical. */
4810 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4813 expr->ts.cl->backend_decl =
4814 gfc_create_var (gfc_charlen_type_node, "sln");
4816 if (expr->value.op.op2)
4818 get_array_charlen (expr->value.op.op2, se);
4820 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4822 /* Add the string lengths and assign them to the expression
4823 string length backend declaration. */
4824 gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
4825 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4826 expr->value.op.op1->ts.cl->backend_decl,
4827 expr->value.op.op2->ts.cl->backend_decl));
4830 gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
4831 expr->value.op.op1->ts.cl->backend_decl);
4835 if (expr->value.function.esym == NULL
4836 || expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4838 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4842 /* Map expressions involving the dummy arguments onto the actual
4843 argument expressions. */
4844 gfc_init_interface_mapping (&mapping);
4845 formal = expr->symtree->n.sym->formal;
4846 arg = expr->value.function.actual;
4848 /* Set se = NULL in the calls to the interface mapping, to suppress any
4850 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4855 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4858 gfc_init_se (&tse, NULL);
4860 /* Build the expression for the character length and convert it. */
4861 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4863 gfc_add_block_to_block (&se->pre, &tse.pre);
4864 gfc_add_block_to_block (&se->post, &tse.post);
4865 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4866 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4867 build_int_cst (gfc_charlen_type_node, 0));
4868 expr->ts.cl->backend_decl = tse.expr;
4869 gfc_free_interface_mapping (&mapping);
4873 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4880 /* Convert an array for passing as an actual argument. Expressions and
4881 vector subscripts are evaluated and stored in a temporary, which is then
4882 passed. For whole arrays the descriptor is passed. For array sections
4883 a modified copy of the descriptor is passed, but using the original data.
4885 This function is also used for array pointer assignments, and there
4888 - se->want_pointer && !se->direct_byref
4889 EXPR is an actual argument. On exit, se->expr contains a
4890 pointer to the array descriptor.
4892 - !se->want_pointer && !se->direct_byref
4893 EXPR is an actual argument to an intrinsic function or the
4894 left-hand side of a pointer assignment. On exit, se->expr
4895 contains the descriptor for EXPR.
4897 - !se->want_pointer && se->direct_byref
4898 EXPR is the right-hand side of a pointer assignment and
4899 se->expr is the descriptor for the previously-evaluated
4900 left-hand side. The function creates an assignment from
4901 EXPR to se->expr. */
4904 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4917 bool subref_array_target = false;
4919 gcc_assert (ss != gfc_ss_terminator);
4921 /* Special case things we know we can pass easily. */
4922 switch (expr->expr_type)
4925 /* If we have a linear array section, we can pass it directly.
4926 Otherwise we need to copy it into a temporary. */
4928 /* Find the SS for the array section. */
4930 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4931 secss = secss->next;
4933 gcc_assert (secss != gfc_ss_terminator);
4934 info = &secss->data.info;
4936 /* Get the descriptor for the array. */
4937 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4938 desc = info->descriptor;
4940 subref_array_target = se->direct_byref && is_subref_array (expr);
4941 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4942 && !subref_array_target;
4946 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4948 /* Create a new descriptor if the array doesn't have one. */
4951 else if (info->ref->u.ar.type == AR_FULL)
4953 else if (se->direct_byref)
4956 full = gfc_full_array_ref_p (info->ref);
4960 if (se->direct_byref)
4962 /* Copy the descriptor for pointer assignments. */
4963 gfc_add_modify (&se->pre, se->expr, desc);
4965 /* Add any offsets from subreferences. */
4966 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4967 subref_array_target, expr);
4969 else if (se->want_pointer)
4971 /* We pass full arrays directly. This means that pointers and
4972 allocatable arrays should also work. */
4973 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
4980 if (expr->ts.type == BT_CHARACTER)
4981 se->string_length = gfc_get_expr_charlen (expr);
4988 /* A transformational function return value will be a temporary
4989 array descriptor. We still need to go through the scalarizer
4990 to create the descriptor. Elemental functions ar handled as
4991 arbitrary expressions, i.e. copy to a temporary. */
4993 /* Look for the SS for this function. */
4994 while (secss != gfc_ss_terminator
4995 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4996 secss = secss->next;
4998 if (se->direct_byref)
5000 gcc_assert (secss != gfc_ss_terminator);
5002 /* For pointer assignments pass the descriptor directly. */
5004 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5005 gfc_conv_expr (se, expr);
5009 if (secss == gfc_ss_terminator)
5011 /* Elemental function. */
5013 if (expr->ts.type == BT_CHARACTER
5014 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
5015 get_array_charlen (expr, se);
5021 /* Transformational function. */
5022 info = &secss->data.info;
5028 /* Constant array constructors don't need a temporary. */
5029 if (ss->type == GFC_SS_CONSTRUCTOR
5030 && expr->ts.type != BT_CHARACTER
5031 && gfc_constant_array_constructor_p (expr->value.constructor))
5034 info = &ss->data.info;
5046 /* Something complicated. Copy it into a temporary. */
5053 gfc_init_loopinfo (&loop);
5055 /* Associate the SS with the loop. */
5056 gfc_add_ss_to_loop (&loop, ss);
5058 /* Tell the scalarizer not to bother creating loop variables, etc. */
5060 loop.array_parameter = 1;
5062 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5063 gcc_assert (!se->direct_byref);
5065 /* Setup the scalarizing loops and bounds. */
5066 gfc_conv_ss_startstride (&loop);
5070 /* Tell the scalarizer to make a temporary. */
5071 loop.temp_ss = gfc_get_ss ();
5072 loop.temp_ss->type = GFC_SS_TEMP;
5073 loop.temp_ss->next = gfc_ss_terminator;
5075 if (expr->ts.type == BT_CHARACTER
5076 && !expr->ts.cl->backend_decl)
5077 get_array_charlen (expr, se);
5079 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5081 if (expr->ts.type == BT_CHARACTER)
5082 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
5084 loop.temp_ss->string_length = NULL;
5086 se->string_length = loop.temp_ss->string_length;
5087 loop.temp_ss->data.temp.dimen = loop.dimen;
5088 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5091 gfc_conv_loop_setup (&loop, & expr->where);
5095 /* Copy into a temporary and pass that. We don't need to copy the data
5096 back because expressions and vector subscripts must be INTENT_IN. */
5097 /* TODO: Optimize passing function return values. */
5101 /* Start the copying loops. */
5102 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5103 gfc_mark_ss_chain_used (ss, 1);
5104 gfc_start_scalarized_body (&loop, &block);
5106 /* Copy each data element. */
5107 gfc_init_se (&lse, NULL);
5108 gfc_copy_loopinfo_to_se (&lse, &loop);
5109 gfc_init_se (&rse, NULL);
5110 gfc_copy_loopinfo_to_se (&rse, &loop);
5112 lse.ss = loop.temp_ss;
5115 gfc_conv_scalarized_array_ref (&lse, NULL);
5116 if (expr->ts.type == BT_CHARACTER)
5118 gfc_conv_expr (&rse, expr);
5119 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5120 rse.expr = build_fold_indirect_ref (rse.expr);
5123 gfc_conv_expr_val (&rse, expr);
5125 gfc_add_block_to_block (&block, &rse.pre);
5126 gfc_add_block_to_block (&block, &lse.pre);
5128 lse.string_length = rse.string_length;
5129 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5130 expr->expr_type == EXPR_VARIABLE);
5131 gfc_add_expr_to_block (&block, tmp);
5133 /* Finish the copying loops. */
5134 gfc_trans_scalarizing_loops (&loop, &block);
5136 desc = loop.temp_ss->data.info.descriptor;
5138 gcc_assert (is_gimple_lvalue (desc));
5140 else if (expr->expr_type == EXPR_FUNCTION)
5142 desc = info->descriptor;
5143 se->string_length = ss->string_length;
5147 /* We pass sections without copying to a temporary. Make a new
5148 descriptor and point it at the section we want. The loop variable
5149 limits will be the limits of the section.
5150 A function may decide to repack the array to speed up access, but
5151 we're not bothered about that here. */
5160 /* Set the string_length for a character array. */
5161 if (expr->ts.type == BT_CHARACTER)
5162 se->string_length = gfc_get_expr_charlen (expr);
5164 desc = info->descriptor;
5165 gcc_assert (secss && secss != gfc_ss_terminator);
5166 if (se->direct_byref)
5168 /* For pointer assignments we fill in the destination. */
5170 parmtype = TREE_TYPE (parm);
5174 /* Otherwise make a new one. */
5175 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5176 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5177 loop.from, loop.to, 0,
5179 parm = gfc_create_var (parmtype, "parm");
5182 offset = gfc_index_zero_node;
5185 /* The following can be somewhat confusing. We have two
5186 descriptors, a new one and the original array.
5187 {parm, parmtype, dim} refer to the new one.
5188 {desc, type, n, secss, loop} refer to the original, which maybe
5189 a descriptorless array.
5190 The bounds of the scalarization are the bounds of the section.
5191 We don't have to worry about numeric overflows when calculating
5192 the offsets because all elements are within the array data. */
5194 /* Set the dtype. */
5195 tmp = gfc_conv_descriptor_dtype (parm);
5196 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5198 /* Set offset for assignments to pointer only to zero if it is not
5200 if (se->direct_byref
5201 && info->ref && info->ref->u.ar.type != AR_FULL)
5202 base = gfc_index_zero_node;
5203 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5204 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5208 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5209 for (n = 0; n < ndim; n++)
5211 stride = gfc_conv_array_stride (desc, n);
5213 /* Work out the offset. */
5215 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5217 gcc_assert (info->subscript[n]
5218 && info->subscript[n]->type == GFC_SS_SCALAR);
5219 start = info->subscript[n]->data.scalar.expr;
5223 /* Check we haven't somehow got out of sync. */
5224 gcc_assert (info->dim[dim] == n);
5226 /* Evaluate and remember the start of the section. */
5227 start = info->start[dim];
5228 stride = gfc_evaluate_now (stride, &loop.pre);
5231 tmp = gfc_conv_array_lbound (desc, n);
5232 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5234 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5235 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5238 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5240 /* For elemental dimensions, we only need the offset. */
5244 /* Vector subscripts need copying and are handled elsewhere. */
5246 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5248 /* Set the new lower bound. */
5249 from = loop.from[dim];
5252 /* If we have an array section or are assigning make sure that
5253 the lower bound is 1. References to the full
5254 array should otherwise keep the original bounds. */
5256 || info->ref->u.ar.type != AR_FULL)
5257 && !integer_onep (from))
5259 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5260 gfc_index_one_node, from);
5261 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5262 from = gfc_index_one_node;
5264 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5265 gfc_add_modify (&loop.pre, tmp, from);
5267 /* Set the new upper bound. */
5268 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5269 gfc_add_modify (&loop.pre, tmp, to);
5271 /* Multiply the stride by the section stride to get the
5273 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5274 stride, info->stride[dim]);
5276 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5278 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5281 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5283 tmp = gfc_conv_array_lbound (desc, n);
5284 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5285 tmp, loop.from[dim]);
5286 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5287 tmp, gfc_conv_array_stride (desc, n));
5288 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5292 /* Store the new stride. */
5293 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5294 gfc_add_modify (&loop.pre, tmp, stride);
5299 if (se->data_not_needed)
5300 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5302 /* Point the data pointer at the first element in the section. */
5303 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5304 subref_array_target, expr);
5306 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5307 && !se->data_not_needed)
5309 /* Set the offset. */
5310 tmp = gfc_conv_descriptor_offset (parm);
5311 gfc_add_modify (&loop.pre, tmp, base);
5315 /* Only the callee knows what the correct offset it, so just set
5317 tmp = gfc_conv_descriptor_offset (parm);
5318 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5323 if (!se->direct_byref)
5325 /* Get a pointer to the new descriptor. */
5326 if (se->want_pointer)
5327 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5332 gfc_add_block_to_block (&se->pre, &loop.pre);
5333 gfc_add_block_to_block (&se->post, &loop.post);
5335 /* Cleanup the scalarizer. */
5336 gfc_cleanup_loop (&loop);
5340 /* Convert an array for passing as an actual parameter. */
5341 /* TODO: Optimize passing g77 arrays. */
5344 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5345 const gfc_symbol *fsym, const char *proc_name)
5349 tree tmp = NULL_TREE;
5351 tree parent = DECL_CONTEXT (current_function_decl);
5352 bool full_array_var, this_array_result;
5356 full_array_var = (expr->expr_type == EXPR_VARIABLE
5357 && expr->ref->type == REF_ARRAY
5358 && expr->ref->u.ar.type == AR_FULL);
5359 sym = full_array_var ? expr->symtree->n.sym : NULL;
5361 /* The symbol should have an array specification. */
5362 gcc_assert (!sym || sym->as);
5364 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5366 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5367 expr->ts.cl->backend_decl = tmp;
5368 se->string_length = tmp;
5371 /* Is this the result of the enclosing procedure? */
5372 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5373 if (this_array_result
5374 && (sym->backend_decl != current_function_decl)
5375 && (sym->backend_decl != parent))
5376 this_array_result = false;
5378 /* Passing address of the array if it is not pointer or assumed-shape. */
5379 if (full_array_var && g77 && !this_array_result)
5381 tmp = gfc_get_symbol_decl (sym);
5383 if (sym->ts.type == BT_CHARACTER)
5384 se->string_length = sym->ts.cl->backend_decl;
5385 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5386 && !sym->attr.allocatable)
5388 /* Some variables are declared directly, others are declared as
5389 pointers and allocated on the heap. */
5390 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5393 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5396 if (sym->attr.allocatable)
5398 if (sym->attr.dummy || sym->attr.result)
5400 gfc_conv_expr_descriptor (se, expr, ss);
5401 se->expr = gfc_conv_array_data (se->expr);
5404 se->expr = gfc_conv_array_data (tmp);
5409 if (this_array_result)
5411 /* Result of the enclosing function. */
5412 gfc_conv_expr_descriptor (se, expr, ss);
5413 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5415 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5416 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5417 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5423 /* Every other type of array. */
5424 se->want_pointer = 1;
5425 gfc_conv_expr_descriptor (se, expr, ss);
5428 /* Deallocate the allocatable components of structures that are
5430 if (expr->ts.type == BT_DERIVED
5431 && expr->ts.derived->attr.alloc_comp
5432 && expr->expr_type != EXPR_VARIABLE)
5434 tmp = build_fold_indirect_ref (se->expr);
5435 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5436 gfc_add_expr_to_block (&se->post, tmp);
5442 /* Repack the array. */
5444 if (gfc_option.warn_array_temp)
5447 gfc_warning ("Creating array temporary at %L for argument '%s'",
5448 &expr->where, fsym->name);
5450 gfc_warning ("Creating array temporary at %L", &expr->where);
5453 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5455 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5457 tmp = gfc_conv_expr_present (sym);
5458 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5459 fold_convert (TREE_TYPE (se->expr), ptr),
5460 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5463 ptr = gfc_evaluate_now (ptr, &se->pre);
5467 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5471 if (fsym && proc_name)
5472 asprintf (&msg, "An array temporary was created for argument "
5473 "'%s' of procedure '%s'", fsym->name, proc_name);
5475 asprintf (&msg, "An array temporary was created");
5477 tmp = build_fold_indirect_ref (desc);
5478 tmp = gfc_conv_array_data (tmp);
5479 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5480 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5482 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5483 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5484 gfc_conv_expr_present (sym), tmp);
5486 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5491 gfc_start_block (&block);
5493 /* Copy the data back. */
5494 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5496 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5497 gfc_add_expr_to_block (&block, tmp);
5500 /* Free the temporary. */
5501 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5502 gfc_add_expr_to_block (&block, tmp);
5504 stmt = gfc_finish_block (&block);
5506 gfc_init_block (&block);
5507 /* Only if it was repacked. This code needs to be executed before the
5508 loop cleanup code. */
5509 tmp = build_fold_indirect_ref (desc);
5510 tmp = gfc_conv_array_data (tmp);
5511 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5512 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5514 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5515 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5516 gfc_conv_expr_present (sym), tmp);
5518 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5520 gfc_add_expr_to_block (&block, tmp);
5521 gfc_add_block_to_block (&block, &se->post);
5523 gfc_init_block (&se->post);
5524 gfc_add_block_to_block (&se->post, &block);
5529 /* Generate code to deallocate an array, if it is allocated. */
5532 gfc_trans_dealloc_allocated (tree descriptor)
5538 gfc_start_block (&block);
5540 var = gfc_conv_descriptor_data_get (descriptor);
5543 /* Call array_deallocate with an int * present in the second argument.
5544 Although it is ignored here, it's presence ensures that arrays that
5545 are already deallocated are ignored. */
5546 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5547 gfc_add_expr_to_block (&block, tmp);
5549 /* Zero the data pointer. */
5550 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5551 var, build_int_cst (TREE_TYPE (var), 0));
5552 gfc_add_expr_to_block (&block, tmp);
5554 return gfc_finish_block (&block);
5558 /* This helper function calculates the size in words of a full array. */
5561 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5566 idx = gfc_rank_cst[rank - 1];
5567 nelems = gfc_conv_descriptor_ubound (decl, idx);
5568 tmp = gfc_conv_descriptor_lbound (decl, idx);
5569 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5570 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5571 tmp, gfc_index_one_node);
5572 tmp = gfc_evaluate_now (tmp, block);
5574 nelems = gfc_conv_descriptor_stride (decl, idx);
5575 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5576 return gfc_evaluate_now (tmp, block);
5580 /* Allocate dest to the same size as src, and copy src -> dest. */
5583 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5592 /* If the source is null, set the destination to null. */
5593 gfc_init_block (&block);
5594 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5595 null_data = gfc_finish_block (&block);
5597 gfc_init_block (&block);
5599 nelems = get_full_array_size (&block, src, rank);
5600 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5601 fold_convert (gfc_array_index_type,
5602 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5604 /* Allocate memory to the destination. */
5605 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5607 gfc_conv_descriptor_data_set (&block, dest, tmp);
5609 /* We know the temporary and the value will be the same length,
5610 so can use memcpy. */
5611 tmp = built_in_decls[BUILT_IN_MEMCPY];
5612 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5613 gfc_conv_descriptor_data_get (src), size);
5614 gfc_add_expr_to_block (&block, tmp);
5615 tmp = gfc_finish_block (&block);
5617 /* Null the destination if the source is null; otherwise do
5618 the allocate and copy. */
5619 null_cond = gfc_conv_descriptor_data_get (src);
5620 null_cond = convert (pvoid_type_node, null_cond);
5621 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5622 null_cond, null_pointer_node);
5623 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5627 /* Recursively traverse an object of derived type, generating code to
5628 deallocate, nullify or copy allocatable components. This is the work horse
5629 function for the functions named in this enum. */
5631 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5634 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5635 tree dest, int rank, int purpose)
5639 stmtblock_t fnblock;
5640 stmtblock_t loopbody;
5650 tree null_cond = NULL_TREE;
5652 gfc_init_block (&fnblock);
5654 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5655 decl = build_fold_indirect_ref (decl);
5657 /* If this an array of derived types with allocatable components
5658 build a loop and recursively call this function. */
5659 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5660 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5662 tmp = gfc_conv_array_data (decl);
5663 var = build_fold_indirect_ref (tmp);
5665 /* Get the number of elements - 1 and set the counter. */
5666 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5668 /* Use the descriptor for an allocatable array. Since this
5669 is a full array reference, we only need the descriptor
5670 information from dimension = rank. */
5671 tmp = get_full_array_size (&fnblock, decl, rank);
5672 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5673 tmp, gfc_index_one_node);
5675 null_cond = gfc_conv_descriptor_data_get (decl);
5676 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5677 build_int_cst (TREE_TYPE (null_cond), 0));
5681 /* Otherwise use the TYPE_DOMAIN information. */
5682 tmp = array_type_nelts (TREE_TYPE (decl));
5683 tmp = fold_convert (gfc_array_index_type, tmp);
5686 /* Remember that this is, in fact, the no. of elements - 1. */
5687 nelems = gfc_evaluate_now (tmp, &fnblock);
5688 index = gfc_create_var (gfc_array_index_type, "S");
5690 /* Build the body of the loop. */
5691 gfc_init_block (&loopbody);
5693 vref = gfc_build_array_ref (var, index, NULL);
5695 if (purpose == COPY_ALLOC_COMP)
5697 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5699 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5700 gfc_add_expr_to_block (&fnblock, tmp);
5702 tmp = build_fold_indirect_ref (gfc_conv_array_data (dest));
5703 dref = gfc_build_array_ref (tmp, index, NULL);
5704 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5707 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5709 gfc_add_expr_to_block (&loopbody, tmp);
5711 /* Build the loop and return. */
5712 gfc_init_loopinfo (&loop);
5714 loop.from[0] = gfc_index_zero_node;
5715 loop.loopvar[0] = index;
5716 loop.to[0] = nelems;
5717 gfc_trans_scalarizing_loops (&loop, &loopbody);
5718 gfc_add_block_to_block (&fnblock, &loop.pre);
5720 tmp = gfc_finish_block (&fnblock);
5721 if (null_cond != NULL_TREE)
5722 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5727 /* Otherwise, act on the components or recursively call self to
5728 act on a chain of components. */
5729 for (c = der_type->components; c; c = c->next)
5731 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5732 && c->ts.derived->attr.alloc_comp;
5733 cdecl = c->backend_decl;
5734 ctype = TREE_TYPE (cdecl);
5738 case DEALLOCATE_ALLOC_COMP:
5739 /* Do not deallocate the components of ultimate pointer
5741 if (cmp_has_alloc_comps && !c->attr.pointer)
5743 comp = fold_build3 (COMPONENT_REF, ctype,
5744 decl, cdecl, NULL_TREE);
5745 rank = c->as ? c->as->rank : 0;
5746 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5748 gfc_add_expr_to_block (&fnblock, tmp);
5751 if (c->attr.allocatable)
5753 comp = fold_build3 (COMPONENT_REF, ctype,
5754 decl, cdecl, NULL_TREE);
5755 tmp = gfc_trans_dealloc_allocated (comp);
5756 gfc_add_expr_to_block (&fnblock, tmp);
5760 case NULLIFY_ALLOC_COMP:
5761 if (c->attr.pointer)
5763 else if (c->attr.allocatable)
5765 comp = fold_build3 (COMPONENT_REF, ctype,
5766 decl, cdecl, NULL_TREE);
5767 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5769 else if (cmp_has_alloc_comps)
5771 comp = fold_build3 (COMPONENT_REF, ctype,
5772 decl, cdecl, NULL_TREE);
5773 rank = c->as ? c->as->rank : 0;
5774 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5776 gfc_add_expr_to_block (&fnblock, tmp);
5780 case COPY_ALLOC_COMP:
5781 if (c->attr.pointer)
5784 /* We need source and destination components. */
5785 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5786 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5787 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5789 if (c->attr.allocatable && !cmp_has_alloc_comps)
5791 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5792 gfc_add_expr_to_block (&fnblock, tmp);
5795 if (cmp_has_alloc_comps)
5797 rank = c->as ? c->as->rank : 0;
5798 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5799 gfc_add_modify (&fnblock, dcmp, tmp);
5800 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5802 gfc_add_expr_to_block (&fnblock, tmp);
5812 return gfc_finish_block (&fnblock);
5815 /* Recursively traverse an object of derived type, generating code to
5816 nullify allocatable components. */
5819 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5821 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5822 NULLIFY_ALLOC_COMP);
5826 /* Recursively traverse an object of derived type, generating code to
5827 deallocate allocatable components. */
5830 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5832 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5833 DEALLOCATE_ALLOC_COMP);
5837 /* Recursively traverse an object of derived type, generating code to
5838 copy its allocatable components. */
5841 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5843 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5847 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5848 Do likewise, recursively if necessary, with the allocatable components of
5852 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5857 stmtblock_t fnblock;
5860 bool sym_has_alloc_comp;
5862 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5863 && sym->ts.derived->attr.alloc_comp;
5865 /* Make sure the frontend gets these right. */
5866 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5867 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5868 "allocatable attribute or derived type without allocatable "
5871 gfc_init_block (&fnblock);
5873 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5874 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5876 if (sym->ts.type == BT_CHARACTER
5877 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5879 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5880 gfc_trans_vla_type_sizes (sym, &fnblock);
5883 /* Dummy, use associated and result variables don't need anything special. */
5884 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
5886 gfc_add_expr_to_block (&fnblock, body);
5888 return gfc_finish_block (&fnblock);
5891 gfc_get_backend_locus (&loc);
5892 gfc_set_backend_locus (&sym->declared_at);
5893 descriptor = sym->backend_decl;
5895 /* Although static, derived types with default initializers and
5896 allocatable components must not be nulled wholesale; instead they
5897 are treated component by component. */
5898 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5900 /* SAVEd variables are not freed on exit. */
5901 gfc_trans_static_array_pointer (sym);
5905 /* Get the descriptor type. */
5906 type = TREE_TYPE (sym->backend_decl);
5908 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5910 if (!sym->attr.save)
5912 rank = sym->as ? sym->as->rank : 0;
5913 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5914 gfc_add_expr_to_block (&fnblock, tmp);
5917 tmp = gfc_init_default_dt (sym, NULL);
5918 gfc_add_expr_to_block (&fnblock, tmp);
5922 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5924 /* If the backend_decl is not a descriptor, we must have a pointer
5926 descriptor = build_fold_indirect_ref (sym->backend_decl);
5927 type = TREE_TYPE (descriptor);
5930 /* NULLIFY the data pointer. */
5931 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5932 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5934 gfc_add_expr_to_block (&fnblock, body);
5936 gfc_set_backend_locus (&loc);
5938 /* Allocatable arrays need to be freed when they go out of scope.
5939 The allocatable components of pointers must not be touched. */
5940 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5941 && !sym->attr.pointer && !sym->attr.save)
5944 rank = sym->as ? sym->as->rank : 0;
5945 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5946 gfc_add_expr_to_block (&fnblock, tmp);
5949 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5951 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5952 gfc_add_expr_to_block (&fnblock, tmp);
5955 return gfc_finish_block (&fnblock);
5958 /************ Expression Walking Functions ******************/
5960 /* Walk a variable reference.
5962 Possible extension - multiple component subscripts.
5963 x(:,:) = foo%a(:)%b(:)
5965 forall (i=..., j=...)
5966 x(i,j) = foo%a(j)%b(i)
5968 This adds a fair amount of complexity because you need to deal with more
5969 than one ref. Maybe handle in a similar manner to vector subscripts.
5970 Maybe not worth the effort. */
5974 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5982 for (ref = expr->ref; ref; ref = ref->next)
5983 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5986 for (; ref; ref = ref->next)
5988 if (ref->type == REF_SUBSTRING)
5990 newss = gfc_get_ss ();
5991 newss->type = GFC_SS_SCALAR;
5992 newss->expr = ref->u.ss.start;
5996 newss = gfc_get_ss ();
5997 newss->type = GFC_SS_SCALAR;
5998 newss->expr = ref->u.ss.end;
6003 /* We're only interested in array sections from now on. */
6004 if (ref->type != REF_ARRAY)
6011 for (n = 0; n < ar->dimen; n++)
6013 newss = gfc_get_ss ();
6014 newss->type = GFC_SS_SCALAR;
6015 newss->expr = ar->start[n];
6022 newss = gfc_get_ss ();
6023 newss->type = GFC_SS_SECTION;
6026 newss->data.info.dimen = ar->as->rank;
6027 newss->data.info.ref = ref;
6029 /* Make sure array is the same as array(:,:), this way
6030 we don't need to special case all the time. */
6031 ar->dimen = ar->as->rank;
6032 for (n = 0; n < ar->dimen; n++)
6034 newss->data.info.dim[n] = n;
6035 ar->dimen_type[n] = DIMEN_RANGE;
6037 gcc_assert (ar->start[n] == NULL);
6038 gcc_assert (ar->end[n] == NULL);
6039 gcc_assert (ar->stride[n] == NULL);
6045 newss = gfc_get_ss ();
6046 newss->type = GFC_SS_SECTION;
6049 newss->data.info.dimen = 0;
6050 newss->data.info.ref = ref;
6054 /* We add SS chains for all the subscripts in the section. */
6055 for (n = 0; n < ar->dimen; n++)
6059 switch (ar->dimen_type[n])
6062 /* Add SS for elemental (scalar) subscripts. */
6063 gcc_assert (ar->start[n]);
6064 indexss = gfc_get_ss ();
6065 indexss->type = GFC_SS_SCALAR;
6066 indexss->expr = ar->start[n];
6067 indexss->next = gfc_ss_terminator;
6068 indexss->loop_chain = gfc_ss_terminator;
6069 newss->data.info.subscript[n] = indexss;
6073 /* We don't add anything for sections, just remember this
6074 dimension for later. */
6075 newss->data.info.dim[newss->data.info.dimen] = n;
6076 newss->data.info.dimen++;
6080 /* Create a GFC_SS_VECTOR index in which we can store
6081 the vector's descriptor. */
6082 indexss = gfc_get_ss ();
6083 indexss->type = GFC_SS_VECTOR;
6084 indexss->expr = ar->start[n];
6085 indexss->next = gfc_ss_terminator;
6086 indexss->loop_chain = gfc_ss_terminator;
6087 newss->data.info.subscript[n] = indexss;
6088 newss->data.info.dim[newss->data.info.dimen] = n;
6089 newss->data.info.dimen++;
6093 /* We should know what sort of section it is by now. */
6097 /* We should have at least one non-elemental dimension. */
6098 gcc_assert (newss->data.info.dimen > 0);
6103 /* We should know what sort of section it is by now. */
6112 /* Walk an expression operator. If only one operand of a binary expression is
6113 scalar, we must also add the scalar term to the SS chain. */
6116 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6122 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6123 if (expr->value.op.op2 == NULL)
6126 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6128 /* All operands are scalar. Pass back and let the caller deal with it. */
6132 /* All operands require scalarization. */
6133 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6136 /* One of the operands needs scalarization, the other is scalar.
6137 Create a gfc_ss for the scalar expression. */
6138 newss = gfc_get_ss ();
6139 newss->type = GFC_SS_SCALAR;
6142 /* First operand is scalar. We build the chain in reverse order, so
6143 add the scalar SS after the second operand. */
6145 while (head && head->next != ss)
6147 /* Check we haven't somehow broken the chain. */
6151 newss->expr = expr->value.op.op1;
6153 else /* head2 == head */
6155 gcc_assert (head2 == head);
6156 /* Second operand is scalar. */
6157 newss->next = head2;
6159 newss->expr = expr->value.op.op2;
6166 /* Reverse a SS chain. */
6169 gfc_reverse_ss (gfc_ss * ss)
6174 gcc_assert (ss != NULL);
6176 head = gfc_ss_terminator;
6177 while (ss != gfc_ss_terminator)
6180 /* Check we didn't somehow break the chain. */
6181 gcc_assert (next != NULL);
6191 /* Walk the arguments of an elemental function. */
6194 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6202 head = gfc_ss_terminator;
6205 for (; arg; arg = arg->next)
6210 newss = gfc_walk_subexpr (head, arg->expr);
6213 /* Scalar argument. */
6214 newss = gfc_get_ss ();
6216 newss->expr = arg->expr;
6226 while (tail->next != gfc_ss_terminator)
6233 /* If all the arguments are scalar we don't need the argument SS. */
6234 gfc_free_ss_chain (head);
6239 /* Add it onto the existing chain. */
6245 /* Walk a function call. Scalar functions are passed back, and taken out of
6246 scalarization loops. For elemental functions we walk their arguments.
6247 The result of functions returning arrays is stored in a temporary outside
6248 the loop, so that the function is only called once. Hence we do not need
6249 to walk their arguments. */
6252 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6255 gfc_intrinsic_sym *isym;
6258 isym = expr->value.function.isym;
6260 /* Handle intrinsic functions separately. */
6262 return gfc_walk_intrinsic_function (ss, expr, isym);
6264 sym = expr->value.function.esym;
6266 sym = expr->symtree->n.sym;
6268 /* A function that returns arrays. */
6269 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6271 newss = gfc_get_ss ();
6272 newss->type = GFC_SS_FUNCTION;
6275 newss->data.info.dimen = expr->rank;
6279 /* Walk the parameters of an elemental function. For now we always pass
6281 if (sym->attr.elemental)
6282 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6285 /* Scalar functions are OK as these are evaluated outside the scalarization
6286 loop. Pass back and let the caller deal with it. */
6291 /* An array temporary is constructed for array constructors. */
6294 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6299 newss = gfc_get_ss ();
6300 newss->type = GFC_SS_CONSTRUCTOR;
6303 newss->data.info.dimen = expr->rank;
6304 for (n = 0; n < expr->rank; n++)
6305 newss->data.info.dim[n] = n;
6311 /* Walk an expression. Add walked expressions to the head of the SS chain.
6312 A wholly scalar expression will not be added. */
6315 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6319 switch (expr->expr_type)
6322 head = gfc_walk_variable_expr (ss, expr);
6326 head = gfc_walk_op_expr (ss, expr);
6330 head = gfc_walk_function_expr (ss, expr);
6335 case EXPR_STRUCTURE:
6336 /* Pass back and let the caller deal with it. */
6340 head = gfc_walk_array_constructor (ss, expr);
6343 case EXPR_SUBSTRING:
6344 /* Pass back and let the caller deal with it. */
6348 internal_error ("bad expression type during walk (%d)",
6355 /* Entry point for expression walking.
6356 A return value equal to the passed chain means this is
6357 a scalar expression. It is up to the caller to take whatever action is
6358 necessary to translate these. */
6361 gfc_walk_expr (gfc_expr * expr)
6365 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6366 return gfc_reverse_ss (res);