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 if (c->expr->ts.type != BT_CHARACTER)
1267 se.expr = fold_convert (type, se.expr);
1268 /* For constant character array constructors we build
1269 an array of pointers. */
1270 else if (POINTER_TYPE_P (type))
1271 se.expr = gfc_build_addr_expr
1272 (gfc_get_pchar_type (p->expr->ts.kind),
1275 list = tree_cons (build_int_cst (gfc_array_index_type,
1276 idx++), se.expr, list);
1281 bound = build_int_cst (NULL_TREE, n - 1);
1282 /* Create an array type to hold them. */
1283 tmptype = build_range_type (gfc_array_index_type,
1284 gfc_index_zero_node, bound);
1285 tmptype = build_array_type (type, tmptype);
1287 init = build_constructor_from_list (tmptype, nreverse (list));
1288 TREE_CONSTANT (init) = 1;
1289 TREE_STATIC (init) = 1;
1290 /* Create a static variable to hold the data. */
1291 tmp = gfc_create_var (tmptype, "data");
1292 TREE_STATIC (tmp) = 1;
1293 TREE_CONSTANT (tmp) = 1;
1294 TREE_READONLY (tmp) = 1;
1295 DECL_INITIAL (tmp) = init;
1298 /* Use BUILTIN_MEMCPY to assign the values. */
1299 tmp = gfc_conv_descriptor_data_get (desc);
1300 tmp = build_fold_indirect_ref (tmp);
1301 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1302 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1303 init = gfc_build_addr_expr (NULL_TREE, init);
1305 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1306 bound = build_int_cst (NULL_TREE, n * size);
1307 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1309 gfc_add_expr_to_block (&body, tmp);
1311 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1313 build_int_cst (gfc_array_index_type, n));
1315 if (!INTEGER_CST_P (*poffset))
1317 gfc_add_modify (&body, *offsetvar, *poffset);
1318 *poffset = *offsetvar;
1322 /* The frontend should already have done any expansions
1326 /* Pass the code as is. */
1327 tmp = gfc_finish_block (&body);
1328 gfc_add_expr_to_block (pblock, tmp);
1332 /* Build the implied do-loop. */
1333 stmtblock_t implied_do_block;
1341 loopbody = gfc_finish_block (&body);
1343 /* Create a new block that holds the implied-do loop. A temporary
1344 loop-variable is used. */
1345 gfc_start_block(&implied_do_block);
1347 /* Initialize the loop. */
1348 gfc_init_se (&se, NULL);
1349 gfc_conv_expr_val (&se, c->iterator->start);
1350 gfc_add_block_to_block (&implied_do_block, &se.pre);
1351 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1353 gfc_init_se (&se, NULL);
1354 gfc_conv_expr_val (&se, c->iterator->end);
1355 gfc_add_block_to_block (&implied_do_block, &se.pre);
1356 end = gfc_evaluate_now (se.expr, &implied_do_block);
1358 gfc_init_se (&se, NULL);
1359 gfc_conv_expr_val (&se, c->iterator->step);
1360 gfc_add_block_to_block (&implied_do_block, &se.pre);
1361 step = gfc_evaluate_now (se.expr, &implied_do_block);
1363 /* If this array expands dynamically, and the number of iterations
1364 is not constant, we won't have allocated space for the static
1365 part of C->EXPR's size. Do that now. */
1366 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1368 /* Get the number of iterations. */
1369 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1371 /* Get the static part of C->EXPR's size. */
1372 gfc_get_array_constructor_element_size (&size, c->expr);
1373 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1375 /* Grow the array by TMP * TMP2 elements. */
1376 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1377 gfc_grow_array (&implied_do_block, desc, tmp);
1380 /* Generate the loop body. */
1381 exit_label = gfc_build_label_decl (NULL_TREE);
1382 gfc_start_block (&body);
1384 /* Generate the exit condition. Depending on the sign of
1385 the step variable we have to generate the correct
1387 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1388 build_int_cst (TREE_TYPE (step), 0));
1389 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1390 fold_build2 (GT_EXPR, boolean_type_node,
1391 shadow_loopvar, end),
1392 fold_build2 (LT_EXPR, boolean_type_node,
1393 shadow_loopvar, end));
1394 tmp = build1_v (GOTO_EXPR, exit_label);
1395 TREE_USED (exit_label) = 1;
1396 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1397 gfc_add_expr_to_block (&body, tmp);
1399 /* The main loop body. */
1400 gfc_add_expr_to_block (&body, loopbody);
1402 /* Increase loop variable by step. */
1403 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1404 gfc_add_modify (&body, shadow_loopvar, tmp);
1406 /* Finish the loop. */
1407 tmp = gfc_finish_block (&body);
1408 tmp = build1_v (LOOP_EXPR, tmp);
1409 gfc_add_expr_to_block (&implied_do_block, tmp);
1411 /* Add the exit label. */
1412 tmp = build1_v (LABEL_EXPR, exit_label);
1413 gfc_add_expr_to_block (&implied_do_block, tmp);
1415 /* Finishe the implied-do loop. */
1416 tmp = gfc_finish_block(&implied_do_block);
1417 gfc_add_expr_to_block(pblock, tmp);
1419 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1426 /* Figure out the string length of a variable reference expression.
1427 Used by get_array_ctor_strlen. */
1430 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1436 /* Don't bother if we already know the length is a constant. */
1437 if (*len && INTEGER_CST_P (*len))
1440 ts = &expr->symtree->n.sym->ts;
1441 for (ref = expr->ref; ref; ref = ref->next)
1446 /* Array references don't change the string length. */
1450 /* Use the length of the component. */
1451 ts = &ref->u.c.component->ts;
1455 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1456 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1458 mpz_init_set_ui (char_len, 1);
1459 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1460 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1461 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1462 *len = convert (gfc_charlen_type_node, *len);
1463 mpz_clear (char_len);
1467 /* TODO: Substrings are tricky because we can't evaluate the
1468 expression more than once. For now we just give up, and hope
1469 we can figure it out elsewhere. */
1474 *len = ts->cl->backend_decl;
1478 /* A catch-all to obtain the string length for anything that is not a
1479 constant, array or variable. */
1481 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1486 /* Don't bother if we already know the length is a constant. */
1487 if (*len && INTEGER_CST_P (*len))
1490 if (!e->ref && e->ts.cl && e->ts.cl->length
1491 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1494 gfc_conv_const_charlen (e->ts.cl);
1495 *len = e->ts.cl->backend_decl;
1499 /* Otherwise, be brutal even if inefficient. */
1500 ss = gfc_walk_expr (e);
1501 gfc_init_se (&se, NULL);
1503 /* No function call, in case of side effects. */
1504 se.no_function_call = 1;
1505 if (ss == gfc_ss_terminator)
1506 gfc_conv_expr (&se, e);
1508 gfc_conv_expr_descriptor (&se, e, ss);
1510 /* Fix the value. */
1511 *len = gfc_evaluate_now (se.string_length, &se.pre);
1513 gfc_add_block_to_block (block, &se.pre);
1514 gfc_add_block_to_block (block, &se.post);
1516 e->ts.cl->backend_decl = *len;
1521 /* Figure out the string length of a character array constructor.
1522 If len is NULL, don't calculate the length; this happens for recursive calls
1523 when a sub-array-constructor is an element but not at the first position,
1524 so when we're not interested in the length.
1525 Returns TRUE if all elements are character constants. */
1528 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1537 *len = build_int_cstu (gfc_charlen_type_node, 0);
1541 /* Loop over all constructor elements to find out is_const, but in len we
1542 want to store the length of the first, not the last, element. We can
1543 of course exit the loop as soon as is_const is found to be false. */
1544 for (; c && is_const; c = c->next)
1546 switch (c->expr->expr_type)
1549 if (len && !(*len && INTEGER_CST_P (*len)))
1550 *len = build_int_cstu (gfc_charlen_type_node,
1551 c->expr->value.character.length);
1555 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1562 get_array_ctor_var_strlen (c->expr, len);
1568 get_array_ctor_all_strlen (block, c->expr, len);
1572 /* After the first iteration, we don't want the length modified. */
1579 /* Check whether the array constructor C consists entirely of constant
1580 elements, and if so returns the number of those elements, otherwise
1581 return zero. Note, an empty or NULL array constructor returns zero. */
1583 unsigned HOST_WIDE_INT
1584 gfc_constant_array_constructor_p (gfc_constructor * c)
1586 unsigned HOST_WIDE_INT nelem = 0;
1591 || c->expr->rank > 0
1592 || c->expr->expr_type != EXPR_CONSTANT)
1601 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1602 and the tree type of it's elements, TYPE, return a static constant
1603 variable that is compile-time initialized. */
1606 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1608 tree tmptype, list, init, tmp;
1609 HOST_WIDE_INT nelem;
1615 /* First traverse the constructor list, converting the constants
1616 to tree to build an initializer. */
1619 c = expr->value.constructor;
1622 gfc_init_se (&se, NULL);
1623 gfc_conv_constant (&se, c->expr);
1624 if (c->expr->ts.type != BT_CHARACTER)
1625 se.expr = fold_convert (type, se.expr);
1626 else if (POINTER_TYPE_P (type))
1627 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1629 list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1635 /* Next determine the tree type for the array. We use the gfortran
1636 front-end's gfc_get_nodesc_array_type in order to create a suitable
1637 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1639 memset (&as, 0, sizeof (gfc_array_spec));
1641 as.rank = expr->rank;
1642 as.type = AS_EXPLICIT;
1645 as.lower[0] = gfc_int_expr (0);
1646 as.upper[0] = gfc_int_expr (nelem - 1);
1649 for (i = 0; i < expr->rank; i++)
1651 int tmp = (int) mpz_get_si (expr->shape[i]);
1652 as.lower[i] = gfc_int_expr (0);
1653 as.upper[i] = gfc_int_expr (tmp - 1);
1656 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1658 init = build_constructor_from_list (tmptype, nreverse (list));
1660 TREE_CONSTANT (init) = 1;
1661 TREE_STATIC (init) = 1;
1663 tmp = gfc_create_var (tmptype, "A");
1664 TREE_STATIC (tmp) = 1;
1665 TREE_CONSTANT (tmp) = 1;
1666 TREE_READONLY (tmp) = 1;
1667 DECL_INITIAL (tmp) = init;
1673 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1674 This mostly initializes the scalarizer state info structure with the
1675 appropriate values to directly use the array created by the function
1676 gfc_build_constant_array_constructor. */
1679 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1680 gfc_ss * ss, tree type)
1686 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1688 info = &ss->data.info;
1690 info->descriptor = tmp;
1691 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1692 info->offset = gfc_index_zero_node;
1694 for (i = 0; i < info->dimen; i++)
1696 info->delta[i] = gfc_index_zero_node;
1697 info->start[i] = gfc_index_zero_node;
1698 info->end[i] = gfc_index_zero_node;
1699 info->stride[i] = gfc_index_one_node;
1703 if (info->dimen > loop->temp_dim)
1704 loop->temp_dim = info->dimen;
1707 /* Helper routine of gfc_trans_array_constructor to determine if the
1708 bounds of the loop specified by LOOP are constant and simple enough
1709 to use with gfc_trans_constant_array_constructor. Returns the
1710 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1713 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1715 tree size = gfc_index_one_node;
1719 for (i = 0; i < loop->dimen; i++)
1721 /* If the bounds aren't constant, return NULL_TREE. */
1722 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1724 if (!integer_zerop (loop->from[i]))
1726 /* Only allow nonzero "from" in one-dimensional arrays. */
1727 if (loop->dimen != 1)
1729 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1730 loop->to[i], loop->from[i]);
1734 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1735 tmp, gfc_index_one_node);
1736 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1743 /* Array constructors are handled by constructing a temporary, then using that
1744 within the scalarization loop. This is not optimal, but seems by far the
1748 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1756 bool old_first_len, old_typespec_chararray_ctor;
1757 tree old_first_len_val;
1759 /* Save the old values for nested checking. */
1760 old_first_len = first_len;
1761 old_first_len_val = first_len_val;
1762 old_typespec_chararray_ctor = typespec_chararray_ctor;
1764 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1765 typespec was given for the array constructor. */
1766 typespec_chararray_ctor = (ss->expr->ts.cl
1767 && ss->expr->ts.cl->length_from_typespec);
1769 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1770 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1772 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1776 ss->data.info.dimen = loop->dimen;
1778 c = ss->expr->value.constructor;
1779 if (ss->expr->ts.type == BT_CHARACTER)
1783 /* get_array_ctor_strlen walks the elements of the constructor, if a
1784 typespec was given, we already know the string length and want the one
1786 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1787 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1791 const_string = false;
1792 gfc_init_se (&length_se, NULL);
1793 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1794 gfc_charlen_type_node);
1795 ss->string_length = length_se.expr;
1796 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1797 gfc_add_block_to_block (&loop->post, &length_se.post);
1800 const_string = get_array_ctor_strlen (&loop->pre, c,
1801 &ss->string_length);
1803 /* Complex character array constructors should have been taken care of
1804 and not end up here. */
1805 gcc_assert (ss->string_length);
1807 ss->expr->ts.cl->backend_decl = ss->string_length;
1809 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1811 type = build_pointer_type (type);
1814 type = gfc_typenode_for_spec (&ss->expr->ts);
1816 /* See if the constructor determines the loop bounds. */
1819 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1821 /* We have a multidimensional parameter. */
1823 for (n = 0; n < ss->expr->rank; n++)
1825 loop->from[n] = gfc_index_zero_node;
1826 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1827 gfc_index_integer_kind);
1828 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1829 loop->to[n], gfc_index_one_node);
1833 if (loop->to[0] == NULL_TREE)
1837 /* We should have a 1-dimensional, zero-based loop. */
1838 gcc_assert (loop->dimen == 1);
1839 gcc_assert (integer_zerop (loop->from[0]));
1841 /* Split the constructor size into a static part and a dynamic part.
1842 Allocate the static size up-front and record whether the dynamic
1843 size might be nonzero. */
1845 dynamic = gfc_get_array_constructor_size (&size, c);
1846 mpz_sub_ui (size, size, 1);
1847 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1851 /* Special case constant array constructors. */
1854 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1857 tree size = constant_array_constructor_loop_size (loop);
1858 if (size && compare_tree_int (size, nelem) == 0)
1860 gfc_trans_constant_array_constructor (loop, ss, type);
1866 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1867 type, NULL_TREE, dynamic, true, false, where);
1869 desc = ss->data.info.descriptor;
1870 offset = gfc_index_zero_node;
1871 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1872 TREE_NO_WARNING (offsetvar) = 1;
1873 TREE_USED (offsetvar) = 0;
1874 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1875 &offset, &offsetvar, dynamic);
1877 /* If the array grows dynamically, the upper bound of the loop variable
1878 is determined by the array's final upper bound. */
1880 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1882 if (TREE_USED (offsetvar))
1883 pushdecl (offsetvar);
1885 gcc_assert (INTEGER_CST_P (offset));
1887 /* Disable bound checking for now because it's probably broken. */
1888 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1895 /* Restore old values of globals. */
1896 first_len = old_first_len;
1897 first_len_val = old_first_len_val;
1898 typespec_chararray_ctor = old_typespec_chararray_ctor;
1902 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1903 called after evaluating all of INFO's vector dimensions. Go through
1904 each such vector dimension and see if we can now fill in any missing
1908 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1917 for (n = 0; n < loop->dimen; n++)
1920 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1921 && loop->to[n] == NULL)
1923 /* Loop variable N indexes vector dimension DIM, and we don't
1924 yet know the upper bound of loop variable N. Set it to the
1925 difference between the vector's upper and lower bounds. */
1926 gcc_assert (loop->from[n] == gfc_index_zero_node);
1927 gcc_assert (info->subscript[dim]
1928 && info->subscript[dim]->type == GFC_SS_VECTOR);
1930 gfc_init_se (&se, NULL);
1931 desc = info->subscript[dim]->data.info.descriptor;
1932 zero = gfc_rank_cst[0];
1933 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1934 gfc_conv_descriptor_ubound (desc, zero),
1935 gfc_conv_descriptor_lbound (desc, zero));
1936 tmp = gfc_evaluate_now (tmp, &loop->pre);
1943 /* Add the pre and post chains for all the scalar expressions in a SS chain
1944 to loop. This is called after the loop parameters have been calculated,
1945 but before the actual scalarizing loops. */
1948 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1954 /* TODO: This can generate bad code if there are ordering dependencies,
1955 e.g., a callee allocated function and an unknown size constructor. */
1956 gcc_assert (ss != NULL);
1958 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1965 /* Scalar expression. Evaluate this now. This includes elemental
1966 dimension indices, but not array section bounds. */
1967 gfc_init_se (&se, NULL);
1968 gfc_conv_expr (&se, ss->expr);
1969 gfc_add_block_to_block (&loop->pre, &se.pre);
1971 if (ss->expr->ts.type != BT_CHARACTER)
1973 /* Move the evaluation of scalar expressions outside the
1974 scalarization loop, except for WHERE assignments. */
1976 se.expr = convert(gfc_array_index_type, se.expr);
1978 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1979 gfc_add_block_to_block (&loop->pre, &se.post);
1982 gfc_add_block_to_block (&loop->post, &se.post);
1984 ss->data.scalar.expr = se.expr;
1985 ss->string_length = se.string_length;
1988 case GFC_SS_REFERENCE:
1989 /* Scalar reference. Evaluate this now. */
1990 gfc_init_se (&se, NULL);
1991 gfc_conv_expr_reference (&se, ss->expr);
1992 gfc_add_block_to_block (&loop->pre, &se.pre);
1993 gfc_add_block_to_block (&loop->post, &se.post);
1995 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1996 ss->string_length = se.string_length;
1999 case GFC_SS_SECTION:
2000 /* Add the expressions for scalar and vector subscripts. */
2001 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2002 if (ss->data.info.subscript[n])
2003 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2006 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2010 /* Get the vector's descriptor and store it in SS. */
2011 gfc_init_se (&se, NULL);
2012 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2013 gfc_add_block_to_block (&loop->pre, &se.pre);
2014 gfc_add_block_to_block (&loop->post, &se.post);
2015 ss->data.info.descriptor = se.expr;
2018 case GFC_SS_INTRINSIC:
2019 gfc_add_intrinsic_ss_code (loop, ss);
2022 case GFC_SS_FUNCTION:
2023 /* Array function return value. We call the function and save its
2024 result in a temporary for use inside the loop. */
2025 gfc_init_se (&se, NULL);
2028 gfc_conv_expr (&se, ss->expr);
2029 gfc_add_block_to_block (&loop->pre, &se.pre);
2030 gfc_add_block_to_block (&loop->post, &se.post);
2031 ss->string_length = se.string_length;
2034 case GFC_SS_CONSTRUCTOR:
2035 if (ss->expr->ts.type == BT_CHARACTER
2036 && ss->string_length == NULL
2038 && ss->expr->ts.cl->length)
2040 gfc_init_se (&se, NULL);
2041 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
2042 gfc_charlen_type_node);
2043 ss->string_length = se.expr;
2044 gfc_add_block_to_block (&loop->pre, &se.pre);
2045 gfc_add_block_to_block (&loop->post, &se.post);
2047 gfc_trans_array_constructor (loop, ss, where);
2051 case GFC_SS_COMPONENT:
2052 /* Do nothing. These are handled elsewhere. */
2062 /* Translate expressions for the descriptor and data pointer of a SS. */
2066 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2071 /* Get the descriptor for the array to be scalarized. */
2072 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2073 gfc_init_se (&se, NULL);
2074 se.descriptor_only = 1;
2075 gfc_conv_expr_lhs (&se, ss->expr);
2076 gfc_add_block_to_block (block, &se.pre);
2077 ss->data.info.descriptor = se.expr;
2078 ss->string_length = se.string_length;
2082 /* Also the data pointer. */
2083 tmp = gfc_conv_array_data (se.expr);
2084 /* If this is a variable or address of a variable we use it directly.
2085 Otherwise we must evaluate it now to avoid breaking dependency
2086 analysis by pulling the expressions for elemental array indices
2089 || (TREE_CODE (tmp) == ADDR_EXPR
2090 && DECL_P (TREE_OPERAND (tmp, 0)))))
2091 tmp = gfc_evaluate_now (tmp, block);
2092 ss->data.info.data = tmp;
2094 tmp = gfc_conv_array_offset (se.expr);
2095 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2100 /* Initialize a gfc_loopinfo structure. */
2103 gfc_init_loopinfo (gfc_loopinfo * loop)
2107 memset (loop, 0, sizeof (gfc_loopinfo));
2108 gfc_init_block (&loop->pre);
2109 gfc_init_block (&loop->post);
2111 /* Initially scalarize in order. */
2112 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2115 loop->ss = gfc_ss_terminator;
2119 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2123 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2129 /* Return an expression for the data pointer of an array. */
2132 gfc_conv_array_data (tree descriptor)
2136 type = TREE_TYPE (descriptor);
2137 if (GFC_ARRAY_TYPE_P (type))
2139 if (TREE_CODE (type) == POINTER_TYPE)
2143 /* Descriptorless arrays. */
2144 return gfc_build_addr_expr (NULL_TREE, descriptor);
2148 return gfc_conv_descriptor_data_get (descriptor);
2152 /* Return an expression for the base offset of an array. */
2155 gfc_conv_array_offset (tree descriptor)
2159 type = TREE_TYPE (descriptor);
2160 if (GFC_ARRAY_TYPE_P (type))
2161 return GFC_TYPE_ARRAY_OFFSET (type);
2163 return gfc_conv_descriptor_offset (descriptor);
2167 /* Get an expression for the array stride. */
2170 gfc_conv_array_stride (tree descriptor, int dim)
2175 type = TREE_TYPE (descriptor);
2177 /* For descriptorless arrays use the array size. */
2178 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2179 if (tmp != NULL_TREE)
2182 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2187 /* Like gfc_conv_array_stride, but for the lower bound. */
2190 gfc_conv_array_lbound (tree descriptor, int dim)
2195 type = TREE_TYPE (descriptor);
2197 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2198 if (tmp != NULL_TREE)
2201 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2206 /* Like gfc_conv_array_stride, but for the upper bound. */
2209 gfc_conv_array_ubound (tree descriptor, int dim)
2214 type = TREE_TYPE (descriptor);
2216 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2217 if (tmp != NULL_TREE)
2220 /* This should only ever happen when passing an assumed shape array
2221 as an actual parameter. The value will never be used. */
2222 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2223 return gfc_index_zero_node;
2225 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2230 /* Generate code to perform an array index bound check. */
2233 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2234 locus * where, bool check_upper)
2239 const char * name = NULL;
2241 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2244 index = gfc_evaluate_now (index, &se->pre);
2246 /* We find a name for the error message. */
2248 name = se->ss->expr->symtree->name;
2250 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2251 && se->loop->ss->expr->symtree)
2252 name = se->loop->ss->expr->symtree->name;
2254 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2255 && se->loop->ss->loop_chain->expr
2256 && se->loop->ss->loop_chain->expr->symtree)
2257 name = se->loop->ss->loop_chain->expr->symtree->name;
2259 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2260 && se->loop->ss->loop_chain->expr->symtree)
2261 name = se->loop->ss->loop_chain->expr->symtree->name;
2263 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2265 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2266 && se->loop->ss->expr->value.function.name)
2267 name = se->loop->ss->expr->value.function.name;
2269 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2270 || se->loop->ss->type == GFC_SS_SCALAR)
2271 name = "unnamed constant";
2274 /* Check lower bound. */
2275 tmp = gfc_conv_array_lbound (descriptor, n);
2276 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2278 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2279 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2281 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2282 gfc_msg_fault, n+1);
2283 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2284 fold_convert (long_integer_type_node, index),
2285 fold_convert (long_integer_type_node, tmp));
2288 /* Check upper bound. */
2291 tmp = gfc_conv_array_ubound (descriptor, n);
2292 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2294 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2295 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2297 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2298 gfc_msg_fault, n+1);
2299 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2300 fold_convert (long_integer_type_node, index),
2301 fold_convert (long_integer_type_node, tmp));
2309 /* Return the offset for an index. Performs bound checking for elemental
2310 dimensions. Single element references are processed separately. */
2313 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2314 gfc_array_ref * ar, tree stride)
2320 /* Get the index into the array for this dimension. */
2323 gcc_assert (ar->type != AR_ELEMENT);
2324 switch (ar->dimen_type[dim])
2327 /* Elemental dimension. */
2328 gcc_assert (info->subscript[dim]
2329 && info->subscript[dim]->type == GFC_SS_SCALAR);
2330 /* We've already translated this value outside the loop. */
2331 index = info->subscript[dim]->data.scalar.expr;
2333 index = gfc_trans_array_bound_check (se, info->descriptor,
2334 index, dim, &ar->where,
2335 (ar->as->type != AS_ASSUMED_SIZE
2336 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2340 gcc_assert (info && se->loop);
2341 gcc_assert (info->subscript[dim]
2342 && info->subscript[dim]->type == GFC_SS_VECTOR);
2343 desc = info->subscript[dim]->data.info.descriptor;
2345 /* Get a zero-based index into the vector. */
2346 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2347 se->loop->loopvar[i], se->loop->from[i]);
2349 /* Multiply the index by the stride. */
2350 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2351 index, gfc_conv_array_stride (desc, 0));
2353 /* Read the vector to get an index into info->descriptor. */
2354 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2355 index = gfc_build_array_ref (data, index, NULL);
2356 index = gfc_evaluate_now (index, &se->pre);
2358 /* Do any bounds checking on the final info->descriptor index. */
2359 index = gfc_trans_array_bound_check (se, info->descriptor,
2360 index, dim, &ar->where,
2361 (ar->as->type != AS_ASSUMED_SIZE
2362 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2366 /* Scalarized dimension. */
2367 gcc_assert (info && se->loop);
2369 /* Multiply the loop variable by the stride and delta. */
2370 index = se->loop->loopvar[i];
2371 if (!integer_onep (info->stride[i]))
2372 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2374 if (!integer_zerop (info->delta[i]))
2375 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2385 /* Temporary array or derived type component. */
2386 gcc_assert (se->loop);
2387 index = se->loop->loopvar[se->loop->order[i]];
2388 if (!integer_zerop (info->delta[i]))
2389 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2390 index, info->delta[i]);
2393 /* Multiply by the stride. */
2394 if (!integer_onep (stride))
2395 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2401 /* Build a scalarized reference to an array. */
2404 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2407 tree decl = NULL_TREE;
2412 info = &se->ss->data.info;
2414 n = se->loop->order[0];
2418 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2420 /* Add the offset for this dimension to the stored offset for all other
2422 if (!integer_zerop (info->offset))
2423 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2425 if (se->ss->expr && is_subref_array (se->ss->expr))
2426 decl = se->ss->expr->symtree->n.sym->backend_decl;
2428 tmp = build_fold_indirect_ref (info->data);
2429 se->expr = gfc_build_array_ref (tmp, index, decl);
2433 /* Translate access of temporary array. */
2436 gfc_conv_tmp_array_ref (gfc_se * se)
2438 se->string_length = se->ss->string_length;
2439 gfc_conv_scalarized_array_ref (se, NULL);
2443 /* Build an array reference. se->expr already holds the array descriptor.
2444 This should be either a variable, indirect variable reference or component
2445 reference. For arrays which do not have a descriptor, se->expr will be
2447 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2450 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2460 /* Handle scalarized references separately. */
2461 if (ar->type != AR_ELEMENT)
2463 gfc_conv_scalarized_array_ref (se, ar);
2464 gfc_advance_se_ss_chain (se);
2468 index = gfc_index_zero_node;
2470 /* Calculate the offsets from all the dimensions. */
2471 for (n = 0; n < ar->dimen; n++)
2473 /* Calculate the index for this dimension. */
2474 gfc_init_se (&indexse, se);
2475 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2476 gfc_add_block_to_block (&se->pre, &indexse.pre);
2478 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2480 /* Check array bounds. */
2484 /* Evaluate the indexse.expr only once. */
2485 indexse.expr = save_expr (indexse.expr);
2488 tmp = gfc_conv_array_lbound (se->expr, n);
2489 if (sym->attr.temporary)
2491 gfc_init_se (&tmpse, se);
2492 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2493 gfc_array_index_type);
2494 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2498 cond = fold_build2 (LT_EXPR, boolean_type_node,
2500 asprintf (&msg, "%s for array '%s', "
2501 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2502 gfc_msg_fault, sym->name, n+1);
2503 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2504 fold_convert (long_integer_type_node,
2506 fold_convert (long_integer_type_node, tmp));
2509 /* Upper bound, but not for the last dimension of assumed-size
2511 if (n < ar->dimen - 1
2512 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2514 tmp = gfc_conv_array_ubound (se->expr, n);
2515 if (sym->attr.temporary)
2517 gfc_init_se (&tmpse, se);
2518 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2519 gfc_array_index_type);
2520 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2524 cond = fold_build2 (GT_EXPR, boolean_type_node,
2526 asprintf (&msg, "%s for array '%s', "
2527 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2528 gfc_msg_fault, sym->name, n+1);
2529 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2530 fold_convert (long_integer_type_node,
2532 fold_convert (long_integer_type_node, tmp));
2537 /* Multiply the index by the stride. */
2538 stride = gfc_conv_array_stride (se->expr, n);
2539 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2542 /* And add it to the total. */
2543 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2546 tmp = gfc_conv_array_offset (se->expr);
2547 if (!integer_zerop (tmp))
2548 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2550 /* Access the calculated element. */
2551 tmp = gfc_conv_array_data (se->expr);
2552 tmp = build_fold_indirect_ref (tmp);
2553 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2557 /* Generate the code to be executed immediately before entering a
2558 scalarization loop. */
2561 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2562 stmtblock_t * pblock)
2571 /* This code will be executed before entering the scalarization loop
2572 for this dimension. */
2573 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2575 if ((ss->useflags & flag) == 0)
2578 if (ss->type != GFC_SS_SECTION
2579 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2580 && ss->type != GFC_SS_COMPONENT)
2583 info = &ss->data.info;
2585 if (dim >= info->dimen)
2588 if (dim == info->dimen - 1)
2590 /* For the outermost loop calculate the offset due to any
2591 elemental dimensions. It will have been initialized with the
2592 base offset of the array. */
2595 for (i = 0; i < info->ref->u.ar.dimen; i++)
2597 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2600 gfc_init_se (&se, NULL);
2602 se.expr = info->descriptor;
2603 stride = gfc_conv_array_stride (info->descriptor, i);
2604 index = gfc_conv_array_index_offset (&se, info, i, -1,
2607 gfc_add_block_to_block (pblock, &se.pre);
2609 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2610 info->offset, index);
2611 info->offset = gfc_evaluate_now (info->offset, pblock);
2615 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2618 stride = gfc_conv_array_stride (info->descriptor, 0);
2620 /* Calculate the stride of the innermost loop. Hopefully this will
2621 allow the backend optimizers to do their stuff more effectively.
2623 info->stride0 = gfc_evaluate_now (stride, pblock);
2627 /* Add the offset for the previous loop dimension. */
2632 ar = &info->ref->u.ar;
2633 i = loop->order[dim + 1];
2641 gfc_init_se (&se, NULL);
2643 se.expr = info->descriptor;
2644 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2645 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2647 gfc_add_block_to_block (pblock, &se.pre);
2648 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2649 info->offset, index);
2650 info->offset = gfc_evaluate_now (info->offset, pblock);
2653 /* Remember this offset for the second loop. */
2654 if (dim == loop->temp_dim - 1)
2655 info->saved_offset = info->offset;
2660 /* Start a scalarized expression. Creates a scope and declares loop
2664 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2670 gcc_assert (!loop->array_parameter);
2672 for (dim = loop->dimen - 1; dim >= 0; dim--)
2674 n = loop->order[dim];
2676 gfc_start_block (&loop->code[n]);
2678 /* Create the loop variable. */
2679 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2681 if (dim < loop->temp_dim)
2685 /* Calculate values that will be constant within this loop. */
2686 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2688 gfc_start_block (pbody);
2692 /* Generates the actual loop code for a scalarization loop. */
2695 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2696 stmtblock_t * pbody)
2707 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2708 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2709 && n == loop->dimen - 1)
2711 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2712 init = make_tree_vec (1);
2713 cond = make_tree_vec (1);
2714 incr = make_tree_vec (1);
2716 /* Cycle statement is implemented with a goto. Exit statement must not
2717 be present for this loop. */
2718 exit_label = gfc_build_label_decl (NULL_TREE);
2719 TREE_USED (exit_label) = 1;
2721 /* Label for cycle statements (if needed). */
2722 tmp = build1_v (LABEL_EXPR, exit_label);
2723 gfc_add_expr_to_block (pbody, tmp);
2725 stmt = make_node (OMP_FOR);
2727 TREE_TYPE (stmt) = void_type_node;
2728 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2730 OMP_FOR_CLAUSES (stmt) = build_omp_clause (OMP_CLAUSE_SCHEDULE);
2731 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2732 = OMP_CLAUSE_SCHEDULE_STATIC;
2733 if (ompws_flags & OMPWS_NOWAIT)
2734 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2735 = build_omp_clause (OMP_CLAUSE_NOWAIT);
2737 /* Initialize the loopvar. */
2738 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2740 OMP_FOR_INIT (stmt) = init;
2741 /* The exit condition. */
2742 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2743 loop->loopvar[n], loop->to[n]);
2744 OMP_FOR_COND (stmt) = cond;
2745 /* Increment the loopvar. */
2746 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2747 loop->loopvar[n], gfc_index_one_node);
2748 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2749 void_type_node, loop->loopvar[n], tmp);
2750 OMP_FOR_INCR (stmt) = incr;
2752 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2753 gfc_add_expr_to_block (&loop->code[n], stmt);
2757 loopbody = gfc_finish_block (pbody);
2759 /* Initialize the loopvar. */
2760 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2762 exit_label = gfc_build_label_decl (NULL_TREE);
2764 /* Generate the loop body. */
2765 gfc_init_block (&block);
2767 /* The exit condition. */
2768 cond = fold_build2 (GT_EXPR, boolean_type_node,
2769 loop->loopvar[n], loop->to[n]);
2770 tmp = build1_v (GOTO_EXPR, exit_label);
2771 TREE_USED (exit_label) = 1;
2772 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2773 gfc_add_expr_to_block (&block, tmp);
2775 /* The main body. */
2776 gfc_add_expr_to_block (&block, loopbody);
2778 /* Increment the loopvar. */
2779 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2780 loop->loopvar[n], gfc_index_one_node);
2781 gfc_add_modify (&block, loop->loopvar[n], tmp);
2783 /* Build the loop. */
2784 tmp = gfc_finish_block (&block);
2785 tmp = build1_v (LOOP_EXPR, tmp);
2786 gfc_add_expr_to_block (&loop->code[n], tmp);
2788 /* Add the exit label. */
2789 tmp = build1_v (LABEL_EXPR, exit_label);
2790 gfc_add_expr_to_block (&loop->code[n], tmp);
2796 /* Finishes and generates the loops for a scalarized expression. */
2799 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2804 stmtblock_t *pblock;
2808 /* Generate the loops. */
2809 for (dim = 0; dim < loop->dimen; dim++)
2811 n = loop->order[dim];
2812 gfc_trans_scalarized_loop_end (loop, n, pblock);
2813 loop->loopvar[n] = NULL_TREE;
2814 pblock = &loop->code[n];
2817 tmp = gfc_finish_block (pblock);
2818 gfc_add_expr_to_block (&loop->pre, tmp);
2820 /* Clear all the used flags. */
2821 for (ss = loop->ss; ss; ss = ss->loop_chain)
2826 /* Finish the main body of a scalarized expression, and start the secondary
2830 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2834 stmtblock_t *pblock;
2838 /* We finish as many loops as are used by the temporary. */
2839 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2841 n = loop->order[dim];
2842 gfc_trans_scalarized_loop_end (loop, n, pblock);
2843 loop->loopvar[n] = NULL_TREE;
2844 pblock = &loop->code[n];
2847 /* We don't want to finish the outermost loop entirely. */
2848 n = loop->order[loop->temp_dim - 1];
2849 gfc_trans_scalarized_loop_end (loop, n, pblock);
2851 /* Restore the initial offsets. */
2852 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2854 if ((ss->useflags & 2) == 0)
2857 if (ss->type != GFC_SS_SECTION
2858 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2859 && ss->type != GFC_SS_COMPONENT)
2862 ss->data.info.offset = ss->data.info.saved_offset;
2865 /* Restart all the inner loops we just finished. */
2866 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2868 n = loop->order[dim];
2870 gfc_start_block (&loop->code[n]);
2872 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2874 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2877 /* Start a block for the secondary copying code. */
2878 gfc_start_block (body);
2882 /* Calculate the upper bound of an array section. */
2885 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2894 gcc_assert (ss->type == GFC_SS_SECTION);
2896 info = &ss->data.info;
2899 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2900 /* We'll calculate the upper bound once we have access to the
2901 vector's descriptor. */
2904 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2905 desc = info->descriptor;
2906 end = info->ref->u.ar.end[dim];
2910 /* The upper bound was specified. */
2911 gfc_init_se (&se, NULL);
2912 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2913 gfc_add_block_to_block (pblock, &se.pre);
2918 /* No upper bound was specified, so use the bound of the array. */
2919 bound = gfc_conv_array_ubound (desc, dim);
2926 /* Calculate the lower bound of an array section. */
2929 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2939 gcc_assert (ss->type == GFC_SS_SECTION);
2941 info = &ss->data.info;
2944 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2946 /* We use a zero-based index to access the vector. */
2947 info->start[n] = gfc_index_zero_node;
2948 info->end[n] = gfc_index_zero_node;
2949 info->stride[n] = gfc_index_one_node;
2953 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2954 desc = info->descriptor;
2955 start = info->ref->u.ar.start[dim];
2956 end = info->ref->u.ar.end[dim];
2957 stride = info->ref->u.ar.stride[dim];
2959 /* Calculate the start of the range. For vector subscripts this will
2960 be the range of the vector. */
2963 /* Specified section start. */
2964 gfc_init_se (&se, NULL);
2965 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2966 gfc_add_block_to_block (&loop->pre, &se.pre);
2967 info->start[n] = se.expr;
2971 /* No lower bound specified so use the bound of the array. */
2972 info->start[n] = gfc_conv_array_lbound (desc, dim);
2974 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2976 /* Similarly calculate the end. Although this is not used in the
2977 scalarizer, it is needed when checking bounds and where the end
2978 is an expression with side-effects. */
2981 /* Specified section start. */
2982 gfc_init_se (&se, NULL);
2983 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2984 gfc_add_block_to_block (&loop->pre, &se.pre);
2985 info->end[n] = se.expr;
2989 /* No upper bound specified so use the bound of the array. */
2990 info->end[n] = gfc_conv_array_ubound (desc, dim);
2992 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2994 /* Calculate the stride. */
2996 info->stride[n] = gfc_index_one_node;
2999 gfc_init_se (&se, NULL);
3000 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3001 gfc_add_block_to_block (&loop->pre, &se.pre);
3002 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3007 /* Calculates the range start and stride for a SS chain. Also gets the
3008 descriptor and data pointer. The range of vector subscripts is the size
3009 of the vector. Array bounds are also checked. */
3012 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3020 /* Determine the rank of the loop. */
3022 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3026 case GFC_SS_SECTION:
3027 case GFC_SS_CONSTRUCTOR:
3028 case GFC_SS_FUNCTION:
3029 case GFC_SS_COMPONENT:
3030 loop->dimen = ss->data.info.dimen;
3033 /* As usual, lbound and ubound are exceptions!. */
3034 case GFC_SS_INTRINSIC:
3035 switch (ss->expr->value.function.isym->id)
3037 case GFC_ISYM_LBOUND:
3038 case GFC_ISYM_UBOUND:
3039 loop->dimen = ss->data.info.dimen;
3050 /* We should have determined the rank of the expression by now. If
3051 not, that's bad news. */
3052 gcc_assert (loop->dimen != 0);
3054 /* Loop over all the SS in the chain. */
3055 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3057 if (ss->expr && ss->expr->shape && !ss->shape)
3058 ss->shape = ss->expr->shape;
3062 case GFC_SS_SECTION:
3063 /* Get the descriptor for the array. */
3064 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3066 for (n = 0; n < ss->data.info.dimen; n++)
3067 gfc_conv_section_startstride (loop, ss, n);
3070 case GFC_SS_INTRINSIC:
3071 switch (ss->expr->value.function.isym->id)
3073 /* Fall through to supply start and stride. */
3074 case GFC_ISYM_LBOUND:
3075 case GFC_ISYM_UBOUND:
3081 case GFC_SS_CONSTRUCTOR:
3082 case GFC_SS_FUNCTION:
3083 for (n = 0; n < ss->data.info.dimen; n++)
3085 ss->data.info.start[n] = gfc_index_zero_node;
3086 ss->data.info.end[n] = gfc_index_zero_node;
3087 ss->data.info.stride[n] = gfc_index_one_node;
3096 /* The rest is just runtime bound checking. */
3097 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3100 tree lbound, ubound;
3102 tree size[GFC_MAX_DIMENSIONS];
3103 tree stride_pos, stride_neg, non_zerosized, tmp2;
3108 gfc_start_block (&block);
3110 for (n = 0; n < loop->dimen; n++)
3111 size[n] = NULL_TREE;
3113 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3117 if (ss->type != GFC_SS_SECTION)
3120 gfc_start_block (&inner);
3122 /* TODO: range checking for mapped dimensions. */
3123 info = &ss->data.info;
3125 /* This code only checks ranges. Elemental and vector
3126 dimensions are checked later. */
3127 for (n = 0; n < loop->dimen; n++)
3132 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3135 if (dim == info->ref->u.ar.dimen - 1
3136 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3137 || info->ref->u.ar.as->cp_was_assumed))
3138 check_upper = false;
3142 /* Zero stride is not allowed. */
3143 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3144 gfc_index_zero_node);
3145 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3146 "of array '%s'", info->dim[n]+1,
3147 ss->expr->symtree->name);
3148 gfc_trans_runtime_check (true, false, tmp, &inner,
3149 &ss->expr->where, msg);
3152 desc = ss->data.info.descriptor;
3154 /* This is the run-time equivalent of resolve.c's
3155 check_dimension(). The logical is more readable there
3156 than it is here, with all the trees. */
3157 lbound = gfc_conv_array_lbound (desc, dim);
3160 ubound = gfc_conv_array_ubound (desc, dim);
3164 /* non_zerosized is true when the selected range is not
3166 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3167 info->stride[n], gfc_index_zero_node);
3168 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3170 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3173 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3174 info->stride[n], gfc_index_zero_node);
3175 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3177 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3179 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3180 stride_pos, stride_neg);
3182 /* Check the start of the range against the lower and upper
3183 bounds of the array, if the range is not empty. */
3184 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3186 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3187 non_zerosized, tmp);
3188 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3189 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3190 info->dim[n]+1, ss->expr->symtree->name);
3191 gfc_trans_runtime_check (true, false, tmp, &inner,
3192 &ss->expr->where, msg,
3193 fold_convert (long_integer_type_node,
3195 fold_convert (long_integer_type_node,
3201 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3202 info->start[n], ubound);
3203 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3204 non_zerosized, tmp);
3205 asprintf (&msg, "%s, upper bound of dimension %d of array "
3206 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3207 info->dim[n]+1, ss->expr->symtree->name);
3208 gfc_trans_runtime_check (true, false, tmp, &inner,
3209 &ss->expr->where, msg,
3210 fold_convert (long_integer_type_node, info->start[n]),
3211 fold_convert (long_integer_type_node, ubound));
3215 /* Compute the last element of the range, which is not
3216 necessarily "end" (think 0:5:3, which doesn't contain 5)
3217 and check it against both lower and upper bounds. */
3218 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3220 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3222 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3225 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3226 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3227 non_zerosized, tmp);
3228 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3229 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3230 info->dim[n]+1, ss->expr->symtree->name);
3231 gfc_trans_runtime_check (true, false, tmp, &inner,
3232 &ss->expr->where, msg,
3233 fold_convert (long_integer_type_node,
3235 fold_convert (long_integer_type_node,
3241 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3242 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3243 non_zerosized, tmp);
3244 asprintf (&msg, "%s, upper bound of dimension %d of array "
3245 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3246 info->dim[n]+1, ss->expr->symtree->name);
3247 gfc_trans_runtime_check (true, false, tmp, &inner,
3248 &ss->expr->where, msg,
3249 fold_convert (long_integer_type_node, tmp2),
3250 fold_convert (long_integer_type_node, ubound));
3254 /* Check the section sizes match. */
3255 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3257 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3259 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3260 build_int_cst (gfc_array_index_type, 0));
3261 /* We remember the size of the first section, and check all the
3262 others against this. */
3267 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3268 asprintf (&msg, "%s, size mismatch for dimension %d "
3269 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3270 info->dim[n]+1, ss->expr->symtree->name);
3271 gfc_trans_runtime_check (true, false, tmp3, &inner,
3272 &ss->expr->where, msg,
3273 fold_convert (long_integer_type_node, tmp),
3274 fold_convert (long_integer_type_node, size[n]));
3278 size[n] = gfc_evaluate_now (tmp, &inner);
3281 tmp = gfc_finish_block (&inner);
3283 /* For optional arguments, only check bounds if the argument is
3285 if (ss->expr->symtree->n.sym->attr.optional
3286 || ss->expr->symtree->n.sym->attr.not_always_present)
3287 tmp = build3_v (COND_EXPR,
3288 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3289 tmp, build_empty_stmt ());
3291 gfc_add_expr_to_block (&block, tmp);
3295 tmp = gfc_finish_block (&block);
3296 gfc_add_expr_to_block (&loop->pre, tmp);
3301 /* Return true if the two SS could be aliased, i.e. both point to the same data
3303 /* TODO: resolve aliases based on frontend expressions. */
3306 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3313 lsym = lss->expr->symtree->n.sym;
3314 rsym = rss->expr->symtree->n.sym;
3315 if (gfc_symbols_could_alias (lsym, rsym))
3318 if (rsym->ts.type != BT_DERIVED
3319 && lsym->ts.type != BT_DERIVED)
3322 /* For derived types we must check all the component types. We can ignore
3323 array references as these will have the same base type as the previous
3325 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3327 if (lref->type != REF_COMPONENT)
3330 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3333 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3336 if (rref->type != REF_COMPONENT)
3339 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3344 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3346 if (rref->type != REF_COMPONENT)
3349 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3357 /* Resolve array data dependencies. Creates a temporary if required. */
3358 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3362 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3372 loop->temp_ss = NULL;
3373 aref = dest->data.info.ref;
3376 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3378 if (ss->type != GFC_SS_SECTION)
3381 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3383 if (gfc_could_be_alias (dest, ss)
3384 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3392 lref = dest->expr->ref;
3393 rref = ss->expr->ref;
3395 nDepend = gfc_dep_resolver (lref, rref);
3399 /* TODO : loop shifting. */
3402 /* Mark the dimensions for LOOP SHIFTING */
3403 for (n = 0; n < loop->dimen; n++)
3405 int dim = dest->data.info.dim[n];
3407 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3409 else if (! gfc_is_same_range (&lref->u.ar,
3410 &rref->u.ar, dim, 0))
3414 /* Put all the dimensions with dependencies in the
3417 for (n = 0; n < loop->dimen; n++)
3419 gcc_assert (loop->order[n] == n);
3421 loop->order[dim++] = n;
3424 for (n = 0; n < loop->dimen; n++)
3427 loop->order[dim++] = n;
3430 gcc_assert (dim == loop->dimen);
3439 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3440 if (GFC_ARRAY_TYPE_P (base_type)
3441 || GFC_DESCRIPTOR_TYPE_P (base_type))
3442 base_type = gfc_get_element_type (base_type);
3443 loop->temp_ss = gfc_get_ss ();
3444 loop->temp_ss->type = GFC_SS_TEMP;
3445 loop->temp_ss->data.temp.type = base_type;
3446 loop->temp_ss->string_length = dest->string_length;
3447 loop->temp_ss->data.temp.dimen = loop->dimen;
3448 loop->temp_ss->next = gfc_ss_terminator;
3449 gfc_add_ss_to_loop (loop, loop->temp_ss);
3452 loop->temp_ss = NULL;
3456 /* Initialize the scalarization loop. Creates the loop variables. Determines
3457 the range of the loop variables. Creates a temporary if required.
3458 Calculates how to transform from loop variables to array indices for each
3459 expression. Also generates code for scalar expressions which have been
3460 moved outside the loop. */
3463 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3468 gfc_ss_info *specinfo;
3472 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3473 bool dynamic[GFC_MAX_DIMENSIONS];
3479 for (n = 0; n < loop->dimen; n++)
3483 /* We use one SS term, and use that to determine the bounds of the
3484 loop for this dimension. We try to pick the simplest term. */
3485 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3489 /* The frontend has worked out the size for us. */
3490 if (!loopspec[n] || !loopspec[n]->shape
3491 || !integer_zerop (loopspec[n]->data.info.start[n]))
3492 /* Prefer zero-based descriptors if possible. */
3497 if (ss->type == GFC_SS_CONSTRUCTOR)
3499 /* An unknown size constructor will always be rank one.
3500 Higher rank constructors will either have known shape,
3501 or still be wrapped in a call to reshape. */
3502 gcc_assert (loop->dimen == 1);
3504 /* Always prefer to use the constructor bounds if the size
3505 can be determined at compile time. Prefer not to otherwise,
3506 since the general case involves realloc, and it's better to
3507 avoid that overhead if possible. */
3508 c = ss->expr->value.constructor;
3509 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3510 if (!dynamic[n] || !loopspec[n])
3515 /* TODO: Pick the best bound if we have a choice between a
3516 function and something else. */
3517 if (ss->type == GFC_SS_FUNCTION)
3523 if (ss->type != GFC_SS_SECTION)
3527 specinfo = &loopspec[n]->data.info;
3530 info = &ss->data.info;
3534 /* Criteria for choosing a loop specifier (most important first):
3535 doesn't need realloc
3541 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3543 else if (integer_onep (info->stride[n])
3544 && !integer_onep (specinfo->stride[n]))
3546 else if (INTEGER_CST_P (info->stride[n])
3547 && !INTEGER_CST_P (specinfo->stride[n]))
3549 else if (INTEGER_CST_P (info->start[n])
3550 && !INTEGER_CST_P (specinfo->start[n]))
3552 /* We don't work out the upper bound.
3553 else if (INTEGER_CST_P (info->finish[n])
3554 && ! INTEGER_CST_P (specinfo->finish[n]))
3555 loopspec[n] = ss; */
3558 /* We should have found the scalarization loop specifier. If not,
3560 gcc_assert (loopspec[n]);
3562 info = &loopspec[n]->data.info;
3564 /* Set the extents of this range. */
3565 cshape = loopspec[n]->shape;
3566 if (cshape && INTEGER_CST_P (info->start[n])
3567 && INTEGER_CST_P (info->stride[n]))
3569 loop->from[n] = info->start[n];
3570 mpz_set (i, cshape[n]);
3571 mpz_sub_ui (i, i, 1);
3572 /* To = from + (size - 1) * stride. */
3573 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3574 if (!integer_onep (info->stride[n]))
3575 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3576 tmp, info->stride[n]);
3577 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3578 loop->from[n], tmp);
3582 loop->from[n] = info->start[n];
3583 switch (loopspec[n]->type)
3585 case GFC_SS_CONSTRUCTOR:
3586 /* The upper bound is calculated when we expand the
3588 gcc_assert (loop->to[n] == NULL_TREE);
3591 case GFC_SS_SECTION:
3592 /* Use the end expression if it exists and is not constant,
3593 so that it is only evaluated once. */
3594 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3595 loop->to[n] = info->end[n];
3597 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3601 case GFC_SS_FUNCTION:
3602 /* The loop bound will be set when we generate the call. */
3603 gcc_assert (loop->to[n] == NULL_TREE);
3611 /* Transform everything so we have a simple incrementing variable. */
3612 if (integer_onep (info->stride[n]))
3613 info->delta[n] = gfc_index_zero_node;
3616 /* Set the delta for this section. */
3617 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3618 /* Number of iterations is (end - start + step) / step.
3619 with start = 0, this simplifies to
3621 for (i = 0; i<=last; i++){...}; */
3622 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3623 loop->to[n], loop->from[n]);
3624 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3625 tmp, info->stride[n]);
3626 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3627 build_int_cst (gfc_array_index_type, -1));
3628 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3629 /* Make the loop variable start at 0. */
3630 loop->from[n] = gfc_index_zero_node;
3634 /* Add all the scalar code that can be taken out of the loops.
3635 This may include calculating the loop bounds, so do it before
3636 allocating the temporary. */
3637 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3639 /* If we want a temporary then create it. */
3640 if (loop->temp_ss != NULL)
3642 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3644 /* Make absolutely sure that this is a complete type. */
3645 if (loop->temp_ss->string_length)
3646 loop->temp_ss->data.temp.type
3647 = gfc_get_character_type_len_for_eltype
3648 (TREE_TYPE (loop->temp_ss->data.temp.type),
3649 loop->temp_ss->string_length);
3651 tmp = loop->temp_ss->data.temp.type;
3652 len = loop->temp_ss->string_length;
3653 n = loop->temp_ss->data.temp.dimen;
3654 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3655 loop->temp_ss->type = GFC_SS_SECTION;
3656 loop->temp_ss->data.info.dimen = n;
3657 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3658 &loop->temp_ss->data.info, tmp, NULL_TREE,
3659 false, true, false, where);
3662 for (n = 0; n < loop->temp_dim; n++)
3663 loopspec[loop->order[n]] = NULL;
3667 /* For array parameters we don't have loop variables, so don't calculate the
3669 if (loop->array_parameter)
3672 /* Calculate the translation from loop variables to array indices. */
3673 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3675 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3676 && ss->type != GFC_SS_CONSTRUCTOR)
3680 info = &ss->data.info;
3682 for (n = 0; n < info->dimen; n++)
3686 /* If we are specifying the range the delta is already set. */
3687 if (loopspec[n] != ss)
3689 /* Calculate the offset relative to the loop variable.
3690 First multiply by the stride. */
3691 tmp = loop->from[n];
3692 if (!integer_onep (info->stride[n]))
3693 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3694 tmp, info->stride[n]);
3696 /* Then subtract this from our starting value. */
3697 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3698 info->start[n], tmp);
3700 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3707 /* Fills in an array descriptor, and returns the size of the array. The size
3708 will be a simple_val, ie a variable or a constant. Also calculates the
3709 offset of the base. Returns the size of the array.
3713 for (n = 0; n < rank; n++)
3715 a.lbound[n] = specified_lower_bound;
3716 offset = offset + a.lbond[n] * stride;
3718 a.ubound[n] = specified_upper_bound;
3719 a.stride[n] = stride;
3720 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3721 stride = stride * size;
3728 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3729 gfc_expr ** lower, gfc_expr ** upper,
3730 stmtblock_t * pblock)
3742 stmtblock_t thenblock;
3743 stmtblock_t elseblock;
3748 type = TREE_TYPE (descriptor);
3750 stride = gfc_index_one_node;
3751 offset = gfc_index_zero_node;
3753 /* Set the dtype. */
3754 tmp = gfc_conv_descriptor_dtype (descriptor);
3755 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3757 or_expr = NULL_TREE;
3759 for (n = 0; n < rank; n++)
3761 /* We have 3 possibilities for determining the size of the array:
3762 lower == NULL => lbound = 1, ubound = upper[n]
3763 upper[n] = NULL => lbound = 1, ubound = lower[n]
3764 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3767 /* Set lower bound. */
3768 gfc_init_se (&se, NULL);
3770 se.expr = gfc_index_one_node;
3773 gcc_assert (lower[n]);
3776 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3777 gfc_add_block_to_block (pblock, &se.pre);
3781 se.expr = gfc_index_one_node;
3785 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3786 gfc_add_modify (pblock, tmp, se.expr);
3788 /* Work out the offset for this component. */
3789 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3790 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3792 /* Start the calculation for the size of this dimension. */
3793 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3794 gfc_index_one_node, se.expr);
3796 /* Set upper bound. */
3797 gfc_init_se (&se, NULL);
3798 gcc_assert (ubound);
3799 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3800 gfc_add_block_to_block (pblock, &se.pre);
3802 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3803 gfc_add_modify (pblock, tmp, se.expr);
3805 /* Store the stride. */
3806 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3807 gfc_add_modify (pblock, tmp, stride);
3809 /* Calculate the size of this dimension. */
3810 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3812 /* Check whether the size for this dimension is negative. */
3813 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3814 gfc_index_zero_node);
3818 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3820 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3821 gfc_index_zero_node, size);
3823 /* Multiply the stride by the number of elements in this dimension. */
3824 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3825 stride = gfc_evaluate_now (stride, pblock);
3828 /* The stride is the number of elements in the array, so multiply by the
3829 size of an element to get the total size. */
3830 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3831 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3832 fold_convert (gfc_array_index_type, tmp));
3834 if (poffset != NULL)
3836 offset = gfc_evaluate_now (offset, pblock);
3840 if (integer_zerop (or_expr))
3842 if (integer_onep (or_expr))
3843 return gfc_index_zero_node;
3845 var = gfc_create_var (TREE_TYPE (size), "size");
3846 gfc_start_block (&thenblock);
3847 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3848 thencase = gfc_finish_block (&thenblock);
3850 gfc_start_block (&elseblock);
3851 gfc_add_modify (&elseblock, var, size);
3852 elsecase = gfc_finish_block (&elseblock);
3854 tmp = gfc_evaluate_now (or_expr, pblock);
3855 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3856 gfc_add_expr_to_block (pblock, tmp);
3862 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3863 the work for an ALLOCATE statement. */
3867 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3875 gfc_ref *ref, *prev_ref = NULL;
3876 bool allocatable_array;
3880 /* Find the last reference in the chain. */
3881 while (ref && ref->next != NULL)
3883 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3888 if (ref == NULL || ref->type != REF_ARRAY)
3892 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3894 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3896 /* Figure out the size of the array. */
3897 switch (ref->u.ar.type)
3901 upper = ref->u.ar.start;
3905 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3907 lower = ref->u.ar.as->lower;
3908 upper = ref->u.ar.as->upper;
3912 lower = ref->u.ar.start;
3913 upper = ref->u.ar.end;
3921 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3922 lower, upper, &se->pre);
3924 /* Allocate memory to store the data. */
3925 pointer = gfc_conv_descriptor_data_get (se->expr);
3926 STRIP_NOPS (pointer);
3928 /* The allocate_array variants take the old pointer as first argument. */
3929 if (allocatable_array)
3930 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3932 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3933 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3934 gfc_add_expr_to_block (&se->pre, tmp);
3936 tmp = gfc_conv_descriptor_offset (se->expr);
3937 gfc_add_modify (&se->pre, tmp, offset);
3939 if (expr->ts.type == BT_DERIVED
3940 && expr->ts.derived->attr.alloc_comp)
3942 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3943 ref->u.ar.as->rank);
3944 gfc_add_expr_to_block (&se->pre, tmp);
3951 /* Deallocate an array variable. Also used when an allocated variable goes
3956 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3962 gfc_start_block (&block);
3963 /* Get a pointer to the data. */
3964 var = gfc_conv_descriptor_data_get (descriptor);
3967 /* Parameter is the address of the data component. */
3968 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3969 gfc_add_expr_to_block (&block, tmp);
3971 /* Zero the data pointer. */
3972 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3973 var, build_int_cst (TREE_TYPE (var), 0));
3974 gfc_add_expr_to_block (&block, tmp);
3976 return gfc_finish_block (&block);
3980 /* Create an array constructor from an initialization expression.
3981 We assume the frontend already did any expansions and conversions. */
3984 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3991 unsigned HOST_WIDE_INT lo;
3993 VEC(constructor_elt,gc) *v = NULL;
3995 switch (expr->expr_type)
3998 case EXPR_STRUCTURE:
3999 /* A single scalar or derived type value. Create an array with all
4000 elements equal to that value. */
4001 gfc_init_se (&se, NULL);
4003 if (expr->expr_type == EXPR_CONSTANT)
4004 gfc_conv_constant (&se, expr);
4006 gfc_conv_structure (&se, expr, 1);
4008 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4009 gcc_assert (tmp && INTEGER_CST_P (tmp));
4010 hi = TREE_INT_CST_HIGH (tmp);
4011 lo = TREE_INT_CST_LOW (tmp);
4015 /* This will probably eat buckets of memory for large arrays. */
4016 while (hi != 0 || lo != 0)
4018 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4026 /* Create a vector of all the elements. */
4027 for (c = expr->value.constructor; c; c = c->next)
4031 /* Problems occur when we get something like
4032 integer :: a(lots) = (/(i, i=1, lots)/) */
4033 gfc_error_now ("The number of elements in the array constructor "
4034 "at %L requires an increase of the allowed %d "
4035 "upper limit. See -fmax-array-constructor "
4036 "option", &expr->where,
4037 gfc_option.flag_max_array_constructor);
4040 if (mpz_cmp_si (c->n.offset, 0) != 0)
4041 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4045 if (mpz_cmp_si (c->repeat, 0) != 0)
4049 mpz_set (maxval, c->repeat);
4050 mpz_add (maxval, c->n.offset, maxval);
4051 mpz_sub_ui (maxval, maxval, 1);
4052 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4053 if (mpz_cmp_si (c->n.offset, 0) != 0)
4055 mpz_add_ui (maxval, c->n.offset, 1);
4056 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4059 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4061 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
4067 gfc_init_se (&se, NULL);
4068 switch (c->expr->expr_type)
4071 gfc_conv_constant (&se, c->expr);
4072 if (range == NULL_TREE)
4073 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4076 if (index != NULL_TREE)
4077 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4078 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4082 case EXPR_STRUCTURE:
4083 gfc_conv_structure (&se, c->expr, 1);
4084 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4089 /* Catch those occasional beasts that do not simplify
4090 for one reason or another, assuming that if they are
4091 standard defying the frontend will catch them. */
4092 gfc_conv_expr (&se, c->expr);
4093 if (range == NULL_TREE)
4094 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4097 if (index != NULL_TREE)
4098 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4099 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4107 return gfc_build_null_descriptor (type);
4113 /* Create a constructor from the list of elements. */
4114 tmp = build_constructor (type, v);
4115 TREE_CONSTANT (tmp) = 1;
4120 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4121 returns the size (in elements) of the array. */
4124 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4125 stmtblock_t * pblock)
4140 size = gfc_index_one_node;
4141 offset = gfc_index_zero_node;
4142 for (dim = 0; dim < as->rank; dim++)
4144 /* Evaluate non-constant array bound expressions. */
4145 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4146 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4148 gfc_init_se (&se, NULL);
4149 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4150 gfc_add_block_to_block (pblock, &se.pre);
4151 gfc_add_modify (pblock, lbound, se.expr);
4153 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4154 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4156 gfc_init_se (&se, NULL);
4157 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4158 gfc_add_block_to_block (pblock, &se.pre);
4159 gfc_add_modify (pblock, ubound, se.expr);
4161 /* The offset of this dimension. offset = offset - lbound * stride. */
4162 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4163 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4165 /* The size of this dimension, and the stride of the next. */
4166 if (dim + 1 < as->rank)
4167 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4169 stride = GFC_TYPE_ARRAY_SIZE (type);
4171 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4173 /* Calculate stride = size * (ubound + 1 - lbound). */
4174 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4175 gfc_index_one_node, lbound);
4176 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4177 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4179 gfc_add_modify (pblock, stride, tmp);
4181 stride = gfc_evaluate_now (tmp, pblock);
4183 /* Make sure that negative size arrays are translated
4184 to being zero size. */
4185 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4186 stride, gfc_index_zero_node);
4187 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4188 stride, gfc_index_zero_node);
4189 gfc_add_modify (pblock, stride, tmp);
4195 gfc_trans_vla_type_sizes (sym, pblock);
4202 /* Generate code to initialize/allocate an array variable. */
4205 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4214 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4216 /* Do nothing for USEd variables. */
4217 if (sym->attr.use_assoc)
4220 type = TREE_TYPE (decl);
4221 gcc_assert (GFC_ARRAY_TYPE_P (type));
4222 onstack = TREE_CODE (type) != POINTER_TYPE;
4224 gfc_start_block (&block);
4226 /* Evaluate character string length. */
4227 if (sym->ts.type == BT_CHARACTER
4228 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4230 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4232 gfc_trans_vla_type_sizes (sym, &block);
4234 /* Emit a DECL_EXPR for this variable, which will cause the
4235 gimplifier to allocate storage, and all that good stuff. */
4236 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4237 gfc_add_expr_to_block (&block, tmp);
4242 gfc_add_expr_to_block (&block, fnbody);
4243 return gfc_finish_block (&block);
4246 type = TREE_TYPE (type);
4248 gcc_assert (!sym->attr.use_assoc);
4249 gcc_assert (!TREE_STATIC (decl));
4250 gcc_assert (!sym->module);
4252 if (sym->ts.type == BT_CHARACTER
4253 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4254 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4256 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4258 /* Don't actually allocate space for Cray Pointees. */
4259 if (sym->attr.cray_pointee)
4261 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4262 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4263 gfc_add_expr_to_block (&block, fnbody);
4264 return gfc_finish_block (&block);
4267 /* The size is the number of elements in the array, so multiply by the
4268 size of an element to get the total size. */
4269 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4270 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4271 fold_convert (gfc_array_index_type, tmp));
4273 /* Allocate memory to hold the data. */
4274 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4275 gfc_add_modify (&block, decl, tmp);
4277 /* Set offset of the array. */
4278 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4279 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4282 /* Automatic arrays should not have initializers. */
4283 gcc_assert (!sym->value);
4285 gfc_add_expr_to_block (&block, fnbody);
4287 /* Free the temporary. */
4288 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4289 gfc_add_expr_to_block (&block, tmp);
4291 return gfc_finish_block (&block);
4295 /* Generate entry and exit code for g77 calling convention arrays. */
4298 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4308 gfc_get_backend_locus (&loc);
4309 gfc_set_backend_locus (&sym->declared_at);
4311 /* Descriptor type. */
4312 parm = sym->backend_decl;
4313 type = TREE_TYPE (parm);
4314 gcc_assert (GFC_ARRAY_TYPE_P (type));
4316 gfc_start_block (&block);
4318 if (sym->ts.type == BT_CHARACTER
4319 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4320 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4322 /* Evaluate the bounds of the array. */
4323 gfc_trans_array_bounds (type, sym, &offset, &block);
4325 /* Set the offset. */
4326 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4327 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4329 /* Set the pointer itself if we aren't using the parameter directly. */
4330 if (TREE_CODE (parm) != PARM_DECL)
4332 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4333 gfc_add_modify (&block, parm, tmp);
4335 stmt = gfc_finish_block (&block);
4337 gfc_set_backend_locus (&loc);
4339 gfc_start_block (&block);
4341 /* Add the initialization code to the start of the function. */
4343 if (sym->attr.optional || sym->attr.not_always_present)
4345 tmp = gfc_conv_expr_present (sym);
4346 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4349 gfc_add_expr_to_block (&block, stmt);
4350 gfc_add_expr_to_block (&block, body);
4352 return gfc_finish_block (&block);
4356 /* Modify the descriptor of an array parameter so that it has the
4357 correct lower bound. Also move the upper bound accordingly.
4358 If the array is not packed, it will be copied into a temporary.
4359 For each dimension we set the new lower and upper bounds. Then we copy the
4360 stride and calculate the offset for this dimension. We also work out
4361 what the stride of a packed array would be, and see it the two match.
4362 If the array need repacking, we set the stride to the values we just
4363 calculated, recalculate the offset and copy the array data.
4364 Code is also added to copy the data back at the end of the function.
4368 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4375 stmtblock_t cleanup;
4383 tree stride, stride2;
4393 /* Do nothing for pointer and allocatable arrays. */
4394 if (sym->attr.pointer || sym->attr.allocatable)
4397 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4398 return gfc_trans_g77_array (sym, body);
4400 gfc_get_backend_locus (&loc);
4401 gfc_set_backend_locus (&sym->declared_at);
4403 /* Descriptor type. */
4404 type = TREE_TYPE (tmpdesc);
4405 gcc_assert (GFC_ARRAY_TYPE_P (type));
4406 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4407 dumdesc = build_fold_indirect_ref (dumdesc);
4408 gfc_start_block (&block);
4410 if (sym->ts.type == BT_CHARACTER
4411 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4412 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4414 checkparm = (sym->as->type == AS_EXPLICIT
4415 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4417 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4418 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4420 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4422 /* For non-constant shape arrays we only check if the first dimension
4423 is contiguous. Repacking higher dimensions wouldn't gain us
4424 anything as we still don't know the array stride. */
4425 partial = gfc_create_var (boolean_type_node, "partial");
4426 TREE_USED (partial) = 1;
4427 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4428 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4429 gfc_add_modify (&block, partial, tmp);
4433 partial = NULL_TREE;
4436 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4437 here, however I think it does the right thing. */
4440 /* Set the first stride. */
4441 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4442 stride = gfc_evaluate_now (stride, &block);
4444 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4445 stride, gfc_index_zero_node);
4446 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4447 gfc_index_one_node, stride);
4448 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4449 gfc_add_modify (&block, stride, tmp);
4451 /* Allow the user to disable array repacking. */
4452 stmt_unpacked = NULL_TREE;
4456 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4457 /* A library call to repack the array if necessary. */
4458 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4459 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4461 stride = gfc_index_one_node;
4463 if (gfc_option.warn_array_temp)
4464 gfc_warning ("Creating array temporary at %L", &loc);
4467 /* This is for the case where the array data is used directly without
4468 calling the repack function. */
4469 if (no_repack || partial != NULL_TREE)
4470 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4472 stmt_packed = NULL_TREE;
4474 /* Assign the data pointer. */
4475 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4477 /* Don't repack unknown shape arrays when the first stride is 1. */
4478 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4479 partial, stmt_packed, stmt_unpacked);
4482 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4483 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4485 offset = gfc_index_zero_node;
4486 size = gfc_index_one_node;
4488 /* Evaluate the bounds of the array. */
4489 for (n = 0; n < sym->as->rank; n++)
4491 if (checkparm || !sym->as->upper[n])
4493 /* Get the bounds of the actual parameter. */
4494 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4495 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4499 dubound = NULL_TREE;
4500 dlbound = NULL_TREE;
4503 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4504 if (!INTEGER_CST_P (lbound))
4506 gfc_init_se (&se, NULL);
4507 gfc_conv_expr_type (&se, sym->as->lower[n],
4508 gfc_array_index_type);
4509 gfc_add_block_to_block (&block, &se.pre);
4510 gfc_add_modify (&block, lbound, se.expr);
4513 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4514 /* Set the desired upper bound. */
4515 if (sym->as->upper[n])
4517 /* We know what we want the upper bound to be. */
4518 if (!INTEGER_CST_P (ubound))
4520 gfc_init_se (&se, NULL);
4521 gfc_conv_expr_type (&se, sym->as->upper[n],
4522 gfc_array_index_type);
4523 gfc_add_block_to_block (&block, &se.pre);
4524 gfc_add_modify (&block, ubound, se.expr);
4527 /* Check the sizes match. */
4530 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4533 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4535 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4537 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4538 asprintf (&msg, "%s for dimension %d of array '%s'",
4539 gfc_msg_bounds, n+1, sym->name);
4540 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4546 /* For assumed shape arrays move the upper bound by the same amount
4547 as the lower bound. */
4548 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4550 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4551 gfc_add_modify (&block, ubound, tmp);
4553 /* The offset of this dimension. offset = offset - lbound * stride. */
4554 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4555 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4557 /* The size of this dimension, and the stride of the next. */
4558 if (n + 1 < sym->as->rank)
4560 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4562 if (no_repack || partial != NULL_TREE)
4565 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4568 /* Figure out the stride if not a known constant. */
4569 if (!INTEGER_CST_P (stride))
4572 stmt_packed = NULL_TREE;
4575 /* Calculate stride = size * (ubound + 1 - lbound). */
4576 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4577 gfc_index_one_node, lbound);
4578 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4580 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4585 /* Assign the stride. */
4586 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4587 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4588 stmt_unpacked, stmt_packed);
4590 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4591 gfc_add_modify (&block, stride, tmp);
4596 stride = GFC_TYPE_ARRAY_SIZE (type);
4598 if (stride && !INTEGER_CST_P (stride))
4600 /* Calculate size = stride * (ubound + 1 - lbound). */
4601 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4602 gfc_index_one_node, lbound);
4603 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4605 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4606 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4607 gfc_add_modify (&block, stride, tmp);
4612 /* Set the offset. */
4613 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4614 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4616 gfc_trans_vla_type_sizes (sym, &block);
4618 stmt = gfc_finish_block (&block);
4620 gfc_start_block (&block);
4622 /* Only do the entry/initialization code if the arg is present. */
4623 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4624 optional_arg = (sym->attr.optional
4625 || (sym->ns->proc_name->attr.entry_master
4626 && sym->attr.dummy));
4629 tmp = gfc_conv_expr_present (sym);
4630 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4632 gfc_add_expr_to_block (&block, stmt);
4634 /* Add the main function body. */
4635 gfc_add_expr_to_block (&block, body);
4640 gfc_start_block (&cleanup);
4642 if (sym->attr.intent != INTENT_IN)
4644 /* Copy the data back. */
4645 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4646 gfc_add_expr_to_block (&cleanup, tmp);
4649 /* Free the temporary. */
4650 tmp = gfc_call_free (tmpdesc);
4651 gfc_add_expr_to_block (&cleanup, tmp);
4653 stmt = gfc_finish_block (&cleanup);
4655 /* Only do the cleanup if the array was repacked. */
4656 tmp = build_fold_indirect_ref (dumdesc);
4657 tmp = gfc_conv_descriptor_data_get (tmp);
4658 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4659 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4663 tmp = gfc_conv_expr_present (sym);
4664 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4666 gfc_add_expr_to_block (&block, stmt);
4668 /* We don't need to free any memory allocated by internal_pack as it will
4669 be freed at the end of the function by pop_context. */
4670 return gfc_finish_block (&block);
4674 /* Calculate the overall offset, including subreferences. */
4676 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4677 bool subref, gfc_expr *expr)
4687 /* If offset is NULL and this is not a subreferenced array, there is
4689 if (offset == NULL_TREE)
4692 offset = gfc_index_zero_node;
4697 tmp = gfc_conv_array_data (desc);
4698 tmp = build_fold_indirect_ref (tmp);
4699 tmp = gfc_build_array_ref (tmp, offset, NULL);
4701 /* Offset the data pointer for pointer assignments from arrays with
4702 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4705 /* Go past the array reference. */
4706 for (ref = expr->ref; ref; ref = ref->next)
4707 if (ref->type == REF_ARRAY &&
4708 ref->u.ar.type != AR_ELEMENT)
4714 /* Calculate the offset for each subsequent subreference. */
4715 for (; ref; ref = ref->next)
4720 field = ref->u.c.component->backend_decl;
4721 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4722 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4723 tmp, field, NULL_TREE);
4727 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4728 gfc_init_se (&start, NULL);
4729 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4730 gfc_add_block_to_block (block, &start.pre);
4731 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4735 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4736 && ref->u.ar.type == AR_ELEMENT);
4738 /* TODO - Add bounds checking. */
4739 stride = gfc_index_one_node;
4740 index = gfc_index_zero_node;
4741 for (n = 0; n < ref->u.ar.dimen; n++)
4746 /* Update the index. */
4747 gfc_init_se (&start, NULL);
4748 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4749 itmp = gfc_evaluate_now (start.expr, block);
4750 gfc_init_se (&start, NULL);
4751 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4752 jtmp = gfc_evaluate_now (start.expr, block);
4753 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4754 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4755 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4756 index = gfc_evaluate_now (index, block);
4758 /* Update the stride. */
4759 gfc_init_se (&start, NULL);
4760 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4761 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4762 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4763 gfc_index_one_node, itmp);
4764 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4765 stride = gfc_evaluate_now (stride, block);
4768 /* Apply the index to obtain the array element. */
4769 tmp = gfc_build_array_ref (tmp, index, NULL);
4779 /* Set the target data pointer. */
4780 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4781 gfc_conv_descriptor_data_set (block, parm, offset);
4785 /* gfc_conv_expr_descriptor needs the string length an expression
4786 so that the size of the temporary can be obtained. This is done
4787 by adding up the string lengths of all the elements in the
4788 expression. Function with non-constant expressions have their
4789 string lengths mapped onto the actual arguments using the
4790 interface mapping machinery in trans-expr.c. */
4792 get_array_charlen (gfc_expr *expr, gfc_se *se)
4794 gfc_interface_mapping mapping;
4795 gfc_formal_arglist *formal;
4796 gfc_actual_arglist *arg;
4799 if (expr->ts.cl->length
4800 && gfc_is_constant_expr (expr->ts.cl->length))
4802 if (!expr->ts.cl->backend_decl)
4803 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4807 switch (expr->expr_type)
4810 get_array_charlen (expr->value.op.op1, se);
4812 /* For parentheses the expression ts.cl is identical. */
4813 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4816 expr->ts.cl->backend_decl =
4817 gfc_create_var (gfc_charlen_type_node, "sln");
4819 if (expr->value.op.op2)
4821 get_array_charlen (expr->value.op.op2, se);
4823 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4825 /* Add the string lengths and assign them to the expression
4826 string length backend declaration. */
4827 gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
4828 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4829 expr->value.op.op1->ts.cl->backend_decl,
4830 expr->value.op.op2->ts.cl->backend_decl));
4833 gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
4834 expr->value.op.op1->ts.cl->backend_decl);
4838 if (expr->value.function.esym == NULL
4839 || expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4841 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4845 /* Map expressions involving the dummy arguments onto the actual
4846 argument expressions. */
4847 gfc_init_interface_mapping (&mapping);
4848 formal = expr->symtree->n.sym->formal;
4849 arg = expr->value.function.actual;
4851 /* Set se = NULL in the calls to the interface mapping, to suppress any
4853 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4858 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4861 gfc_init_se (&tse, NULL);
4863 /* Build the expression for the character length and convert it. */
4864 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4866 gfc_add_block_to_block (&se->pre, &tse.pre);
4867 gfc_add_block_to_block (&se->post, &tse.post);
4868 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4869 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4870 build_int_cst (gfc_charlen_type_node, 0));
4871 expr->ts.cl->backend_decl = tse.expr;
4872 gfc_free_interface_mapping (&mapping);
4876 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4883 /* Convert an array for passing as an actual argument. Expressions and
4884 vector subscripts are evaluated and stored in a temporary, which is then
4885 passed. For whole arrays the descriptor is passed. For array sections
4886 a modified copy of the descriptor is passed, but using the original data.
4888 This function is also used for array pointer assignments, and there
4891 - se->want_pointer && !se->direct_byref
4892 EXPR is an actual argument. On exit, se->expr contains a
4893 pointer to the array descriptor.
4895 - !se->want_pointer && !se->direct_byref
4896 EXPR is an actual argument to an intrinsic function or the
4897 left-hand side of a pointer assignment. On exit, se->expr
4898 contains the descriptor for EXPR.
4900 - !se->want_pointer && se->direct_byref
4901 EXPR is the right-hand side of a pointer assignment and
4902 se->expr is the descriptor for the previously-evaluated
4903 left-hand side. The function creates an assignment from
4904 EXPR to se->expr. */
4907 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4920 bool subref_array_target = false;
4922 gcc_assert (ss != gfc_ss_terminator);
4924 /* Special case things we know we can pass easily. */
4925 switch (expr->expr_type)
4928 /* If we have a linear array section, we can pass it directly.
4929 Otherwise we need to copy it into a temporary. */
4931 /* Find the SS for the array section. */
4933 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4934 secss = secss->next;
4936 gcc_assert (secss != gfc_ss_terminator);
4937 info = &secss->data.info;
4939 /* Get the descriptor for the array. */
4940 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4941 desc = info->descriptor;
4943 subref_array_target = se->direct_byref && is_subref_array (expr);
4944 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4945 && !subref_array_target;
4949 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4951 /* Create a new descriptor if the array doesn't have one. */
4954 else if (info->ref->u.ar.type == AR_FULL)
4956 else if (se->direct_byref)
4959 full = gfc_full_array_ref_p (info->ref);
4963 if (se->direct_byref)
4965 /* Copy the descriptor for pointer assignments. */
4966 gfc_add_modify (&se->pre, se->expr, desc);
4968 /* Add any offsets from subreferences. */
4969 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4970 subref_array_target, expr);
4972 else if (se->want_pointer)
4974 /* We pass full arrays directly. This means that pointers and
4975 allocatable arrays should also work. */
4976 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
4983 if (expr->ts.type == BT_CHARACTER)
4984 se->string_length = gfc_get_expr_charlen (expr);
4991 /* A transformational function return value will be a temporary
4992 array descriptor. We still need to go through the scalarizer
4993 to create the descriptor. Elemental functions ar handled as
4994 arbitrary expressions, i.e. copy to a temporary. */
4996 /* Look for the SS for this function. */
4997 while (secss != gfc_ss_terminator
4998 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4999 secss = secss->next;
5001 if (se->direct_byref)
5003 gcc_assert (secss != gfc_ss_terminator);
5005 /* For pointer assignments pass the descriptor directly. */
5007 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5008 gfc_conv_expr (se, expr);
5012 if (secss == gfc_ss_terminator)
5014 /* Elemental function. */
5016 if (expr->ts.type == BT_CHARACTER
5017 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
5018 get_array_charlen (expr, se);
5024 /* Transformational function. */
5025 info = &secss->data.info;
5031 /* Constant array constructors don't need a temporary. */
5032 if (ss->type == GFC_SS_CONSTRUCTOR
5033 && expr->ts.type != BT_CHARACTER
5034 && gfc_constant_array_constructor_p (expr->value.constructor))
5037 info = &ss->data.info;
5049 /* Something complicated. Copy it into a temporary. */
5056 gfc_init_loopinfo (&loop);
5058 /* Associate the SS with the loop. */
5059 gfc_add_ss_to_loop (&loop, ss);
5061 /* Tell the scalarizer not to bother creating loop variables, etc. */
5063 loop.array_parameter = 1;
5065 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5066 gcc_assert (!se->direct_byref);
5068 /* Setup the scalarizing loops and bounds. */
5069 gfc_conv_ss_startstride (&loop);
5073 /* Tell the scalarizer to make a temporary. */
5074 loop.temp_ss = gfc_get_ss ();
5075 loop.temp_ss->type = GFC_SS_TEMP;
5076 loop.temp_ss->next = gfc_ss_terminator;
5078 if (expr->ts.type == BT_CHARACTER
5079 && !expr->ts.cl->backend_decl)
5080 get_array_charlen (expr, se);
5082 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5084 if (expr->ts.type == BT_CHARACTER)
5085 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
5087 loop.temp_ss->string_length = NULL;
5089 se->string_length = loop.temp_ss->string_length;
5090 loop.temp_ss->data.temp.dimen = loop.dimen;
5091 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5094 gfc_conv_loop_setup (&loop, & expr->where);
5098 /* Copy into a temporary and pass that. We don't need to copy the data
5099 back because expressions and vector subscripts must be INTENT_IN. */
5100 /* TODO: Optimize passing function return values. */
5104 /* Start the copying loops. */
5105 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5106 gfc_mark_ss_chain_used (ss, 1);
5107 gfc_start_scalarized_body (&loop, &block);
5109 /* Copy each data element. */
5110 gfc_init_se (&lse, NULL);
5111 gfc_copy_loopinfo_to_se (&lse, &loop);
5112 gfc_init_se (&rse, NULL);
5113 gfc_copy_loopinfo_to_se (&rse, &loop);
5115 lse.ss = loop.temp_ss;
5118 gfc_conv_scalarized_array_ref (&lse, NULL);
5119 if (expr->ts.type == BT_CHARACTER)
5121 gfc_conv_expr (&rse, expr);
5122 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5123 rse.expr = build_fold_indirect_ref (rse.expr);
5126 gfc_conv_expr_val (&rse, expr);
5128 gfc_add_block_to_block (&block, &rse.pre);
5129 gfc_add_block_to_block (&block, &lse.pre);
5131 lse.string_length = rse.string_length;
5132 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5133 expr->expr_type == EXPR_VARIABLE);
5134 gfc_add_expr_to_block (&block, tmp);
5136 /* Finish the copying loops. */
5137 gfc_trans_scalarizing_loops (&loop, &block);
5139 desc = loop.temp_ss->data.info.descriptor;
5141 gcc_assert (is_gimple_lvalue (desc));
5143 else if (expr->expr_type == EXPR_FUNCTION)
5145 desc = info->descriptor;
5146 se->string_length = ss->string_length;
5150 /* We pass sections without copying to a temporary. Make a new
5151 descriptor and point it at the section we want. The loop variable
5152 limits will be the limits of the section.
5153 A function may decide to repack the array to speed up access, but
5154 we're not bothered about that here. */
5163 /* Set the string_length for a character array. */
5164 if (expr->ts.type == BT_CHARACTER)
5165 se->string_length = gfc_get_expr_charlen (expr);
5167 desc = info->descriptor;
5168 gcc_assert (secss && secss != gfc_ss_terminator);
5169 if (se->direct_byref)
5171 /* For pointer assignments we fill in the destination. */
5173 parmtype = TREE_TYPE (parm);
5177 /* Otherwise make a new one. */
5178 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5179 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5180 loop.from, loop.to, 0,
5182 parm = gfc_create_var (parmtype, "parm");
5185 offset = gfc_index_zero_node;
5188 /* The following can be somewhat confusing. We have two
5189 descriptors, a new one and the original array.
5190 {parm, parmtype, dim} refer to the new one.
5191 {desc, type, n, secss, loop} refer to the original, which maybe
5192 a descriptorless array.
5193 The bounds of the scalarization are the bounds of the section.
5194 We don't have to worry about numeric overflows when calculating
5195 the offsets because all elements are within the array data. */
5197 /* Set the dtype. */
5198 tmp = gfc_conv_descriptor_dtype (parm);
5199 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5201 /* Set offset for assignments to pointer only to zero if it is not
5203 if (se->direct_byref
5204 && info->ref && info->ref->u.ar.type != AR_FULL)
5205 base = gfc_index_zero_node;
5206 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5207 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5211 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5212 for (n = 0; n < ndim; n++)
5214 stride = gfc_conv_array_stride (desc, n);
5216 /* Work out the offset. */
5218 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5220 gcc_assert (info->subscript[n]
5221 && info->subscript[n]->type == GFC_SS_SCALAR);
5222 start = info->subscript[n]->data.scalar.expr;
5226 /* Check we haven't somehow got out of sync. */
5227 gcc_assert (info->dim[dim] == n);
5229 /* Evaluate and remember the start of the section. */
5230 start = info->start[dim];
5231 stride = gfc_evaluate_now (stride, &loop.pre);
5234 tmp = gfc_conv_array_lbound (desc, n);
5235 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5237 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5238 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5241 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5243 /* For elemental dimensions, we only need the offset. */
5247 /* Vector subscripts need copying and are handled elsewhere. */
5249 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5251 /* Set the new lower bound. */
5252 from = loop.from[dim];
5255 /* If we have an array section or are assigning make sure that
5256 the lower bound is 1. References to the full
5257 array should otherwise keep the original bounds. */
5259 || info->ref->u.ar.type != AR_FULL)
5260 && !integer_onep (from))
5262 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5263 gfc_index_one_node, from);
5264 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5265 from = gfc_index_one_node;
5267 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5268 gfc_add_modify (&loop.pre, tmp, from);
5270 /* Set the new upper bound. */
5271 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5272 gfc_add_modify (&loop.pre, tmp, to);
5274 /* Multiply the stride by the section stride to get the
5276 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5277 stride, info->stride[dim]);
5279 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5281 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5284 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5286 tmp = gfc_conv_array_lbound (desc, n);
5287 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5288 tmp, loop.from[dim]);
5289 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5290 tmp, gfc_conv_array_stride (desc, n));
5291 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5295 /* Store the new stride. */
5296 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5297 gfc_add_modify (&loop.pre, tmp, stride);
5302 if (se->data_not_needed)
5303 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5305 /* Point the data pointer at the first element in the section. */
5306 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5307 subref_array_target, expr);
5309 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5310 && !se->data_not_needed)
5312 /* Set the offset. */
5313 tmp = gfc_conv_descriptor_offset (parm);
5314 gfc_add_modify (&loop.pre, tmp, base);
5318 /* Only the callee knows what the correct offset it, so just set
5320 tmp = gfc_conv_descriptor_offset (parm);
5321 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5326 if (!se->direct_byref)
5328 /* Get a pointer to the new descriptor. */
5329 if (se->want_pointer)
5330 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5335 gfc_add_block_to_block (&se->pre, &loop.pre);
5336 gfc_add_block_to_block (&se->post, &loop.post);
5338 /* Cleanup the scalarizer. */
5339 gfc_cleanup_loop (&loop);
5342 /* Helper function for gfc_conv_array_parameter if array size needs to be
5346 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5349 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5350 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5351 else if (expr->rank > 1)
5352 *size = build_call_expr (gfor_fndecl_size0, 1,
5353 gfc_build_addr_expr (NULL, desc));
5356 tree ubound = gfc_conv_descriptor_ubound (desc, gfc_index_zero_node);
5357 tree lbound = gfc_conv_descriptor_lbound (desc, gfc_index_zero_node);
5359 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5360 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5361 gfc_index_one_node);
5362 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5363 gfc_index_zero_node);
5365 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5366 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5367 fold_convert (gfc_array_index_type, elem));
5370 /* Convert an array for passing as an actual parameter. */
5371 /* TODO: Optimize passing g77 arrays. */
5374 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5375 const gfc_symbol *fsym, const char *proc_name,
5380 tree tmp = NULL_TREE;
5382 tree parent = DECL_CONTEXT (current_function_decl);
5383 bool full_array_var, this_array_result;
5387 full_array_var = (expr->expr_type == EXPR_VARIABLE
5388 && expr->ref->type == REF_ARRAY
5389 && expr->ref->u.ar.type == AR_FULL);
5390 sym = full_array_var ? expr->symtree->n.sym : NULL;
5392 /* The symbol should have an array specification. */
5393 gcc_assert (!sym || sym->as);
5395 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5397 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5398 expr->ts.cl->backend_decl = tmp;
5399 se->string_length = tmp;
5402 /* Is this the result of the enclosing procedure? */
5403 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5404 if (this_array_result
5405 && (sym->backend_decl != current_function_decl)
5406 && (sym->backend_decl != parent))
5407 this_array_result = false;
5409 /* Passing address of the array if it is not pointer or assumed-shape. */
5410 if (full_array_var && g77 && !this_array_result)
5412 tmp = gfc_get_symbol_decl (sym);
5414 if (sym->ts.type == BT_CHARACTER)
5415 se->string_length = sym->ts.cl->backend_decl;
5416 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5417 && !sym->attr.allocatable)
5419 /* Some variables are declared directly, others are declared as
5420 pointers and allocated on the heap. */
5421 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5424 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5426 array_parameter_size (tmp, expr, size);
5429 if (sym->attr.allocatable)
5431 if (sym->attr.dummy || sym->attr.result)
5433 gfc_conv_expr_descriptor (se, expr, ss);
5437 array_parameter_size (tmp, expr, size);
5438 se->expr = gfc_conv_array_data (tmp);
5443 if (this_array_result)
5445 /* Result of the enclosing function. */
5446 gfc_conv_expr_descriptor (se, expr, ss);
5448 array_parameter_size (se->expr, expr, size);
5449 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5451 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5452 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5453 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5459 /* Every other type of array. */
5460 se->want_pointer = 1;
5461 gfc_conv_expr_descriptor (se, expr, ss);
5463 array_parameter_size (build_fold_indirect_ref (se->expr),
5467 /* Deallocate the allocatable components of structures that are
5469 if (expr->ts.type == BT_DERIVED
5470 && expr->ts.derived->attr.alloc_comp
5471 && expr->expr_type != EXPR_VARIABLE)
5473 tmp = build_fold_indirect_ref (se->expr);
5474 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5475 gfc_add_expr_to_block (&se->post, tmp);
5481 /* Repack the array. */
5483 if (gfc_option.warn_array_temp)
5486 gfc_warning ("Creating array temporary at %L for argument '%s'",
5487 &expr->where, fsym->name);
5489 gfc_warning ("Creating array temporary at %L", &expr->where);
5492 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5494 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5496 tmp = gfc_conv_expr_present (sym);
5497 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5498 fold_convert (TREE_TYPE (se->expr), ptr),
5499 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5502 ptr = gfc_evaluate_now (ptr, &se->pre);
5506 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5510 if (fsym && proc_name)
5511 asprintf (&msg, "An array temporary was created for argument "
5512 "'%s' of procedure '%s'", fsym->name, proc_name);
5514 asprintf (&msg, "An array temporary was created");
5516 tmp = build_fold_indirect_ref (desc);
5517 tmp = gfc_conv_array_data (tmp);
5518 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5519 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5521 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5522 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5523 gfc_conv_expr_present (sym), tmp);
5525 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5530 gfc_start_block (&block);
5532 /* Copy the data back. */
5533 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5535 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5536 gfc_add_expr_to_block (&block, tmp);
5539 /* Free the temporary. */
5540 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5541 gfc_add_expr_to_block (&block, tmp);
5543 stmt = gfc_finish_block (&block);
5545 gfc_init_block (&block);
5546 /* Only if it was repacked. This code needs to be executed before the
5547 loop cleanup code. */
5548 tmp = build_fold_indirect_ref (desc);
5549 tmp = gfc_conv_array_data (tmp);
5550 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5551 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5553 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5554 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5555 gfc_conv_expr_present (sym), tmp);
5557 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5559 gfc_add_expr_to_block (&block, tmp);
5560 gfc_add_block_to_block (&block, &se->post);
5562 gfc_init_block (&se->post);
5563 gfc_add_block_to_block (&se->post, &block);
5568 /* Generate code to deallocate an array, if it is allocated. */
5571 gfc_trans_dealloc_allocated (tree descriptor)
5577 gfc_start_block (&block);
5579 var = gfc_conv_descriptor_data_get (descriptor);
5582 /* Call array_deallocate with an int * present in the second argument.
5583 Although it is ignored here, it's presence ensures that arrays that
5584 are already deallocated are ignored. */
5585 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5586 gfc_add_expr_to_block (&block, tmp);
5588 /* Zero the data pointer. */
5589 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5590 var, build_int_cst (TREE_TYPE (var), 0));
5591 gfc_add_expr_to_block (&block, tmp);
5593 return gfc_finish_block (&block);
5597 /* This helper function calculates the size in words of a full array. */
5600 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5605 idx = gfc_rank_cst[rank - 1];
5606 nelems = gfc_conv_descriptor_ubound (decl, idx);
5607 tmp = gfc_conv_descriptor_lbound (decl, idx);
5608 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5609 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5610 tmp, gfc_index_one_node);
5611 tmp = gfc_evaluate_now (tmp, block);
5613 nelems = gfc_conv_descriptor_stride (decl, idx);
5614 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5615 return gfc_evaluate_now (tmp, block);
5619 /* Allocate dest to the same size as src, and copy src -> dest. */
5622 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5631 /* If the source is null, set the destination to null. */
5632 gfc_init_block (&block);
5633 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5634 null_data = gfc_finish_block (&block);
5636 gfc_init_block (&block);
5638 nelems = get_full_array_size (&block, src, rank);
5639 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5640 fold_convert (gfc_array_index_type,
5641 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5643 /* Allocate memory to the destination. */
5644 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5646 gfc_conv_descriptor_data_set (&block, dest, tmp);
5648 /* We know the temporary and the value will be the same length,
5649 so can use memcpy. */
5650 tmp = built_in_decls[BUILT_IN_MEMCPY];
5651 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5652 gfc_conv_descriptor_data_get (src), size);
5653 gfc_add_expr_to_block (&block, tmp);
5654 tmp = gfc_finish_block (&block);
5656 /* Null the destination if the source is null; otherwise do
5657 the allocate and copy. */
5658 null_cond = gfc_conv_descriptor_data_get (src);
5659 null_cond = convert (pvoid_type_node, null_cond);
5660 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5661 null_cond, null_pointer_node);
5662 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5666 /* Recursively traverse an object of derived type, generating code to
5667 deallocate, nullify or copy allocatable components. This is the work horse
5668 function for the functions named in this enum. */
5670 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5673 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5674 tree dest, int rank, int purpose)
5678 stmtblock_t fnblock;
5679 stmtblock_t loopbody;
5689 tree null_cond = NULL_TREE;
5691 gfc_init_block (&fnblock);
5693 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5694 decl = build_fold_indirect_ref (decl);
5696 /* If this an array of derived types with allocatable components
5697 build a loop and recursively call this function. */
5698 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5699 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5701 tmp = gfc_conv_array_data (decl);
5702 var = build_fold_indirect_ref (tmp);
5704 /* Get the number of elements - 1 and set the counter. */
5705 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5707 /* Use the descriptor for an allocatable array. Since this
5708 is a full array reference, we only need the descriptor
5709 information from dimension = rank. */
5710 tmp = get_full_array_size (&fnblock, decl, rank);
5711 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5712 tmp, gfc_index_one_node);
5714 null_cond = gfc_conv_descriptor_data_get (decl);
5715 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5716 build_int_cst (TREE_TYPE (null_cond), 0));
5720 /* Otherwise use the TYPE_DOMAIN information. */
5721 tmp = array_type_nelts (TREE_TYPE (decl));
5722 tmp = fold_convert (gfc_array_index_type, tmp);
5725 /* Remember that this is, in fact, the no. of elements - 1. */
5726 nelems = gfc_evaluate_now (tmp, &fnblock);
5727 index = gfc_create_var (gfc_array_index_type, "S");
5729 /* Build the body of the loop. */
5730 gfc_init_block (&loopbody);
5732 vref = gfc_build_array_ref (var, index, NULL);
5734 if (purpose == COPY_ALLOC_COMP)
5736 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5738 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5739 gfc_add_expr_to_block (&fnblock, tmp);
5741 tmp = build_fold_indirect_ref (gfc_conv_array_data (dest));
5742 dref = gfc_build_array_ref (tmp, index, NULL);
5743 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5746 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5748 gfc_add_expr_to_block (&loopbody, tmp);
5750 /* Build the loop and return. */
5751 gfc_init_loopinfo (&loop);
5753 loop.from[0] = gfc_index_zero_node;
5754 loop.loopvar[0] = index;
5755 loop.to[0] = nelems;
5756 gfc_trans_scalarizing_loops (&loop, &loopbody);
5757 gfc_add_block_to_block (&fnblock, &loop.pre);
5759 tmp = gfc_finish_block (&fnblock);
5760 if (null_cond != NULL_TREE)
5761 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5766 /* Otherwise, act on the components or recursively call self to
5767 act on a chain of components. */
5768 for (c = der_type->components; c; c = c->next)
5770 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5771 && c->ts.derived->attr.alloc_comp;
5772 cdecl = c->backend_decl;
5773 ctype = TREE_TYPE (cdecl);
5777 case DEALLOCATE_ALLOC_COMP:
5778 /* Do not deallocate the components of ultimate pointer
5780 if (cmp_has_alloc_comps && !c->attr.pointer)
5782 comp = fold_build3 (COMPONENT_REF, ctype,
5783 decl, cdecl, NULL_TREE);
5784 rank = c->as ? c->as->rank : 0;
5785 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5787 gfc_add_expr_to_block (&fnblock, tmp);
5790 if (c->attr.allocatable)
5792 comp = fold_build3 (COMPONENT_REF, ctype,
5793 decl, cdecl, NULL_TREE);
5794 tmp = gfc_trans_dealloc_allocated (comp);
5795 gfc_add_expr_to_block (&fnblock, tmp);
5799 case NULLIFY_ALLOC_COMP:
5800 if (c->attr.pointer)
5802 else if (c->attr.allocatable)
5804 comp = fold_build3 (COMPONENT_REF, ctype,
5805 decl, cdecl, NULL_TREE);
5806 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5808 else if (cmp_has_alloc_comps)
5810 comp = fold_build3 (COMPONENT_REF, ctype,
5811 decl, cdecl, NULL_TREE);
5812 rank = c->as ? c->as->rank : 0;
5813 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5815 gfc_add_expr_to_block (&fnblock, tmp);
5819 case COPY_ALLOC_COMP:
5820 if (c->attr.pointer)
5823 /* We need source and destination components. */
5824 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5825 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5826 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5828 if (c->attr.allocatable && !cmp_has_alloc_comps)
5830 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5831 gfc_add_expr_to_block (&fnblock, tmp);
5834 if (cmp_has_alloc_comps)
5836 rank = c->as ? c->as->rank : 0;
5837 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5838 gfc_add_modify (&fnblock, dcmp, tmp);
5839 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5841 gfc_add_expr_to_block (&fnblock, tmp);
5851 return gfc_finish_block (&fnblock);
5854 /* Recursively traverse an object of derived type, generating code to
5855 nullify allocatable components. */
5858 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5860 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5861 NULLIFY_ALLOC_COMP);
5865 /* Recursively traverse an object of derived type, generating code to
5866 deallocate allocatable components. */
5869 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5871 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5872 DEALLOCATE_ALLOC_COMP);
5876 /* Recursively traverse an object of derived type, generating code to
5877 copy its allocatable components. */
5880 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5882 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5886 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5887 Do likewise, recursively if necessary, with the allocatable components of
5891 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5896 stmtblock_t fnblock;
5899 bool sym_has_alloc_comp;
5901 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5902 && sym->ts.derived->attr.alloc_comp;
5904 /* Make sure the frontend gets these right. */
5905 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5906 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5907 "allocatable attribute or derived type without allocatable "
5910 gfc_init_block (&fnblock);
5912 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5913 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5915 if (sym->ts.type == BT_CHARACTER
5916 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5918 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5919 gfc_trans_vla_type_sizes (sym, &fnblock);
5922 /* Dummy, use associated and result variables don't need anything special. */
5923 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
5925 gfc_add_expr_to_block (&fnblock, body);
5927 return gfc_finish_block (&fnblock);
5930 gfc_get_backend_locus (&loc);
5931 gfc_set_backend_locus (&sym->declared_at);
5932 descriptor = sym->backend_decl;
5934 /* Although static, derived types with default initializers and
5935 allocatable components must not be nulled wholesale; instead they
5936 are treated component by component. */
5937 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5939 /* SAVEd variables are not freed on exit. */
5940 gfc_trans_static_array_pointer (sym);
5944 /* Get the descriptor type. */
5945 type = TREE_TYPE (sym->backend_decl);
5947 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5949 if (!sym->attr.save)
5951 rank = sym->as ? sym->as->rank : 0;
5952 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5953 gfc_add_expr_to_block (&fnblock, tmp);
5956 tmp = gfc_init_default_dt (sym, NULL);
5957 gfc_add_expr_to_block (&fnblock, tmp);
5961 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5963 /* If the backend_decl is not a descriptor, we must have a pointer
5965 descriptor = build_fold_indirect_ref (sym->backend_decl);
5966 type = TREE_TYPE (descriptor);
5969 /* NULLIFY the data pointer. */
5970 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5971 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5973 gfc_add_expr_to_block (&fnblock, body);
5975 gfc_set_backend_locus (&loc);
5977 /* Allocatable arrays need to be freed when they go out of scope.
5978 The allocatable components of pointers must not be touched. */
5979 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5980 && !sym->attr.pointer && !sym->attr.save)
5983 rank = sym->as ? sym->as->rank : 0;
5984 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5985 gfc_add_expr_to_block (&fnblock, tmp);
5988 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5990 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5991 gfc_add_expr_to_block (&fnblock, tmp);
5994 return gfc_finish_block (&fnblock);
5997 /************ Expression Walking Functions ******************/
5999 /* Walk a variable reference.
6001 Possible extension - multiple component subscripts.
6002 x(:,:) = foo%a(:)%b(:)
6004 forall (i=..., j=...)
6005 x(i,j) = foo%a(j)%b(i)
6007 This adds a fair amount of complexity because you need to deal with more
6008 than one ref. Maybe handle in a similar manner to vector subscripts.
6009 Maybe not worth the effort. */
6013 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6021 for (ref = expr->ref; ref; ref = ref->next)
6022 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6025 for (; ref; ref = ref->next)
6027 if (ref->type == REF_SUBSTRING)
6029 newss = gfc_get_ss ();
6030 newss->type = GFC_SS_SCALAR;
6031 newss->expr = ref->u.ss.start;
6035 newss = gfc_get_ss ();
6036 newss->type = GFC_SS_SCALAR;
6037 newss->expr = ref->u.ss.end;
6042 /* We're only interested in array sections from now on. */
6043 if (ref->type != REF_ARRAY)
6050 for (n = 0; n < ar->dimen; n++)
6052 newss = gfc_get_ss ();
6053 newss->type = GFC_SS_SCALAR;
6054 newss->expr = ar->start[n];
6061 newss = gfc_get_ss ();
6062 newss->type = GFC_SS_SECTION;
6065 newss->data.info.dimen = ar->as->rank;
6066 newss->data.info.ref = ref;
6068 /* Make sure array is the same as array(:,:), this way
6069 we don't need to special case all the time. */
6070 ar->dimen = ar->as->rank;
6071 for (n = 0; n < ar->dimen; n++)
6073 newss->data.info.dim[n] = n;
6074 ar->dimen_type[n] = DIMEN_RANGE;
6076 gcc_assert (ar->start[n] == NULL);
6077 gcc_assert (ar->end[n] == NULL);
6078 gcc_assert (ar->stride[n] == NULL);
6084 newss = gfc_get_ss ();
6085 newss->type = GFC_SS_SECTION;
6088 newss->data.info.dimen = 0;
6089 newss->data.info.ref = ref;
6093 /* We add SS chains for all the subscripts in the section. */
6094 for (n = 0; n < ar->dimen; n++)
6098 switch (ar->dimen_type[n])
6101 /* Add SS for elemental (scalar) subscripts. */
6102 gcc_assert (ar->start[n]);
6103 indexss = gfc_get_ss ();
6104 indexss->type = GFC_SS_SCALAR;
6105 indexss->expr = ar->start[n];
6106 indexss->next = gfc_ss_terminator;
6107 indexss->loop_chain = gfc_ss_terminator;
6108 newss->data.info.subscript[n] = indexss;
6112 /* We don't add anything for sections, just remember this
6113 dimension for later. */
6114 newss->data.info.dim[newss->data.info.dimen] = n;
6115 newss->data.info.dimen++;
6119 /* Create a GFC_SS_VECTOR index in which we can store
6120 the vector's descriptor. */
6121 indexss = gfc_get_ss ();
6122 indexss->type = GFC_SS_VECTOR;
6123 indexss->expr = ar->start[n];
6124 indexss->next = gfc_ss_terminator;
6125 indexss->loop_chain = gfc_ss_terminator;
6126 newss->data.info.subscript[n] = indexss;
6127 newss->data.info.dim[newss->data.info.dimen] = n;
6128 newss->data.info.dimen++;
6132 /* We should know what sort of section it is by now. */
6136 /* We should have at least one non-elemental dimension. */
6137 gcc_assert (newss->data.info.dimen > 0);
6142 /* We should know what sort of section it is by now. */
6151 /* Walk an expression operator. If only one operand of a binary expression is
6152 scalar, we must also add the scalar term to the SS chain. */
6155 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6161 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6162 if (expr->value.op.op2 == NULL)
6165 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6167 /* All operands are scalar. Pass back and let the caller deal with it. */
6171 /* All operands require scalarization. */
6172 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6175 /* One of the operands needs scalarization, the other is scalar.
6176 Create a gfc_ss for the scalar expression. */
6177 newss = gfc_get_ss ();
6178 newss->type = GFC_SS_SCALAR;
6181 /* First operand is scalar. We build the chain in reverse order, so
6182 add the scalar SS after the second operand. */
6184 while (head && head->next != ss)
6186 /* Check we haven't somehow broken the chain. */
6190 newss->expr = expr->value.op.op1;
6192 else /* head2 == head */
6194 gcc_assert (head2 == head);
6195 /* Second operand is scalar. */
6196 newss->next = head2;
6198 newss->expr = expr->value.op.op2;
6205 /* Reverse a SS chain. */
6208 gfc_reverse_ss (gfc_ss * ss)
6213 gcc_assert (ss != NULL);
6215 head = gfc_ss_terminator;
6216 while (ss != gfc_ss_terminator)
6219 /* Check we didn't somehow break the chain. */
6220 gcc_assert (next != NULL);
6230 /* Walk the arguments of an elemental function. */
6233 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6241 head = gfc_ss_terminator;
6244 for (; arg; arg = arg->next)
6249 newss = gfc_walk_subexpr (head, arg->expr);
6252 /* Scalar argument. */
6253 newss = gfc_get_ss ();
6255 newss->expr = arg->expr;
6265 while (tail->next != gfc_ss_terminator)
6272 /* If all the arguments are scalar we don't need the argument SS. */
6273 gfc_free_ss_chain (head);
6278 /* Add it onto the existing chain. */
6284 /* Walk a function call. Scalar functions are passed back, and taken out of
6285 scalarization loops. For elemental functions we walk their arguments.
6286 The result of functions returning arrays is stored in a temporary outside
6287 the loop, so that the function is only called once. Hence we do not need
6288 to walk their arguments. */
6291 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6294 gfc_intrinsic_sym *isym;
6297 isym = expr->value.function.isym;
6299 /* Handle intrinsic functions separately. */
6301 return gfc_walk_intrinsic_function (ss, expr, isym);
6303 sym = expr->value.function.esym;
6305 sym = expr->symtree->n.sym;
6307 /* A function that returns arrays. */
6308 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6310 newss = gfc_get_ss ();
6311 newss->type = GFC_SS_FUNCTION;
6314 newss->data.info.dimen = expr->rank;
6318 /* Walk the parameters of an elemental function. For now we always pass
6320 if (sym->attr.elemental)
6321 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6324 /* Scalar functions are OK as these are evaluated outside the scalarization
6325 loop. Pass back and let the caller deal with it. */
6330 /* An array temporary is constructed for array constructors. */
6333 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6338 newss = gfc_get_ss ();
6339 newss->type = GFC_SS_CONSTRUCTOR;
6342 newss->data.info.dimen = expr->rank;
6343 for (n = 0; n < expr->rank; n++)
6344 newss->data.info.dim[n] = n;
6350 /* Walk an expression. Add walked expressions to the head of the SS chain.
6351 A wholly scalar expression will not be added. */
6354 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6358 switch (expr->expr_type)
6361 head = gfc_walk_variable_expr (ss, expr);
6365 head = gfc_walk_op_expr (ss, expr);
6369 head = gfc_walk_function_expr (ss, expr);
6374 case EXPR_STRUCTURE:
6375 /* Pass back and let the caller deal with it. */
6379 head = gfc_walk_array_constructor (ss, expr);
6382 case EXPR_SUBSTRING:
6383 /* Pass back and let the caller deal with it. */
6387 internal_error ("bad expression type during walk (%d)",
6394 /* Entry point for expression walking.
6395 A return value equal to the passed chain means this is
6396 a scalar expression. It is up to the caller to take whatever action is
6397 necessary to translate these. */
6400 gfc_walk_expr (gfc_expr * expr)
6404 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6405 return gfc_reverse_ss (res);