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 (PLUS_EXPR, gfc_array_index_type,
3260 gfc_index_one_node, tmp);
3261 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3262 build_int_cst (gfc_array_index_type, 0));
3263 /* We remember the size of the first section, and check all the
3264 others against this. */
3269 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3270 asprintf (&msg, "%s, size mismatch for dimension %d "
3271 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3272 info->dim[n]+1, ss->expr->symtree->name);
3273 gfc_trans_runtime_check (true, false, tmp3, &inner,
3274 &ss->expr->where, msg,
3275 fold_convert (long_integer_type_node, tmp),
3276 fold_convert (long_integer_type_node, size[n]));
3280 size[n] = gfc_evaluate_now (tmp, &inner);
3283 tmp = gfc_finish_block (&inner);
3285 /* For optional arguments, only check bounds if the argument is
3287 if (ss->expr->symtree->n.sym->attr.optional
3288 || ss->expr->symtree->n.sym->attr.not_always_present)
3289 tmp = build3_v (COND_EXPR,
3290 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3291 tmp, build_empty_stmt ());
3293 gfc_add_expr_to_block (&block, tmp);
3297 tmp = gfc_finish_block (&block);
3298 gfc_add_expr_to_block (&loop->pre, tmp);
3303 /* Return true if the two SS could be aliased, i.e. both point to the same data
3305 /* TODO: resolve aliases based on frontend expressions. */
3308 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3315 lsym = lss->expr->symtree->n.sym;
3316 rsym = rss->expr->symtree->n.sym;
3317 if (gfc_symbols_could_alias (lsym, rsym))
3320 if (rsym->ts.type != BT_DERIVED
3321 && lsym->ts.type != BT_DERIVED)
3324 /* For derived types we must check all the component types. We can ignore
3325 array references as these will have the same base type as the previous
3327 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3329 if (lref->type != REF_COMPONENT)
3332 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3335 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3338 if (rref->type != REF_COMPONENT)
3341 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3346 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3348 if (rref->type != REF_COMPONENT)
3351 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3359 /* Resolve array data dependencies. Creates a temporary if required. */
3360 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3364 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3374 loop->temp_ss = NULL;
3375 aref = dest->data.info.ref;
3378 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3380 if (ss->type != GFC_SS_SECTION)
3383 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3385 if (gfc_could_be_alias (dest, ss)
3386 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3394 lref = dest->expr->ref;
3395 rref = ss->expr->ref;
3397 nDepend = gfc_dep_resolver (lref, rref);
3401 /* TODO : loop shifting. */
3404 /* Mark the dimensions for LOOP SHIFTING */
3405 for (n = 0; n < loop->dimen; n++)
3407 int dim = dest->data.info.dim[n];
3409 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3411 else if (! gfc_is_same_range (&lref->u.ar,
3412 &rref->u.ar, dim, 0))
3416 /* Put all the dimensions with dependencies in the
3419 for (n = 0; n < loop->dimen; n++)
3421 gcc_assert (loop->order[n] == n);
3423 loop->order[dim++] = n;
3426 for (n = 0; n < loop->dimen; n++)
3429 loop->order[dim++] = n;
3432 gcc_assert (dim == loop->dimen);
3441 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3442 if (GFC_ARRAY_TYPE_P (base_type)
3443 || GFC_DESCRIPTOR_TYPE_P (base_type))
3444 base_type = gfc_get_element_type (base_type);
3445 loop->temp_ss = gfc_get_ss ();
3446 loop->temp_ss->type = GFC_SS_TEMP;
3447 loop->temp_ss->data.temp.type = base_type;
3448 loop->temp_ss->string_length = dest->string_length;
3449 loop->temp_ss->data.temp.dimen = loop->dimen;
3450 loop->temp_ss->next = gfc_ss_terminator;
3451 gfc_add_ss_to_loop (loop, loop->temp_ss);
3454 loop->temp_ss = NULL;
3458 /* Initialize the scalarization loop. Creates the loop variables. Determines
3459 the range of the loop variables. Creates a temporary if required.
3460 Calculates how to transform from loop variables to array indices for each
3461 expression. Also generates code for scalar expressions which have been
3462 moved outside the loop. */
3465 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3470 gfc_ss_info *specinfo;
3474 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3475 bool dynamic[GFC_MAX_DIMENSIONS];
3481 for (n = 0; n < loop->dimen; n++)
3485 /* We use one SS term, and use that to determine the bounds of the
3486 loop for this dimension. We try to pick the simplest term. */
3487 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3491 /* The frontend has worked out the size for us. */
3492 if (!loopspec[n] || !loopspec[n]->shape
3493 || !integer_zerop (loopspec[n]->data.info.start[n]))
3494 /* Prefer zero-based descriptors if possible. */
3499 if (ss->type == GFC_SS_CONSTRUCTOR)
3501 /* An unknown size constructor will always be rank one.
3502 Higher rank constructors will either have known shape,
3503 or still be wrapped in a call to reshape. */
3504 gcc_assert (loop->dimen == 1);
3506 /* Always prefer to use the constructor bounds if the size
3507 can be determined at compile time. Prefer not to otherwise,
3508 since the general case involves realloc, and it's better to
3509 avoid that overhead if possible. */
3510 c = ss->expr->value.constructor;
3511 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3512 if (!dynamic[n] || !loopspec[n])
3517 /* TODO: Pick the best bound if we have a choice between a
3518 function and something else. */
3519 if (ss->type == GFC_SS_FUNCTION)
3525 if (ss->type != GFC_SS_SECTION)
3529 specinfo = &loopspec[n]->data.info;
3532 info = &ss->data.info;
3536 /* Criteria for choosing a loop specifier (most important first):
3537 doesn't need realloc
3543 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3545 else if (integer_onep (info->stride[n])
3546 && !integer_onep (specinfo->stride[n]))
3548 else if (INTEGER_CST_P (info->stride[n])
3549 && !INTEGER_CST_P (specinfo->stride[n]))
3551 else if (INTEGER_CST_P (info->start[n])
3552 && !INTEGER_CST_P (specinfo->start[n]))
3554 /* We don't work out the upper bound.
3555 else if (INTEGER_CST_P (info->finish[n])
3556 && ! INTEGER_CST_P (specinfo->finish[n]))
3557 loopspec[n] = ss; */
3560 /* We should have found the scalarization loop specifier. If not,
3562 gcc_assert (loopspec[n]);
3564 info = &loopspec[n]->data.info;
3566 /* Set the extents of this range. */
3567 cshape = loopspec[n]->shape;
3568 if (cshape && INTEGER_CST_P (info->start[n])
3569 && INTEGER_CST_P (info->stride[n]))
3571 loop->from[n] = info->start[n];
3572 mpz_set (i, cshape[n]);
3573 mpz_sub_ui (i, i, 1);
3574 /* To = from + (size - 1) * stride. */
3575 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3576 if (!integer_onep (info->stride[n]))
3577 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3578 tmp, info->stride[n]);
3579 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3580 loop->from[n], tmp);
3584 loop->from[n] = info->start[n];
3585 switch (loopspec[n]->type)
3587 case GFC_SS_CONSTRUCTOR:
3588 /* The upper bound is calculated when we expand the
3590 gcc_assert (loop->to[n] == NULL_TREE);
3593 case GFC_SS_SECTION:
3594 /* Use the end expression if it exists and is not constant,
3595 so that it is only evaluated once. */
3596 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3597 loop->to[n] = info->end[n];
3599 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3603 case GFC_SS_FUNCTION:
3604 /* The loop bound will be set when we generate the call. */
3605 gcc_assert (loop->to[n] == NULL_TREE);
3613 /* Transform everything so we have a simple incrementing variable. */
3614 if (integer_onep (info->stride[n]))
3615 info->delta[n] = gfc_index_zero_node;
3618 /* Set the delta for this section. */
3619 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3620 /* Number of iterations is (end - start + step) / step.
3621 with start = 0, this simplifies to
3623 for (i = 0; i<=last; i++){...}; */
3624 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3625 loop->to[n], loop->from[n]);
3626 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3627 tmp, info->stride[n]);
3628 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3629 build_int_cst (gfc_array_index_type, -1));
3630 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3631 /* Make the loop variable start at 0. */
3632 loop->from[n] = gfc_index_zero_node;
3636 /* Add all the scalar code that can be taken out of the loops.
3637 This may include calculating the loop bounds, so do it before
3638 allocating the temporary. */
3639 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3641 /* If we want a temporary then create it. */
3642 if (loop->temp_ss != NULL)
3644 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3646 /* Make absolutely sure that this is a complete type. */
3647 if (loop->temp_ss->string_length)
3648 loop->temp_ss->data.temp.type
3649 = gfc_get_character_type_len_for_eltype
3650 (TREE_TYPE (loop->temp_ss->data.temp.type),
3651 loop->temp_ss->string_length);
3653 tmp = loop->temp_ss->data.temp.type;
3654 len = loop->temp_ss->string_length;
3655 n = loop->temp_ss->data.temp.dimen;
3656 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3657 loop->temp_ss->type = GFC_SS_SECTION;
3658 loop->temp_ss->data.info.dimen = n;
3659 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3660 &loop->temp_ss->data.info, tmp, NULL_TREE,
3661 false, true, false, where);
3664 for (n = 0; n < loop->temp_dim; n++)
3665 loopspec[loop->order[n]] = NULL;
3669 /* For array parameters we don't have loop variables, so don't calculate the
3671 if (loop->array_parameter)
3674 /* Calculate the translation from loop variables to array indices. */
3675 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3677 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3678 && ss->type != GFC_SS_CONSTRUCTOR)
3682 info = &ss->data.info;
3684 for (n = 0; n < info->dimen; n++)
3688 /* If we are specifying the range the delta is already set. */
3689 if (loopspec[n] != ss)
3691 /* Calculate the offset relative to the loop variable.
3692 First multiply by the stride. */
3693 tmp = loop->from[n];
3694 if (!integer_onep (info->stride[n]))
3695 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3696 tmp, info->stride[n]);
3698 /* Then subtract this from our starting value. */
3699 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3700 info->start[n], tmp);
3702 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3709 /* Fills in an array descriptor, and returns the size of the array. The size
3710 will be a simple_val, ie a variable or a constant. Also calculates the
3711 offset of the base. Returns the size of the array.
3715 for (n = 0; n < rank; n++)
3717 a.lbound[n] = specified_lower_bound;
3718 offset = offset + a.lbond[n] * stride;
3720 a.ubound[n] = specified_upper_bound;
3721 a.stride[n] = stride;
3722 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3723 stride = stride * size;
3730 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3731 gfc_expr ** lower, gfc_expr ** upper,
3732 stmtblock_t * pblock)
3744 stmtblock_t thenblock;
3745 stmtblock_t elseblock;
3750 type = TREE_TYPE (descriptor);
3752 stride = gfc_index_one_node;
3753 offset = gfc_index_zero_node;
3755 /* Set the dtype. */
3756 tmp = gfc_conv_descriptor_dtype (descriptor);
3757 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3759 or_expr = NULL_TREE;
3761 for (n = 0; n < rank; n++)
3763 /* We have 3 possibilities for determining the size of the array:
3764 lower == NULL => lbound = 1, ubound = upper[n]
3765 upper[n] = NULL => lbound = 1, ubound = lower[n]
3766 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3769 /* Set lower bound. */
3770 gfc_init_se (&se, NULL);
3772 se.expr = gfc_index_one_node;
3775 gcc_assert (lower[n]);
3778 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3779 gfc_add_block_to_block (pblock, &se.pre);
3783 se.expr = gfc_index_one_node;
3787 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3788 gfc_add_modify (pblock, tmp, se.expr);
3790 /* Work out the offset for this component. */
3791 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3792 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3794 /* Start the calculation for the size of this dimension. */
3795 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3796 gfc_index_one_node, se.expr);
3798 /* Set upper bound. */
3799 gfc_init_se (&se, NULL);
3800 gcc_assert (ubound);
3801 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3802 gfc_add_block_to_block (pblock, &se.pre);
3804 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3805 gfc_add_modify (pblock, tmp, se.expr);
3807 /* Store the stride. */
3808 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3809 gfc_add_modify (pblock, tmp, stride);
3811 /* Calculate the size of this dimension. */
3812 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3814 /* Check whether the size for this dimension is negative. */
3815 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3816 gfc_index_zero_node);
3820 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3822 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3823 gfc_index_zero_node, size);
3825 /* Multiply the stride by the number of elements in this dimension. */
3826 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3827 stride = gfc_evaluate_now (stride, pblock);
3830 /* The stride is the number of elements in the array, so multiply by the
3831 size of an element to get the total size. */
3832 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3833 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3834 fold_convert (gfc_array_index_type, tmp));
3836 if (poffset != NULL)
3838 offset = gfc_evaluate_now (offset, pblock);
3842 if (integer_zerop (or_expr))
3844 if (integer_onep (or_expr))
3845 return gfc_index_zero_node;
3847 var = gfc_create_var (TREE_TYPE (size), "size");
3848 gfc_start_block (&thenblock);
3849 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3850 thencase = gfc_finish_block (&thenblock);
3852 gfc_start_block (&elseblock);
3853 gfc_add_modify (&elseblock, var, size);
3854 elsecase = gfc_finish_block (&elseblock);
3856 tmp = gfc_evaluate_now (or_expr, pblock);
3857 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3858 gfc_add_expr_to_block (pblock, tmp);
3864 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3865 the work for an ALLOCATE statement. */
3869 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3877 gfc_ref *ref, *prev_ref = NULL;
3878 bool allocatable_array;
3882 /* Find the last reference in the chain. */
3883 while (ref && ref->next != NULL)
3885 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3890 if (ref == NULL || ref->type != REF_ARRAY)
3894 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3896 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3898 /* Figure out the size of the array. */
3899 switch (ref->u.ar.type)
3903 upper = ref->u.ar.start;
3907 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3909 lower = ref->u.ar.as->lower;
3910 upper = ref->u.ar.as->upper;
3914 lower = ref->u.ar.start;
3915 upper = ref->u.ar.end;
3923 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3924 lower, upper, &se->pre);
3926 /* Allocate memory to store the data. */
3927 pointer = gfc_conv_descriptor_data_get (se->expr);
3928 STRIP_NOPS (pointer);
3930 /* The allocate_array variants take the old pointer as first argument. */
3931 if (allocatable_array)
3932 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3934 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3935 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3936 gfc_add_expr_to_block (&se->pre, tmp);
3938 tmp = gfc_conv_descriptor_offset (se->expr);
3939 gfc_add_modify (&se->pre, tmp, offset);
3941 if (expr->ts.type == BT_DERIVED
3942 && expr->ts.derived->attr.alloc_comp)
3944 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3945 ref->u.ar.as->rank);
3946 gfc_add_expr_to_block (&se->pre, tmp);
3953 /* Deallocate an array variable. Also used when an allocated variable goes
3958 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3964 gfc_start_block (&block);
3965 /* Get a pointer to the data. */
3966 var = gfc_conv_descriptor_data_get (descriptor);
3969 /* Parameter is the address of the data component. */
3970 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3971 gfc_add_expr_to_block (&block, tmp);
3973 /* Zero the data pointer. */
3974 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3975 var, build_int_cst (TREE_TYPE (var), 0));
3976 gfc_add_expr_to_block (&block, tmp);
3978 return gfc_finish_block (&block);
3982 /* Create an array constructor from an initialization expression.
3983 We assume the frontend already did any expansions and conversions. */
3986 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3993 unsigned HOST_WIDE_INT lo;
3995 VEC(constructor_elt,gc) *v = NULL;
3997 switch (expr->expr_type)
4000 case EXPR_STRUCTURE:
4001 /* A single scalar or derived type value. Create an array with all
4002 elements equal to that value. */
4003 gfc_init_se (&se, NULL);
4005 if (expr->expr_type == EXPR_CONSTANT)
4006 gfc_conv_constant (&se, expr);
4008 gfc_conv_structure (&se, expr, 1);
4010 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4011 gcc_assert (tmp && INTEGER_CST_P (tmp));
4012 hi = TREE_INT_CST_HIGH (tmp);
4013 lo = TREE_INT_CST_LOW (tmp);
4017 /* This will probably eat buckets of memory for large arrays. */
4018 while (hi != 0 || lo != 0)
4020 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4028 /* Create a vector of all the elements. */
4029 for (c = expr->value.constructor; c; c = c->next)
4033 /* Problems occur when we get something like
4034 integer :: a(lots) = (/(i, i=1, lots)/) */
4035 gfc_error_now ("The number of elements in the array constructor "
4036 "at %L requires an increase of the allowed %d "
4037 "upper limit. See -fmax-array-constructor "
4038 "option", &expr->where,
4039 gfc_option.flag_max_array_constructor);
4042 if (mpz_cmp_si (c->n.offset, 0) != 0)
4043 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4047 if (mpz_cmp_si (c->repeat, 0) != 0)
4051 mpz_set (maxval, c->repeat);
4052 mpz_add (maxval, c->n.offset, maxval);
4053 mpz_sub_ui (maxval, maxval, 1);
4054 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4055 if (mpz_cmp_si (c->n.offset, 0) != 0)
4057 mpz_add_ui (maxval, c->n.offset, 1);
4058 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4061 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4063 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
4069 gfc_init_se (&se, NULL);
4070 switch (c->expr->expr_type)
4073 gfc_conv_constant (&se, c->expr);
4074 if (range == NULL_TREE)
4075 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4078 if (index != NULL_TREE)
4079 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4080 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4084 case EXPR_STRUCTURE:
4085 gfc_conv_structure (&se, c->expr, 1);
4086 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4091 /* Catch those occasional beasts that do not simplify
4092 for one reason or another, assuming that if they are
4093 standard defying the frontend will catch them. */
4094 gfc_conv_expr (&se, c->expr);
4095 if (range == NULL_TREE)
4096 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4099 if (index != NULL_TREE)
4100 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4101 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4109 return gfc_build_null_descriptor (type);
4115 /* Create a constructor from the list of elements. */
4116 tmp = build_constructor (type, v);
4117 TREE_CONSTANT (tmp) = 1;
4122 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4123 returns the size (in elements) of the array. */
4126 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4127 stmtblock_t * pblock)
4142 size = gfc_index_one_node;
4143 offset = gfc_index_zero_node;
4144 for (dim = 0; dim < as->rank; dim++)
4146 /* Evaluate non-constant array bound expressions. */
4147 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4148 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4150 gfc_init_se (&se, NULL);
4151 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4152 gfc_add_block_to_block (pblock, &se.pre);
4153 gfc_add_modify (pblock, lbound, se.expr);
4155 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4156 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4158 gfc_init_se (&se, NULL);
4159 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4160 gfc_add_block_to_block (pblock, &se.pre);
4161 gfc_add_modify (pblock, ubound, se.expr);
4163 /* The offset of this dimension. offset = offset - lbound * stride. */
4164 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4165 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4167 /* The size of this dimension, and the stride of the next. */
4168 if (dim + 1 < as->rank)
4169 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4171 stride = GFC_TYPE_ARRAY_SIZE (type);
4173 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4175 /* Calculate stride = size * (ubound + 1 - lbound). */
4176 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4177 gfc_index_one_node, lbound);
4178 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4179 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4181 gfc_add_modify (pblock, stride, tmp);
4183 stride = gfc_evaluate_now (tmp, pblock);
4185 /* Make sure that negative size arrays are translated
4186 to being zero size. */
4187 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4188 stride, gfc_index_zero_node);
4189 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4190 stride, gfc_index_zero_node);
4191 gfc_add_modify (pblock, stride, tmp);
4197 gfc_trans_vla_type_sizes (sym, pblock);
4204 /* Generate code to initialize/allocate an array variable. */
4207 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4216 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4218 /* Do nothing for USEd variables. */
4219 if (sym->attr.use_assoc)
4222 type = TREE_TYPE (decl);
4223 gcc_assert (GFC_ARRAY_TYPE_P (type));
4224 onstack = TREE_CODE (type) != POINTER_TYPE;
4226 gfc_start_block (&block);
4228 /* Evaluate character string length. */
4229 if (sym->ts.type == BT_CHARACTER
4230 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4232 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4234 gfc_trans_vla_type_sizes (sym, &block);
4236 /* Emit a DECL_EXPR for this variable, which will cause the
4237 gimplifier to allocate storage, and all that good stuff. */
4238 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4239 gfc_add_expr_to_block (&block, tmp);
4244 gfc_add_expr_to_block (&block, fnbody);
4245 return gfc_finish_block (&block);
4248 type = TREE_TYPE (type);
4250 gcc_assert (!sym->attr.use_assoc);
4251 gcc_assert (!TREE_STATIC (decl));
4252 gcc_assert (!sym->module);
4254 if (sym->ts.type == BT_CHARACTER
4255 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4256 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4258 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4260 /* Don't actually allocate space for Cray Pointees. */
4261 if (sym->attr.cray_pointee)
4263 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4264 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4265 gfc_add_expr_to_block (&block, fnbody);
4266 return gfc_finish_block (&block);
4269 /* The size is the number of elements in the array, so multiply by the
4270 size of an element to get the total size. */
4271 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4272 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4273 fold_convert (gfc_array_index_type, tmp));
4275 /* Allocate memory to hold the data. */
4276 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4277 gfc_add_modify (&block, decl, tmp);
4279 /* Set offset of the array. */
4280 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4281 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4284 /* Automatic arrays should not have initializers. */
4285 gcc_assert (!sym->value);
4287 gfc_add_expr_to_block (&block, fnbody);
4289 /* Free the temporary. */
4290 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4291 gfc_add_expr_to_block (&block, tmp);
4293 return gfc_finish_block (&block);
4297 /* Generate entry and exit code for g77 calling convention arrays. */
4300 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4310 gfc_get_backend_locus (&loc);
4311 gfc_set_backend_locus (&sym->declared_at);
4313 /* Descriptor type. */
4314 parm = sym->backend_decl;
4315 type = TREE_TYPE (parm);
4316 gcc_assert (GFC_ARRAY_TYPE_P (type));
4318 gfc_start_block (&block);
4320 if (sym->ts.type == BT_CHARACTER
4321 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4322 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4324 /* Evaluate the bounds of the array. */
4325 gfc_trans_array_bounds (type, sym, &offset, &block);
4327 /* Set the offset. */
4328 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4329 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4331 /* Set the pointer itself if we aren't using the parameter directly. */
4332 if (TREE_CODE (parm) != PARM_DECL)
4334 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4335 gfc_add_modify (&block, parm, tmp);
4337 stmt = gfc_finish_block (&block);
4339 gfc_set_backend_locus (&loc);
4341 gfc_start_block (&block);
4343 /* Add the initialization code to the start of the function. */
4345 if (sym->attr.optional || sym->attr.not_always_present)
4347 tmp = gfc_conv_expr_present (sym);
4348 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4351 gfc_add_expr_to_block (&block, stmt);
4352 gfc_add_expr_to_block (&block, body);
4354 return gfc_finish_block (&block);
4358 /* Modify the descriptor of an array parameter so that it has the
4359 correct lower bound. Also move the upper bound accordingly.
4360 If the array is not packed, it will be copied into a temporary.
4361 For each dimension we set the new lower and upper bounds. Then we copy the
4362 stride and calculate the offset for this dimension. We also work out
4363 what the stride of a packed array would be, and see it the two match.
4364 If the array need repacking, we set the stride to the values we just
4365 calculated, recalculate the offset and copy the array data.
4366 Code is also added to copy the data back at the end of the function.
4370 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4377 stmtblock_t cleanup;
4385 tree stride, stride2;
4395 /* Do nothing for pointer and allocatable arrays. */
4396 if (sym->attr.pointer || sym->attr.allocatable)
4399 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4400 return gfc_trans_g77_array (sym, body);
4402 gfc_get_backend_locus (&loc);
4403 gfc_set_backend_locus (&sym->declared_at);
4405 /* Descriptor type. */
4406 type = TREE_TYPE (tmpdesc);
4407 gcc_assert (GFC_ARRAY_TYPE_P (type));
4408 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4409 dumdesc = build_fold_indirect_ref (dumdesc);
4410 gfc_start_block (&block);
4412 if (sym->ts.type == BT_CHARACTER
4413 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4414 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4416 checkparm = (sym->as->type == AS_EXPLICIT
4417 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4419 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4420 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4422 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4424 /* For non-constant shape arrays we only check if the first dimension
4425 is contiguous. Repacking higher dimensions wouldn't gain us
4426 anything as we still don't know the array stride. */
4427 partial = gfc_create_var (boolean_type_node, "partial");
4428 TREE_USED (partial) = 1;
4429 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4430 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4431 gfc_add_modify (&block, partial, tmp);
4435 partial = NULL_TREE;
4438 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4439 here, however I think it does the right thing. */
4442 /* Set the first stride. */
4443 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4444 stride = gfc_evaluate_now (stride, &block);
4446 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4447 stride, gfc_index_zero_node);
4448 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4449 gfc_index_one_node, stride);
4450 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4451 gfc_add_modify (&block, stride, tmp);
4453 /* Allow the user to disable array repacking. */
4454 stmt_unpacked = NULL_TREE;
4458 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4459 /* A library call to repack the array if necessary. */
4460 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4461 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4463 stride = gfc_index_one_node;
4465 if (gfc_option.warn_array_temp)
4466 gfc_warning ("Creating array temporary at %L", &loc);
4469 /* This is for the case where the array data is used directly without
4470 calling the repack function. */
4471 if (no_repack || partial != NULL_TREE)
4472 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4474 stmt_packed = NULL_TREE;
4476 /* Assign the data pointer. */
4477 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4479 /* Don't repack unknown shape arrays when the first stride is 1. */
4480 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4481 partial, stmt_packed, stmt_unpacked);
4484 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4485 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4487 offset = gfc_index_zero_node;
4488 size = gfc_index_one_node;
4490 /* Evaluate the bounds of the array. */
4491 for (n = 0; n < sym->as->rank; n++)
4493 if (checkparm || !sym->as->upper[n])
4495 /* Get the bounds of the actual parameter. */
4496 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4497 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4501 dubound = NULL_TREE;
4502 dlbound = NULL_TREE;
4505 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4506 if (!INTEGER_CST_P (lbound))
4508 gfc_init_se (&se, NULL);
4509 gfc_conv_expr_type (&se, sym->as->lower[n],
4510 gfc_array_index_type);
4511 gfc_add_block_to_block (&block, &se.pre);
4512 gfc_add_modify (&block, lbound, se.expr);
4515 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4516 /* Set the desired upper bound. */
4517 if (sym->as->upper[n])
4519 /* We know what we want the upper bound to be. */
4520 if (!INTEGER_CST_P (ubound))
4522 gfc_init_se (&se, NULL);
4523 gfc_conv_expr_type (&se, sym->as->upper[n],
4524 gfc_array_index_type);
4525 gfc_add_block_to_block (&block, &se.pre);
4526 gfc_add_modify (&block, ubound, se.expr);
4529 /* Check the sizes match. */
4532 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4535 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4537 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4539 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4540 asprintf (&msg, "%s for dimension %d of array '%s'",
4541 gfc_msg_bounds, n+1, sym->name);
4542 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4548 /* For assumed shape arrays move the upper bound by the same amount
4549 as the lower bound. */
4550 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4552 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4553 gfc_add_modify (&block, ubound, tmp);
4555 /* The offset of this dimension. offset = offset - lbound * stride. */
4556 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4557 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4559 /* The size of this dimension, and the stride of the next. */
4560 if (n + 1 < sym->as->rank)
4562 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4564 if (no_repack || partial != NULL_TREE)
4567 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4570 /* Figure out the stride if not a known constant. */
4571 if (!INTEGER_CST_P (stride))
4574 stmt_packed = NULL_TREE;
4577 /* Calculate stride = size * (ubound + 1 - lbound). */
4578 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4579 gfc_index_one_node, lbound);
4580 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4582 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4587 /* Assign the stride. */
4588 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4589 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4590 stmt_unpacked, stmt_packed);
4592 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4593 gfc_add_modify (&block, stride, tmp);
4598 stride = GFC_TYPE_ARRAY_SIZE (type);
4600 if (stride && !INTEGER_CST_P (stride))
4602 /* Calculate size = stride * (ubound + 1 - lbound). */
4603 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4604 gfc_index_one_node, lbound);
4605 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4607 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4608 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4609 gfc_add_modify (&block, stride, tmp);
4614 /* Set the offset. */
4615 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4616 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4618 gfc_trans_vla_type_sizes (sym, &block);
4620 stmt = gfc_finish_block (&block);
4622 gfc_start_block (&block);
4624 /* Only do the entry/initialization code if the arg is present. */
4625 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4626 optional_arg = (sym->attr.optional
4627 || (sym->ns->proc_name->attr.entry_master
4628 && sym->attr.dummy));
4631 tmp = gfc_conv_expr_present (sym);
4632 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4634 gfc_add_expr_to_block (&block, stmt);
4636 /* Add the main function body. */
4637 gfc_add_expr_to_block (&block, body);
4642 gfc_start_block (&cleanup);
4644 if (sym->attr.intent != INTENT_IN)
4646 /* Copy the data back. */
4647 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4648 gfc_add_expr_to_block (&cleanup, tmp);
4651 /* Free the temporary. */
4652 tmp = gfc_call_free (tmpdesc);
4653 gfc_add_expr_to_block (&cleanup, tmp);
4655 stmt = gfc_finish_block (&cleanup);
4657 /* Only do the cleanup if the array was repacked. */
4658 tmp = build_fold_indirect_ref (dumdesc);
4659 tmp = gfc_conv_descriptor_data_get (tmp);
4660 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4661 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4665 tmp = gfc_conv_expr_present (sym);
4666 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4668 gfc_add_expr_to_block (&block, stmt);
4670 /* We don't need to free any memory allocated by internal_pack as it will
4671 be freed at the end of the function by pop_context. */
4672 return gfc_finish_block (&block);
4676 /* Calculate the overall offset, including subreferences. */
4678 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4679 bool subref, gfc_expr *expr)
4689 /* If offset is NULL and this is not a subreferenced array, there is
4691 if (offset == NULL_TREE)
4694 offset = gfc_index_zero_node;
4699 tmp = gfc_conv_array_data (desc);
4700 tmp = build_fold_indirect_ref (tmp);
4701 tmp = gfc_build_array_ref (tmp, offset, NULL);
4703 /* Offset the data pointer for pointer assignments from arrays with
4704 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4707 /* Go past the array reference. */
4708 for (ref = expr->ref; ref; ref = ref->next)
4709 if (ref->type == REF_ARRAY &&
4710 ref->u.ar.type != AR_ELEMENT)
4716 /* Calculate the offset for each subsequent subreference. */
4717 for (; ref; ref = ref->next)
4722 field = ref->u.c.component->backend_decl;
4723 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4724 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4725 tmp, field, NULL_TREE);
4729 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4730 gfc_init_se (&start, NULL);
4731 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4732 gfc_add_block_to_block (block, &start.pre);
4733 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4737 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4738 && ref->u.ar.type == AR_ELEMENT);
4740 /* TODO - Add bounds checking. */
4741 stride = gfc_index_one_node;
4742 index = gfc_index_zero_node;
4743 for (n = 0; n < ref->u.ar.dimen; n++)
4748 /* Update the index. */
4749 gfc_init_se (&start, NULL);
4750 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4751 itmp = gfc_evaluate_now (start.expr, block);
4752 gfc_init_se (&start, NULL);
4753 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4754 jtmp = gfc_evaluate_now (start.expr, block);
4755 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4756 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4757 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4758 index = gfc_evaluate_now (index, block);
4760 /* Update the stride. */
4761 gfc_init_se (&start, NULL);
4762 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4763 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4764 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4765 gfc_index_one_node, itmp);
4766 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4767 stride = gfc_evaluate_now (stride, block);
4770 /* Apply the index to obtain the array element. */
4771 tmp = gfc_build_array_ref (tmp, index, NULL);
4781 /* Set the target data pointer. */
4782 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4783 gfc_conv_descriptor_data_set (block, parm, offset);
4787 /* gfc_conv_expr_descriptor needs the string length an expression
4788 so that the size of the temporary can be obtained. This is done
4789 by adding up the string lengths of all the elements in the
4790 expression. Function with non-constant expressions have their
4791 string lengths mapped onto the actual arguments using the
4792 interface mapping machinery in trans-expr.c. */
4794 get_array_charlen (gfc_expr *expr, gfc_se *se)
4796 gfc_interface_mapping mapping;
4797 gfc_formal_arglist *formal;
4798 gfc_actual_arglist *arg;
4801 if (expr->ts.cl->length
4802 && gfc_is_constant_expr (expr->ts.cl->length))
4804 if (!expr->ts.cl->backend_decl)
4805 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4809 switch (expr->expr_type)
4812 get_array_charlen (expr->value.op.op1, se);
4814 /* For parentheses the expression ts.cl is identical. */
4815 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4818 expr->ts.cl->backend_decl =
4819 gfc_create_var (gfc_charlen_type_node, "sln");
4821 if (expr->value.op.op2)
4823 get_array_charlen (expr->value.op.op2, se);
4825 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4827 /* Add the string lengths and assign them to the expression
4828 string length backend declaration. */
4829 gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
4830 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4831 expr->value.op.op1->ts.cl->backend_decl,
4832 expr->value.op.op2->ts.cl->backend_decl));
4835 gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
4836 expr->value.op.op1->ts.cl->backend_decl);
4840 if (expr->value.function.esym == NULL
4841 || expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4843 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4847 /* Map expressions involving the dummy arguments onto the actual
4848 argument expressions. */
4849 gfc_init_interface_mapping (&mapping);
4850 formal = expr->symtree->n.sym->formal;
4851 arg = expr->value.function.actual;
4853 /* Set se = NULL in the calls to the interface mapping, to suppress any
4855 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4860 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4863 gfc_init_se (&tse, NULL);
4865 /* Build the expression for the character length and convert it. */
4866 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4868 gfc_add_block_to_block (&se->pre, &tse.pre);
4869 gfc_add_block_to_block (&se->post, &tse.post);
4870 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4871 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4872 build_int_cst (gfc_charlen_type_node, 0));
4873 expr->ts.cl->backend_decl = tse.expr;
4874 gfc_free_interface_mapping (&mapping);
4878 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4885 /* Convert an array for passing as an actual argument. Expressions and
4886 vector subscripts are evaluated and stored in a temporary, which is then
4887 passed. For whole arrays the descriptor is passed. For array sections
4888 a modified copy of the descriptor is passed, but using the original data.
4890 This function is also used for array pointer assignments, and there
4893 - se->want_pointer && !se->direct_byref
4894 EXPR is an actual argument. On exit, se->expr contains a
4895 pointer to the array descriptor.
4897 - !se->want_pointer && !se->direct_byref
4898 EXPR is an actual argument to an intrinsic function or the
4899 left-hand side of a pointer assignment. On exit, se->expr
4900 contains the descriptor for EXPR.
4902 - !se->want_pointer && se->direct_byref
4903 EXPR is the right-hand side of a pointer assignment and
4904 se->expr is the descriptor for the previously-evaluated
4905 left-hand side. The function creates an assignment from
4906 EXPR to se->expr. */
4909 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4922 bool subref_array_target = false;
4924 gcc_assert (ss != gfc_ss_terminator);
4926 /* Special case things we know we can pass easily. */
4927 switch (expr->expr_type)
4930 /* If we have a linear array section, we can pass it directly.
4931 Otherwise we need to copy it into a temporary. */
4933 /* Find the SS for the array section. */
4935 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4936 secss = secss->next;
4938 gcc_assert (secss != gfc_ss_terminator);
4939 info = &secss->data.info;
4941 /* Get the descriptor for the array. */
4942 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4943 desc = info->descriptor;
4945 subref_array_target = se->direct_byref && is_subref_array (expr);
4946 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4947 && !subref_array_target;
4951 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4953 /* Create a new descriptor if the array doesn't have one. */
4956 else if (info->ref->u.ar.type == AR_FULL)
4958 else if (se->direct_byref)
4961 full = gfc_full_array_ref_p (info->ref);
4965 if (se->direct_byref)
4967 /* Copy the descriptor for pointer assignments. */
4968 gfc_add_modify (&se->pre, se->expr, desc);
4970 /* Add any offsets from subreferences. */
4971 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4972 subref_array_target, expr);
4974 else if (se->want_pointer)
4976 /* We pass full arrays directly. This means that pointers and
4977 allocatable arrays should also work. */
4978 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
4985 if (expr->ts.type == BT_CHARACTER)
4986 se->string_length = gfc_get_expr_charlen (expr);
4993 /* A transformational function return value will be a temporary
4994 array descriptor. We still need to go through the scalarizer
4995 to create the descriptor. Elemental functions ar handled as
4996 arbitrary expressions, i.e. copy to a temporary. */
4998 /* Look for the SS for this function. */
4999 while (secss != gfc_ss_terminator
5000 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5001 secss = secss->next;
5003 if (se->direct_byref)
5005 gcc_assert (secss != gfc_ss_terminator);
5007 /* For pointer assignments pass the descriptor directly. */
5009 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5010 gfc_conv_expr (se, expr);
5014 if (secss == gfc_ss_terminator)
5016 /* Elemental function. */
5018 if (expr->ts.type == BT_CHARACTER
5019 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
5020 get_array_charlen (expr, se);
5026 /* Transformational function. */
5027 info = &secss->data.info;
5033 /* Constant array constructors don't need a temporary. */
5034 if (ss->type == GFC_SS_CONSTRUCTOR
5035 && expr->ts.type != BT_CHARACTER
5036 && gfc_constant_array_constructor_p (expr->value.constructor))
5039 info = &ss->data.info;
5051 /* Something complicated. Copy it into a temporary. */
5058 gfc_init_loopinfo (&loop);
5060 /* Associate the SS with the loop. */
5061 gfc_add_ss_to_loop (&loop, ss);
5063 /* Tell the scalarizer not to bother creating loop variables, etc. */
5065 loop.array_parameter = 1;
5067 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5068 gcc_assert (!se->direct_byref);
5070 /* Setup the scalarizing loops and bounds. */
5071 gfc_conv_ss_startstride (&loop);
5075 /* Tell the scalarizer to make a temporary. */
5076 loop.temp_ss = gfc_get_ss ();
5077 loop.temp_ss->type = GFC_SS_TEMP;
5078 loop.temp_ss->next = gfc_ss_terminator;
5080 if (expr->ts.type == BT_CHARACTER
5081 && !expr->ts.cl->backend_decl)
5082 get_array_charlen (expr, se);
5084 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5086 if (expr->ts.type == BT_CHARACTER)
5087 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
5089 loop.temp_ss->string_length = NULL;
5091 se->string_length = loop.temp_ss->string_length;
5092 loop.temp_ss->data.temp.dimen = loop.dimen;
5093 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5096 gfc_conv_loop_setup (&loop, & expr->where);
5100 /* Copy into a temporary and pass that. We don't need to copy the data
5101 back because expressions and vector subscripts must be INTENT_IN. */
5102 /* TODO: Optimize passing function return values. */
5106 /* Start the copying loops. */
5107 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5108 gfc_mark_ss_chain_used (ss, 1);
5109 gfc_start_scalarized_body (&loop, &block);
5111 /* Copy each data element. */
5112 gfc_init_se (&lse, NULL);
5113 gfc_copy_loopinfo_to_se (&lse, &loop);
5114 gfc_init_se (&rse, NULL);
5115 gfc_copy_loopinfo_to_se (&rse, &loop);
5117 lse.ss = loop.temp_ss;
5120 gfc_conv_scalarized_array_ref (&lse, NULL);
5121 if (expr->ts.type == BT_CHARACTER)
5123 gfc_conv_expr (&rse, expr);
5124 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5125 rse.expr = build_fold_indirect_ref (rse.expr);
5128 gfc_conv_expr_val (&rse, expr);
5130 gfc_add_block_to_block (&block, &rse.pre);
5131 gfc_add_block_to_block (&block, &lse.pre);
5133 lse.string_length = rse.string_length;
5134 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5135 expr->expr_type == EXPR_VARIABLE);
5136 gfc_add_expr_to_block (&block, tmp);
5138 /* Finish the copying loops. */
5139 gfc_trans_scalarizing_loops (&loop, &block);
5141 desc = loop.temp_ss->data.info.descriptor;
5143 gcc_assert (is_gimple_lvalue (desc));
5145 else if (expr->expr_type == EXPR_FUNCTION)
5147 desc = info->descriptor;
5148 se->string_length = ss->string_length;
5152 /* We pass sections without copying to a temporary. Make a new
5153 descriptor and point it at the section we want. The loop variable
5154 limits will be the limits of the section.
5155 A function may decide to repack the array to speed up access, but
5156 we're not bothered about that here. */
5165 /* Set the string_length for a character array. */
5166 if (expr->ts.type == BT_CHARACTER)
5167 se->string_length = gfc_get_expr_charlen (expr);
5169 desc = info->descriptor;
5170 gcc_assert (secss && secss != gfc_ss_terminator);
5171 if (se->direct_byref)
5173 /* For pointer assignments we fill in the destination. */
5175 parmtype = TREE_TYPE (parm);
5179 /* Otherwise make a new one. */
5180 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5181 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5182 loop.from, loop.to, 0,
5184 parm = gfc_create_var (parmtype, "parm");
5187 offset = gfc_index_zero_node;
5190 /* The following can be somewhat confusing. We have two
5191 descriptors, a new one and the original array.
5192 {parm, parmtype, dim} refer to the new one.
5193 {desc, type, n, secss, loop} refer to the original, which maybe
5194 a descriptorless array.
5195 The bounds of the scalarization are the bounds of the section.
5196 We don't have to worry about numeric overflows when calculating
5197 the offsets because all elements are within the array data. */
5199 /* Set the dtype. */
5200 tmp = gfc_conv_descriptor_dtype (parm);
5201 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5203 /* Set offset for assignments to pointer only to zero if it is not
5205 if (se->direct_byref
5206 && info->ref && info->ref->u.ar.type != AR_FULL)
5207 base = gfc_index_zero_node;
5208 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5209 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5213 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5214 for (n = 0; n < ndim; n++)
5216 stride = gfc_conv_array_stride (desc, n);
5218 /* Work out the offset. */
5220 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5222 gcc_assert (info->subscript[n]
5223 && info->subscript[n]->type == GFC_SS_SCALAR);
5224 start = info->subscript[n]->data.scalar.expr;
5228 /* Check we haven't somehow got out of sync. */
5229 gcc_assert (info->dim[dim] == n);
5231 /* Evaluate and remember the start of the section. */
5232 start = info->start[dim];
5233 stride = gfc_evaluate_now (stride, &loop.pre);
5236 tmp = gfc_conv_array_lbound (desc, n);
5237 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5239 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5240 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5243 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5245 /* For elemental dimensions, we only need the offset. */
5249 /* Vector subscripts need copying and are handled elsewhere. */
5251 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5253 /* Set the new lower bound. */
5254 from = loop.from[dim];
5257 /* If we have an array section or are assigning make sure that
5258 the lower bound is 1. References to the full
5259 array should otherwise keep the original bounds. */
5261 || info->ref->u.ar.type != AR_FULL)
5262 && !integer_onep (from))
5264 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5265 gfc_index_one_node, from);
5266 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5267 from = gfc_index_one_node;
5269 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5270 gfc_add_modify (&loop.pre, tmp, from);
5272 /* Set the new upper bound. */
5273 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5274 gfc_add_modify (&loop.pre, tmp, to);
5276 /* Multiply the stride by the section stride to get the
5278 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5279 stride, info->stride[dim]);
5281 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5283 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5286 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5288 tmp = gfc_conv_array_lbound (desc, n);
5289 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5290 tmp, loop.from[dim]);
5291 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5292 tmp, gfc_conv_array_stride (desc, n));
5293 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5297 /* Store the new stride. */
5298 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5299 gfc_add_modify (&loop.pre, tmp, stride);
5304 if (se->data_not_needed)
5305 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5307 /* Point the data pointer at the first element in the section. */
5308 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5309 subref_array_target, expr);
5311 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5312 && !se->data_not_needed)
5314 /* Set the offset. */
5315 tmp = gfc_conv_descriptor_offset (parm);
5316 gfc_add_modify (&loop.pre, tmp, base);
5320 /* Only the callee knows what the correct offset it, so just set
5322 tmp = gfc_conv_descriptor_offset (parm);
5323 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5328 if (!se->direct_byref)
5330 /* Get a pointer to the new descriptor. */
5331 if (se->want_pointer)
5332 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5337 gfc_add_block_to_block (&se->pre, &loop.pre);
5338 gfc_add_block_to_block (&se->post, &loop.post);
5340 /* Cleanup the scalarizer. */
5341 gfc_cleanup_loop (&loop);
5344 /* Helper function for gfc_conv_array_parameter if array size needs to be
5348 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5351 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5352 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5353 else if (expr->rank > 1)
5354 *size = build_call_expr (gfor_fndecl_size0, 1,
5355 gfc_build_addr_expr (NULL, desc));
5358 tree ubound = gfc_conv_descriptor_ubound (desc, gfc_index_zero_node);
5359 tree lbound = gfc_conv_descriptor_lbound (desc, gfc_index_zero_node);
5361 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5362 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5363 gfc_index_one_node);
5364 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5365 gfc_index_zero_node);
5367 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5368 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5369 fold_convert (gfc_array_index_type, elem));
5372 /* Convert an array for passing as an actual parameter. */
5373 /* TODO: Optimize passing g77 arrays. */
5376 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5377 const gfc_symbol *fsym, const char *proc_name,
5382 tree tmp = NULL_TREE;
5384 tree parent = DECL_CONTEXT (current_function_decl);
5385 bool full_array_var, this_array_result;
5389 full_array_var = (expr->expr_type == EXPR_VARIABLE
5390 && expr->ref->type == REF_ARRAY
5391 && expr->ref->u.ar.type == AR_FULL);
5392 sym = full_array_var ? expr->symtree->n.sym : NULL;
5394 /* The symbol should have an array specification. */
5395 gcc_assert (!sym || sym->as);
5397 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5399 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5400 expr->ts.cl->backend_decl = tmp;
5401 se->string_length = tmp;
5404 /* Is this the result of the enclosing procedure? */
5405 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5406 if (this_array_result
5407 && (sym->backend_decl != current_function_decl)
5408 && (sym->backend_decl != parent))
5409 this_array_result = false;
5411 /* Passing address of the array if it is not pointer or assumed-shape. */
5412 if (full_array_var && g77 && !this_array_result)
5414 tmp = gfc_get_symbol_decl (sym);
5416 if (sym->ts.type == BT_CHARACTER)
5417 se->string_length = sym->ts.cl->backend_decl;
5418 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5419 && !sym->attr.allocatable)
5421 /* Some variables are declared directly, others are declared as
5422 pointers and allocated on the heap. */
5423 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5426 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5428 array_parameter_size (tmp, expr, size);
5431 if (sym->attr.allocatable)
5433 if (sym->attr.dummy || sym->attr.result)
5435 gfc_conv_expr_descriptor (se, expr, ss);
5439 array_parameter_size (tmp, expr, size);
5440 se->expr = gfc_conv_array_data (tmp);
5445 if (this_array_result)
5447 /* Result of the enclosing function. */
5448 gfc_conv_expr_descriptor (se, expr, ss);
5450 array_parameter_size (se->expr, expr, size);
5451 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5453 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5454 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5455 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5461 /* Every other type of array. */
5462 se->want_pointer = 1;
5463 gfc_conv_expr_descriptor (se, expr, ss);
5465 array_parameter_size (build_fold_indirect_ref (se->expr),
5469 /* Deallocate the allocatable components of structures that are
5471 if (expr->ts.type == BT_DERIVED
5472 && expr->ts.derived->attr.alloc_comp
5473 && expr->expr_type != EXPR_VARIABLE)
5475 tmp = build_fold_indirect_ref (se->expr);
5476 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5477 gfc_add_expr_to_block (&se->post, tmp);
5483 /* Repack the array. */
5485 if (gfc_option.warn_array_temp)
5488 gfc_warning ("Creating array temporary at %L for argument '%s'",
5489 &expr->where, fsym->name);
5491 gfc_warning ("Creating array temporary at %L", &expr->where);
5494 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5496 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5498 tmp = gfc_conv_expr_present (sym);
5499 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5500 fold_convert (TREE_TYPE (se->expr), ptr),
5501 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5504 ptr = gfc_evaluate_now (ptr, &se->pre);
5508 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5512 if (fsym && proc_name)
5513 asprintf (&msg, "An array temporary was created for argument "
5514 "'%s' of procedure '%s'", fsym->name, proc_name);
5516 asprintf (&msg, "An array temporary was created");
5518 tmp = build_fold_indirect_ref (desc);
5519 tmp = gfc_conv_array_data (tmp);
5520 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5521 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5523 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5524 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5525 gfc_conv_expr_present (sym), tmp);
5527 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5532 gfc_start_block (&block);
5534 /* Copy the data back. */
5535 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5537 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5538 gfc_add_expr_to_block (&block, tmp);
5541 /* Free the temporary. */
5542 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5543 gfc_add_expr_to_block (&block, tmp);
5545 stmt = gfc_finish_block (&block);
5547 gfc_init_block (&block);
5548 /* Only if it was repacked. This code needs to be executed before the
5549 loop cleanup code. */
5550 tmp = build_fold_indirect_ref (desc);
5551 tmp = gfc_conv_array_data (tmp);
5552 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5553 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5555 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5556 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5557 gfc_conv_expr_present (sym), tmp);
5559 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5561 gfc_add_expr_to_block (&block, tmp);
5562 gfc_add_block_to_block (&block, &se->post);
5564 gfc_init_block (&se->post);
5565 gfc_add_block_to_block (&se->post, &block);
5570 /* Generate code to deallocate an array, if it is allocated. */
5573 gfc_trans_dealloc_allocated (tree descriptor)
5579 gfc_start_block (&block);
5581 var = gfc_conv_descriptor_data_get (descriptor);
5584 /* Call array_deallocate with an int * present in the second argument.
5585 Although it is ignored here, it's presence ensures that arrays that
5586 are already deallocated are ignored. */
5587 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5588 gfc_add_expr_to_block (&block, tmp);
5590 /* Zero the data pointer. */
5591 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5592 var, build_int_cst (TREE_TYPE (var), 0));
5593 gfc_add_expr_to_block (&block, tmp);
5595 return gfc_finish_block (&block);
5599 /* This helper function calculates the size in words of a full array. */
5602 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5607 idx = gfc_rank_cst[rank - 1];
5608 nelems = gfc_conv_descriptor_ubound (decl, idx);
5609 tmp = gfc_conv_descriptor_lbound (decl, idx);
5610 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5611 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5612 tmp, gfc_index_one_node);
5613 tmp = gfc_evaluate_now (tmp, block);
5615 nelems = gfc_conv_descriptor_stride (decl, idx);
5616 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5617 return gfc_evaluate_now (tmp, block);
5621 /* Allocate dest to the same size as src, and copy src -> dest. */
5624 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5633 /* If the source is null, set the destination to null. */
5634 gfc_init_block (&block);
5635 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5636 null_data = gfc_finish_block (&block);
5638 gfc_init_block (&block);
5640 nelems = get_full_array_size (&block, src, rank);
5641 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5642 fold_convert (gfc_array_index_type,
5643 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5645 /* Allocate memory to the destination. */
5646 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5648 gfc_conv_descriptor_data_set (&block, dest, tmp);
5650 /* We know the temporary and the value will be the same length,
5651 so can use memcpy. */
5652 tmp = built_in_decls[BUILT_IN_MEMCPY];
5653 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5654 gfc_conv_descriptor_data_get (src), size);
5655 gfc_add_expr_to_block (&block, tmp);
5656 tmp = gfc_finish_block (&block);
5658 /* Null the destination if the source is null; otherwise do
5659 the allocate and copy. */
5660 null_cond = gfc_conv_descriptor_data_get (src);
5661 null_cond = convert (pvoid_type_node, null_cond);
5662 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5663 null_cond, null_pointer_node);
5664 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5668 /* Recursively traverse an object of derived type, generating code to
5669 deallocate, nullify or copy allocatable components. This is the work horse
5670 function for the functions named in this enum. */
5672 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5675 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5676 tree dest, int rank, int purpose)
5680 stmtblock_t fnblock;
5681 stmtblock_t loopbody;
5691 tree null_cond = NULL_TREE;
5693 gfc_init_block (&fnblock);
5695 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5696 decl = build_fold_indirect_ref (decl);
5698 /* If this an array of derived types with allocatable components
5699 build a loop and recursively call this function. */
5700 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5701 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5703 tmp = gfc_conv_array_data (decl);
5704 var = build_fold_indirect_ref (tmp);
5706 /* Get the number of elements - 1 and set the counter. */
5707 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5709 /* Use the descriptor for an allocatable array. Since this
5710 is a full array reference, we only need the descriptor
5711 information from dimension = rank. */
5712 tmp = get_full_array_size (&fnblock, decl, rank);
5713 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5714 tmp, gfc_index_one_node);
5716 null_cond = gfc_conv_descriptor_data_get (decl);
5717 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5718 build_int_cst (TREE_TYPE (null_cond), 0));
5722 /* Otherwise use the TYPE_DOMAIN information. */
5723 tmp = array_type_nelts (TREE_TYPE (decl));
5724 tmp = fold_convert (gfc_array_index_type, tmp);
5727 /* Remember that this is, in fact, the no. of elements - 1. */
5728 nelems = gfc_evaluate_now (tmp, &fnblock);
5729 index = gfc_create_var (gfc_array_index_type, "S");
5731 /* Build the body of the loop. */
5732 gfc_init_block (&loopbody);
5734 vref = gfc_build_array_ref (var, index, NULL);
5736 if (purpose == COPY_ALLOC_COMP)
5738 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5740 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5741 gfc_add_expr_to_block (&fnblock, tmp);
5743 tmp = build_fold_indirect_ref (gfc_conv_array_data (dest));
5744 dref = gfc_build_array_ref (tmp, index, NULL);
5745 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5748 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5750 gfc_add_expr_to_block (&loopbody, tmp);
5752 /* Build the loop and return. */
5753 gfc_init_loopinfo (&loop);
5755 loop.from[0] = gfc_index_zero_node;
5756 loop.loopvar[0] = index;
5757 loop.to[0] = nelems;
5758 gfc_trans_scalarizing_loops (&loop, &loopbody);
5759 gfc_add_block_to_block (&fnblock, &loop.pre);
5761 tmp = gfc_finish_block (&fnblock);
5762 if (null_cond != NULL_TREE)
5763 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5768 /* Otherwise, act on the components or recursively call self to
5769 act on a chain of components. */
5770 for (c = der_type->components; c; c = c->next)
5772 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5773 && c->ts.derived->attr.alloc_comp;
5774 cdecl = c->backend_decl;
5775 ctype = TREE_TYPE (cdecl);
5779 case DEALLOCATE_ALLOC_COMP:
5780 /* Do not deallocate the components of ultimate pointer
5782 if (cmp_has_alloc_comps && !c->attr.pointer)
5784 comp = fold_build3 (COMPONENT_REF, ctype,
5785 decl, cdecl, NULL_TREE);
5786 rank = c->as ? c->as->rank : 0;
5787 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5789 gfc_add_expr_to_block (&fnblock, tmp);
5792 if (c->attr.allocatable)
5794 comp = fold_build3 (COMPONENT_REF, ctype,
5795 decl, cdecl, NULL_TREE);
5796 tmp = gfc_trans_dealloc_allocated (comp);
5797 gfc_add_expr_to_block (&fnblock, tmp);
5801 case NULLIFY_ALLOC_COMP:
5802 if (c->attr.pointer)
5804 else if (c->attr.allocatable)
5806 comp = fold_build3 (COMPONENT_REF, ctype,
5807 decl, cdecl, NULL_TREE);
5808 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5810 else if (cmp_has_alloc_comps)
5812 comp = fold_build3 (COMPONENT_REF, ctype,
5813 decl, cdecl, NULL_TREE);
5814 rank = c->as ? c->as->rank : 0;
5815 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5817 gfc_add_expr_to_block (&fnblock, tmp);
5821 case COPY_ALLOC_COMP:
5822 if (c->attr.pointer)
5825 /* We need source and destination components. */
5826 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5827 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5828 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5830 if (c->attr.allocatable && !cmp_has_alloc_comps)
5832 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5833 gfc_add_expr_to_block (&fnblock, tmp);
5836 if (cmp_has_alloc_comps)
5838 rank = c->as ? c->as->rank : 0;
5839 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5840 gfc_add_modify (&fnblock, dcmp, tmp);
5841 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5843 gfc_add_expr_to_block (&fnblock, tmp);
5853 return gfc_finish_block (&fnblock);
5856 /* Recursively traverse an object of derived type, generating code to
5857 nullify allocatable components. */
5860 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5862 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5863 NULLIFY_ALLOC_COMP);
5867 /* Recursively traverse an object of derived type, generating code to
5868 deallocate allocatable components. */
5871 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5873 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5874 DEALLOCATE_ALLOC_COMP);
5878 /* Recursively traverse an object of derived type, generating code to
5879 copy its allocatable components. */
5882 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5884 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5888 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5889 Do likewise, recursively if necessary, with the allocatable components of
5893 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5898 stmtblock_t fnblock;
5901 bool sym_has_alloc_comp;
5903 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5904 && sym->ts.derived->attr.alloc_comp;
5906 /* Make sure the frontend gets these right. */
5907 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5908 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5909 "allocatable attribute or derived type without allocatable "
5912 gfc_init_block (&fnblock);
5914 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5915 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5917 if (sym->ts.type == BT_CHARACTER
5918 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5920 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5921 gfc_trans_vla_type_sizes (sym, &fnblock);
5924 /* Dummy, use associated and result variables don't need anything special. */
5925 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
5927 gfc_add_expr_to_block (&fnblock, body);
5929 return gfc_finish_block (&fnblock);
5932 gfc_get_backend_locus (&loc);
5933 gfc_set_backend_locus (&sym->declared_at);
5934 descriptor = sym->backend_decl;
5936 /* Although static, derived types with default initializers and
5937 allocatable components must not be nulled wholesale; instead they
5938 are treated component by component. */
5939 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5941 /* SAVEd variables are not freed on exit. */
5942 gfc_trans_static_array_pointer (sym);
5946 /* Get the descriptor type. */
5947 type = TREE_TYPE (sym->backend_decl);
5949 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5951 if (!sym->attr.save)
5953 rank = sym->as ? sym->as->rank : 0;
5954 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5955 gfc_add_expr_to_block (&fnblock, tmp);
5958 tmp = gfc_init_default_dt (sym, NULL);
5959 gfc_add_expr_to_block (&fnblock, tmp);
5963 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5965 /* If the backend_decl is not a descriptor, we must have a pointer
5967 descriptor = build_fold_indirect_ref (sym->backend_decl);
5968 type = TREE_TYPE (descriptor);
5971 /* NULLIFY the data pointer. */
5972 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5973 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5975 gfc_add_expr_to_block (&fnblock, body);
5977 gfc_set_backend_locus (&loc);
5979 /* Allocatable arrays need to be freed when they go out of scope.
5980 The allocatable components of pointers must not be touched. */
5981 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5982 && !sym->attr.pointer && !sym->attr.save)
5985 rank = sym->as ? sym->as->rank : 0;
5986 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5987 gfc_add_expr_to_block (&fnblock, tmp);
5990 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5992 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5993 gfc_add_expr_to_block (&fnblock, tmp);
5996 return gfc_finish_block (&fnblock);
5999 /************ Expression Walking Functions ******************/
6001 /* Walk a variable reference.
6003 Possible extension - multiple component subscripts.
6004 x(:,:) = foo%a(:)%b(:)
6006 forall (i=..., j=...)
6007 x(i,j) = foo%a(j)%b(i)
6009 This adds a fair amount of complexity because you need to deal with more
6010 than one ref. Maybe handle in a similar manner to vector subscripts.
6011 Maybe not worth the effort. */
6015 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6023 for (ref = expr->ref; ref; ref = ref->next)
6024 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6027 for (; ref; ref = ref->next)
6029 if (ref->type == REF_SUBSTRING)
6031 newss = gfc_get_ss ();
6032 newss->type = GFC_SS_SCALAR;
6033 newss->expr = ref->u.ss.start;
6037 newss = gfc_get_ss ();
6038 newss->type = GFC_SS_SCALAR;
6039 newss->expr = ref->u.ss.end;
6044 /* We're only interested in array sections from now on. */
6045 if (ref->type != REF_ARRAY)
6052 for (n = 0; n < ar->dimen; n++)
6054 newss = gfc_get_ss ();
6055 newss->type = GFC_SS_SCALAR;
6056 newss->expr = ar->start[n];
6063 newss = gfc_get_ss ();
6064 newss->type = GFC_SS_SECTION;
6067 newss->data.info.dimen = ar->as->rank;
6068 newss->data.info.ref = ref;
6070 /* Make sure array is the same as array(:,:), this way
6071 we don't need to special case all the time. */
6072 ar->dimen = ar->as->rank;
6073 for (n = 0; n < ar->dimen; n++)
6075 newss->data.info.dim[n] = n;
6076 ar->dimen_type[n] = DIMEN_RANGE;
6078 gcc_assert (ar->start[n] == NULL);
6079 gcc_assert (ar->end[n] == NULL);
6080 gcc_assert (ar->stride[n] == NULL);
6086 newss = gfc_get_ss ();
6087 newss->type = GFC_SS_SECTION;
6090 newss->data.info.dimen = 0;
6091 newss->data.info.ref = ref;
6095 /* We add SS chains for all the subscripts in the section. */
6096 for (n = 0; n < ar->dimen; n++)
6100 switch (ar->dimen_type[n])
6103 /* Add SS for elemental (scalar) subscripts. */
6104 gcc_assert (ar->start[n]);
6105 indexss = gfc_get_ss ();
6106 indexss->type = GFC_SS_SCALAR;
6107 indexss->expr = ar->start[n];
6108 indexss->next = gfc_ss_terminator;
6109 indexss->loop_chain = gfc_ss_terminator;
6110 newss->data.info.subscript[n] = indexss;
6114 /* We don't add anything for sections, just remember this
6115 dimension for later. */
6116 newss->data.info.dim[newss->data.info.dimen] = n;
6117 newss->data.info.dimen++;
6121 /* Create a GFC_SS_VECTOR index in which we can store
6122 the vector's descriptor. */
6123 indexss = gfc_get_ss ();
6124 indexss->type = GFC_SS_VECTOR;
6125 indexss->expr = ar->start[n];
6126 indexss->next = gfc_ss_terminator;
6127 indexss->loop_chain = gfc_ss_terminator;
6128 newss->data.info.subscript[n] = indexss;
6129 newss->data.info.dim[newss->data.info.dimen] = n;
6130 newss->data.info.dimen++;
6134 /* We should know what sort of section it is by now. */
6138 /* We should have at least one non-elemental dimension. */
6139 gcc_assert (newss->data.info.dimen > 0);
6144 /* We should know what sort of section it is by now. */
6153 /* Walk an expression operator. If only one operand of a binary expression is
6154 scalar, we must also add the scalar term to the SS chain. */
6157 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6163 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6164 if (expr->value.op.op2 == NULL)
6167 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6169 /* All operands are scalar. Pass back and let the caller deal with it. */
6173 /* All operands require scalarization. */
6174 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6177 /* One of the operands needs scalarization, the other is scalar.
6178 Create a gfc_ss for the scalar expression. */
6179 newss = gfc_get_ss ();
6180 newss->type = GFC_SS_SCALAR;
6183 /* First operand is scalar. We build the chain in reverse order, so
6184 add the scalar SS after the second operand. */
6186 while (head && head->next != ss)
6188 /* Check we haven't somehow broken the chain. */
6192 newss->expr = expr->value.op.op1;
6194 else /* head2 == head */
6196 gcc_assert (head2 == head);
6197 /* Second operand is scalar. */
6198 newss->next = head2;
6200 newss->expr = expr->value.op.op2;
6207 /* Reverse a SS chain. */
6210 gfc_reverse_ss (gfc_ss * ss)
6215 gcc_assert (ss != NULL);
6217 head = gfc_ss_terminator;
6218 while (ss != gfc_ss_terminator)
6221 /* Check we didn't somehow break the chain. */
6222 gcc_assert (next != NULL);
6232 /* Walk the arguments of an elemental function. */
6235 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6243 head = gfc_ss_terminator;
6246 for (; arg; arg = arg->next)
6251 newss = gfc_walk_subexpr (head, arg->expr);
6254 /* Scalar argument. */
6255 newss = gfc_get_ss ();
6257 newss->expr = arg->expr;
6267 while (tail->next != gfc_ss_terminator)
6274 /* If all the arguments are scalar we don't need the argument SS. */
6275 gfc_free_ss_chain (head);
6280 /* Add it onto the existing chain. */
6286 /* Walk a function call. Scalar functions are passed back, and taken out of
6287 scalarization loops. For elemental functions we walk their arguments.
6288 The result of functions returning arrays is stored in a temporary outside
6289 the loop, so that the function is only called once. Hence we do not need
6290 to walk their arguments. */
6293 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6296 gfc_intrinsic_sym *isym;
6298 gfc_component *comp = NULL;
6300 isym = expr->value.function.isym;
6302 /* Handle intrinsic functions separately. */
6304 return gfc_walk_intrinsic_function (ss, expr, isym);
6306 sym = expr->value.function.esym;
6308 sym = expr->symtree->n.sym;
6310 /* A function that returns arrays. */
6311 is_proc_ptr_comp (expr, &comp);
6312 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6313 || (comp && comp->attr.dimension))
6315 newss = gfc_get_ss ();
6316 newss->type = GFC_SS_FUNCTION;
6319 newss->data.info.dimen = expr->rank;
6323 /* Walk the parameters of an elemental function. For now we always pass
6325 if (sym->attr.elemental)
6326 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6329 /* Scalar functions are OK as these are evaluated outside the scalarization
6330 loop. Pass back and let the caller deal with it. */
6335 /* An array temporary is constructed for array constructors. */
6338 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6343 newss = gfc_get_ss ();
6344 newss->type = GFC_SS_CONSTRUCTOR;
6347 newss->data.info.dimen = expr->rank;
6348 for (n = 0; n < expr->rank; n++)
6349 newss->data.info.dim[n] = n;
6355 /* Walk an expression. Add walked expressions to the head of the SS chain.
6356 A wholly scalar expression will not be added. */
6359 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6363 switch (expr->expr_type)
6366 head = gfc_walk_variable_expr (ss, expr);
6370 head = gfc_walk_op_expr (ss, expr);
6374 head = gfc_walk_function_expr (ss, expr);
6379 case EXPR_STRUCTURE:
6380 /* Pass back and let the caller deal with it. */
6384 head = gfc_walk_array_constructor (ss, expr);
6387 case EXPR_SUBSTRING:
6388 /* Pass back and let the caller deal with it. */
6392 internal_error ("bad expression type during walk (%d)",
6399 /* Entry point for expression walking.
6400 A return value equal to the passed chain means this is
6401 a scalar expression. It is up to the caller to take whatever action is
6402 necessary to translate these. */
6405 gfc_walk_expr (gfc_expr * expr)
6409 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6410 return gfc_reverse_ss (res);