1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subscripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set. */
167 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
171 type = TREE_TYPE (desc);
172 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
174 field = TYPE_FIELDS (type);
175 gcc_assert (DATA_FIELD == 0);
177 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc)
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
196 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
197 return build_fold_addr_expr (t);
201 gfc_conv_descriptor_offset (tree desc)
206 type = TREE_TYPE (desc);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
210 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
213 desc, field, NULL_TREE);
217 gfc_conv_descriptor_dtype (tree desc)
222 type = TREE_TYPE (desc);
223 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
225 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
226 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
228 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
229 desc, field, NULL_TREE);
233 gfc_conv_descriptor_dimension (tree desc, tree dim)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
243 gcc_assert (field != NULL_TREE
244 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
247 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
248 desc, field, NULL_TREE);
249 tmp = gfc_build_array_ref (tmp, dim, NULL);
254 gfc_conv_descriptor_stride (tree desc, tree dim)
259 tmp = gfc_conv_descriptor_dimension (desc, dim);
260 field = TYPE_FIELDS (TREE_TYPE (tmp));
261 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
262 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
264 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
265 tmp, field, NULL_TREE);
270 gfc_conv_descriptor_lbound (tree desc, tree dim)
275 tmp = gfc_conv_descriptor_dimension (desc, dim);
276 field = TYPE_FIELDS (TREE_TYPE (tmp));
277 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
278 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
280 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
281 tmp, field, NULL_TREE);
286 gfc_conv_descriptor_ubound (tree desc, tree dim)
291 tmp = gfc_conv_descriptor_dimension (desc, dim);
292 field = TYPE_FIELDS (TREE_TYPE (tmp));
293 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
294 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
296 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
297 tmp, field, NULL_TREE);
302 /* Build a null array descriptor constructor. */
305 gfc_build_null_descriptor (tree type)
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
311 gcc_assert (DATA_FIELD == 0);
312 field = TYPE_FIELDS (type);
314 /* Set a NULL data pointer. */
315 tmp = build_constructor_single (type, field, null_pointer_node);
316 TREE_CONSTANT (tmp) = 1;
317 /* All other fields are ignored. */
323 /* Cleanup those #defines. */
328 #undef DIMENSION_FIELD
329 #undef STRIDE_SUBFIELD
330 #undef LBOUND_SUBFIELD
331 #undef UBOUND_SUBFIELD
334 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
335 flags & 1 = Main loop body.
336 flags & 2 = temp copy loop. */
339 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
341 for (; ss != gfc_ss_terminator; ss = ss->next)
342 ss->useflags = flags;
345 static void gfc_free_ss (gfc_ss *);
348 /* Free a gfc_ss chain. */
351 gfc_free_ss_chain (gfc_ss * ss)
355 while (ss != gfc_ss_terminator)
357 gcc_assert (ss != NULL);
368 gfc_free_ss (gfc_ss * ss)
375 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
377 if (ss->data.info.subscript[n])
378 gfc_free_ss_chain (ss->data.info.subscript[n]);
390 /* Free all the SS associated with a loop. */
393 gfc_cleanup_loop (gfc_loopinfo * loop)
399 while (ss != gfc_ss_terminator)
401 gcc_assert (ss != NULL);
402 next = ss->loop_chain;
409 /* Associate a SS chain with a loop. */
412 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
416 if (head == gfc_ss_terminator)
420 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
422 if (ss->next == gfc_ss_terminator)
423 ss->loop_chain = loop->ss;
425 ss->loop_chain = ss->next;
427 gcc_assert (ss == gfc_ss_terminator);
432 /* Generate an initializer for a static pointer or allocatable array. */
435 gfc_trans_static_array_pointer (gfc_symbol * sym)
439 gcc_assert (TREE_STATIC (sym->backend_decl));
440 /* Just zero the data member. */
441 type = TREE_TYPE (sym->backend_decl);
442 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
446 /* If the bounds of SE's loop have not yet been set, see if they can be
447 determined from array spec AS, which is the array spec of a called
448 function. MAPPING maps the callee's dummy arguments to the values
449 that the caller is passing. Add any initialization and finalization
453 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
454 gfc_se * se, gfc_array_spec * as)
462 if (as && as->type == AS_EXPLICIT)
463 for (dim = 0; dim < se->loop->dimen; dim++)
465 n = se->loop->order[dim];
466 if (se->loop->to[n] == NULL_TREE)
468 /* Evaluate the lower bound. */
469 gfc_init_se (&tmpse, NULL);
470 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
471 gfc_add_block_to_block (&se->pre, &tmpse.pre);
472 gfc_add_block_to_block (&se->post, &tmpse.post);
473 lower = fold_convert (gfc_array_index_type, tmpse.expr);
475 /* ...and the upper bound. */
476 gfc_init_se (&tmpse, NULL);
477 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
478 gfc_add_block_to_block (&se->pre, &tmpse.pre);
479 gfc_add_block_to_block (&se->post, &tmpse.post);
480 upper = fold_convert (gfc_array_index_type, tmpse.expr);
482 /* Set the upper bound of the loop to UPPER - LOWER. */
483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
484 tmp = gfc_evaluate_now (tmp, &se->pre);
485 se->loop->to[n] = tmp;
491 /* Generate code to allocate an array temporary, or create a variable to
492 hold the data. If size is NULL, zero the descriptor so that the
493 callee will allocate the array. If DEALLOC is true, also generate code to
494 free the array afterwards.
496 Initialization code is added to PRE and finalization code to POST.
497 DYNAMIC is true if the caller may want to extend the array later
498 using realloc. This prevents us from putting the array on the stack. */
501 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
502 gfc_ss_info * info, tree size, tree nelem,
503 bool dynamic, bool dealloc)
509 desc = info->descriptor;
510 info->offset = gfc_index_zero_node;
511 if (size == NULL_TREE || integer_zerop (size))
513 /* A callee allocated array. */
514 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
519 /* Allocate the temporary. */
520 onstack = !dynamic && gfc_can_put_var_on_stack (size);
524 /* Make a temporary variable to hold the data. */
525 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
527 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
529 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
531 tmp = gfc_create_var (tmp, "A");
532 tmp = build_fold_addr_expr (tmp);
533 gfc_conv_descriptor_data_set (pre, desc, tmp);
537 /* Allocate memory to hold the data. */
538 tmp = gfc_call_malloc (pre, NULL, size);
539 tmp = gfc_evaluate_now (tmp, pre);
540 gfc_conv_descriptor_data_set (pre, desc, tmp);
543 info->data = gfc_conv_descriptor_data_get (desc);
545 /* The offset is zero because we create temporaries with a zero
547 tmp = gfc_conv_descriptor_offset (desc);
548 gfc_add_modify (pre, tmp, gfc_index_zero_node);
550 if (dealloc && !onstack)
552 /* Free the temporary. */
553 tmp = gfc_conv_descriptor_data_get (desc);
554 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
555 gfc_add_expr_to_block (post, tmp);
560 /* Generate code to create and initialize the descriptor for a temporary
561 array. This is used for both temporaries needed by the scalarizer, and
562 functions returning arrays. Adjusts the loop variables to be
563 zero-based, and calculates the loop bounds for callee allocated arrays.
564 Allocate the array unless it's callee allocated (we have a callee
565 allocated array if 'callee_alloc' is true, or if loop->to[n] is
566 NULL_TREE for any n). Also fills in the descriptor, data and offset
567 fields of info if known. Returns the size of the array, or NULL for a
568 callee allocated array.
570 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
574 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
575 gfc_loopinfo * loop, gfc_ss_info * info,
576 tree eltype, bool dynamic, bool dealloc,
577 bool callee_alloc, locus * where)
589 gcc_assert (info->dimen > 0);
591 if (gfc_option.warn_array_temp && where)
592 gfc_warning ("Creating array temporary at %L", where);
594 /* Set the lower bound to zero. */
595 for (dim = 0; dim < info->dimen; dim++)
597 n = loop->order[dim];
598 /* TODO: Investigate why "if (n < loop->temp_dim)
599 gcc_assert (integer_zerop (loop->from[n]));" fails here. */
600 if (n >= loop->temp_dim)
602 /* Callee allocated arrays may not have a known bound yet. */
604 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
605 loop->to[n], loop->from[n]);
606 loop->from[n] = gfc_index_zero_node;
609 info->delta[dim] = gfc_index_zero_node;
610 info->start[dim] = gfc_index_zero_node;
611 info->end[dim] = gfc_index_zero_node;
612 info->stride[dim] = gfc_index_one_node;
613 info->dim[dim] = dim;
616 /* Initialize the descriptor. */
618 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
620 desc = gfc_create_var (type, "atmp");
621 GFC_DECL_PACKED_ARRAY (desc) = 1;
623 info->descriptor = desc;
624 size = gfc_index_one_node;
626 /* Fill in the array dtype. */
627 tmp = gfc_conv_descriptor_dtype (desc);
628 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
631 Fill in the bounds and stride. This is a packed array, so:
634 for (n = 0; n < rank; n++)
637 delta = ubound[n] + 1 - lbound[n];
640 size = size * sizeof(element);
645 for (n = 0; n < info->dimen; n++)
647 if (loop->to[n] == NULL_TREE)
649 /* For a callee allocated array express the loop bounds in terms
650 of the descriptor fields. */
652 fold_build2 (MINUS_EXPR, gfc_array_index_type,
653 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
654 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
660 /* Store the stride and bound components in the descriptor. */
661 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
662 gfc_add_modify (pre, tmp, size);
664 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
665 gfc_add_modify (pre, tmp, gfc_index_zero_node);
667 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
668 gfc_add_modify (pre, tmp, loop->to[n]);
670 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
671 loop->to[n], gfc_index_one_node);
673 /* Check whether the size for this dimension is negative. */
674 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
675 gfc_index_zero_node);
676 cond = gfc_evaluate_now (cond, pre);
681 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
683 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
684 size = gfc_evaluate_now (size, pre);
687 /* Get the size of the array. */
689 if (size && !callee_alloc)
691 /* If or_expr is true, then the extent in at least one
692 dimension is zero and the size is set to zero. */
693 size = fold_build3 (COND_EXPR, gfc_array_index_type,
694 or_expr, gfc_index_zero_node, size);
697 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
698 fold_convert (gfc_array_index_type,
699 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
707 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
710 if (info->dimen > loop->temp_dim)
711 loop->temp_dim = info->dimen;
717 /* Generate code to transpose array EXPR by creating a new descriptor
718 in which the dimension specifications have been reversed. */
721 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
723 tree dest, src, dest_index, src_index;
725 gfc_ss_info *dest_info, *src_info;
726 gfc_ss *dest_ss, *src_ss;
732 src_ss = gfc_walk_expr (expr);
735 src_info = &src_ss->data.info;
736 dest_info = &dest_ss->data.info;
737 gcc_assert (dest_info->dimen == 2);
738 gcc_assert (src_info->dimen == 2);
740 /* Get a descriptor for EXPR. */
741 gfc_init_se (&src_se, NULL);
742 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
743 gfc_add_block_to_block (&se->pre, &src_se.pre);
744 gfc_add_block_to_block (&se->post, &src_se.post);
747 /* Allocate a new descriptor for the return value. */
748 dest = gfc_create_var (TREE_TYPE (src), "atmp");
749 dest_info->descriptor = dest;
752 /* Copy across the dtype field. */
753 gfc_add_modify (&se->pre,
754 gfc_conv_descriptor_dtype (dest),
755 gfc_conv_descriptor_dtype (src));
757 /* Copy the dimension information, renumbering dimension 1 to 0 and
759 for (n = 0; n < 2; n++)
761 dest_info->delta[n] = gfc_index_zero_node;
762 dest_info->start[n] = gfc_index_zero_node;
763 dest_info->end[n] = gfc_index_zero_node;
764 dest_info->stride[n] = gfc_index_one_node;
765 dest_info->dim[n] = n;
767 dest_index = gfc_rank_cst[n];
768 src_index = gfc_rank_cst[1 - n];
770 gfc_add_modify (&se->pre,
771 gfc_conv_descriptor_stride (dest, dest_index),
772 gfc_conv_descriptor_stride (src, src_index));
774 gfc_add_modify (&se->pre,
775 gfc_conv_descriptor_lbound (dest, dest_index),
776 gfc_conv_descriptor_lbound (src, src_index));
778 gfc_add_modify (&se->pre,
779 gfc_conv_descriptor_ubound (dest, dest_index),
780 gfc_conv_descriptor_ubound (src, src_index));
784 gcc_assert (integer_zerop (loop->from[n]));
786 fold_build2 (MINUS_EXPR, gfc_array_index_type,
787 gfc_conv_descriptor_ubound (dest, dest_index),
788 gfc_conv_descriptor_lbound (dest, dest_index));
792 /* Copy the data pointer. */
793 dest_info->data = gfc_conv_descriptor_data_get (src);
794 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
796 /* Copy the offset. This is not changed by transposition; the top-left
797 element is still at the same offset as before, except where the loop
799 if (!integer_zerop (loop->from[0]))
800 dest_info->offset = gfc_conv_descriptor_offset (src);
802 dest_info->offset = gfc_index_zero_node;
804 gfc_add_modify (&se->pre,
805 gfc_conv_descriptor_offset (dest),
808 if (dest_info->dimen > loop->temp_dim)
809 loop->temp_dim = dest_info->dimen;
813 /* Return the number of iterations in a loop that starts at START,
814 ends at END, and has step STEP. */
817 gfc_get_iteration_count (tree start, tree end, tree step)
822 type = TREE_TYPE (step);
823 tmp = fold_build2 (MINUS_EXPR, type, end, start);
824 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
825 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
826 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
827 return fold_convert (gfc_array_index_type, tmp);
831 /* Extend the data in array DESC by EXTRA elements. */
834 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
841 if (integer_zerop (extra))
844 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
846 /* Add EXTRA to the upper bound. */
847 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
848 gfc_add_modify (pblock, ubound, tmp);
850 /* Get the value of the current data pointer. */
851 arg0 = gfc_conv_descriptor_data_get (desc);
853 /* Calculate the new array size. */
854 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
855 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
856 ubound, gfc_index_one_node);
857 arg1 = fold_build2 (MULT_EXPR, size_type_node,
858 fold_convert (size_type_node, tmp),
859 fold_convert (size_type_node, size));
861 /* Call the realloc() function. */
862 tmp = gfc_call_realloc (pblock, arg0, arg1);
863 gfc_conv_descriptor_data_set (pblock, desc, tmp);
867 /* Return true if the bounds of iterator I can only be determined
871 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
873 return (i->start->expr_type != EXPR_CONSTANT
874 || i->end->expr_type != EXPR_CONSTANT
875 || i->step->expr_type != EXPR_CONSTANT);
879 /* Split the size of constructor element EXPR into the sum of two terms,
880 one of which can be determined at compile time and one of which must
881 be calculated at run time. Set *SIZE to the former and return true
882 if the latter might be nonzero. */
885 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
887 if (expr->expr_type == EXPR_ARRAY)
888 return gfc_get_array_constructor_size (size, expr->value.constructor);
889 else if (expr->rank > 0)
891 /* Calculate everything at run time. */
892 mpz_set_ui (*size, 0);
897 /* A single element. */
898 mpz_set_ui (*size, 1);
904 /* Like gfc_get_array_constructor_element_size, but applied to the whole
905 of array constructor C. */
908 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
915 mpz_set_ui (*size, 0);
920 for (; c; c = c->next)
923 if (i && gfc_iterator_has_dynamic_bounds (i))
927 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
930 /* Multiply the static part of the element size by the
931 number of iterations. */
932 mpz_sub (val, i->end->value.integer, i->start->value.integer);
933 mpz_fdiv_q (val, val, i->step->value.integer);
934 mpz_add_ui (val, val, 1);
935 if (mpz_sgn (val) > 0)
936 mpz_mul (len, len, val);
940 mpz_add (*size, *size, len);
949 /* Make sure offset is a variable. */
952 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
955 /* We should have already created the offset variable. We cannot
956 create it here because we may be in an inner scope. */
957 gcc_assert (*offsetvar != NULL_TREE);
958 gfc_add_modify (pblock, *offsetvar, *poffset);
959 *poffset = *offsetvar;
960 TREE_USED (*offsetvar) = 1;
964 /* Variables needed for bounds-checking. */
965 static bool first_len;
966 static tree first_len_val;
967 static bool typespec_chararray_ctor;
970 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
971 tree offset, gfc_se * se, gfc_expr * expr)
975 gfc_conv_expr (se, expr);
977 /* Store the value. */
978 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
979 tmp = gfc_build_array_ref (tmp, offset, NULL);
981 if (expr->ts.type == BT_CHARACTER)
983 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
986 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
987 esize = fold_convert (gfc_charlen_type_node, esize);
988 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
989 build_int_cst (gfc_charlen_type_node,
990 gfc_character_kinds[i].bit_size / 8));
992 gfc_conv_string_parameter (se);
993 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
995 /* The temporary is an array of pointers. */
996 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
997 gfc_add_modify (&se->pre, tmp, se->expr);
1001 /* The temporary is an array of string values. */
1002 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1003 /* We know the temporary and the value will be the same length,
1004 so can use memcpy. */
1005 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1006 se->string_length, se->expr, expr->ts.kind);
1008 if (flag_bounds_check && !typespec_chararray_ctor)
1012 gfc_add_modify (&se->pre, first_len_val,
1018 /* Verify that all constructor elements are of the same
1020 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1021 first_len_val, se->string_length);
1022 gfc_trans_runtime_check
1023 (true, false, cond, &se->pre, &expr->where,
1024 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1025 fold_convert (long_integer_type_node, first_len_val),
1026 fold_convert (long_integer_type_node, se->string_length));
1032 /* TODO: Should the frontend already have done this conversion? */
1033 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1034 gfc_add_modify (&se->pre, tmp, se->expr);
1037 gfc_add_block_to_block (pblock, &se->pre);
1038 gfc_add_block_to_block (pblock, &se->post);
1042 /* Add the contents of an array to the constructor. DYNAMIC is as for
1043 gfc_trans_array_constructor_value. */
1046 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1047 tree type ATTRIBUTE_UNUSED,
1048 tree desc, gfc_expr * expr,
1049 tree * poffset, tree * offsetvar,
1060 /* We need this to be a variable so we can increment it. */
1061 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1063 gfc_init_se (&se, NULL);
1065 /* Walk the array expression. */
1066 ss = gfc_walk_expr (expr);
1067 gcc_assert (ss != gfc_ss_terminator);
1069 /* Initialize the scalarizer. */
1070 gfc_init_loopinfo (&loop);
1071 gfc_add_ss_to_loop (&loop, ss);
1073 /* Initialize the loop. */
1074 gfc_conv_ss_startstride (&loop);
1075 gfc_conv_loop_setup (&loop, &expr->where);
1077 /* Make sure the constructed array has room for the new data. */
1080 /* Set SIZE to the total number of elements in the subarray. */
1081 size = gfc_index_one_node;
1082 for (n = 0; n < loop.dimen; n++)
1084 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1085 gfc_index_one_node);
1086 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1089 /* Grow the constructed array by SIZE elements. */
1090 gfc_grow_array (&loop.pre, desc, size);
1093 /* Make the loop body. */
1094 gfc_mark_ss_chain_used (ss, 1);
1095 gfc_start_scalarized_body (&loop, &body);
1096 gfc_copy_loopinfo_to_se (&se, &loop);
1099 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1100 gcc_assert (se.ss == gfc_ss_terminator);
1102 /* Increment the offset. */
1103 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1104 *poffset, gfc_index_one_node);
1105 gfc_add_modify (&body, *poffset, tmp);
1107 /* Finish the loop. */
1108 gfc_trans_scalarizing_loops (&loop, &body);
1109 gfc_add_block_to_block (&loop.pre, &loop.post);
1110 tmp = gfc_finish_block (&loop.pre);
1111 gfc_add_expr_to_block (pblock, tmp);
1113 gfc_cleanup_loop (&loop);
1117 /* Assign the values to the elements of an array constructor. DYNAMIC
1118 is true if descriptor DESC only contains enough data for the static
1119 size calculated by gfc_get_array_constructor_size. When true, memory
1120 for the dynamic parts must be allocated using realloc. */
1123 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1124 tree desc, gfc_constructor * c,
1125 tree * poffset, tree * offsetvar,
1134 for (; c; c = c->next)
1136 /* If this is an iterator or an array, the offset must be a variable. */
1137 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1138 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1140 gfc_start_block (&body);
1142 if (c->expr->expr_type == EXPR_ARRAY)
1144 /* Array constructors can be nested. */
1145 gfc_trans_array_constructor_value (&body, type, desc,
1146 c->expr->value.constructor,
1147 poffset, offsetvar, dynamic);
1149 else if (c->expr->rank > 0)
1151 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1152 poffset, offsetvar, dynamic);
1156 /* This code really upsets the gimplifier so don't bother for now. */
1163 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1170 /* Scalar values. */
1171 gfc_init_se (&se, NULL);
1172 gfc_trans_array_ctor_element (&body, desc, *poffset,
1175 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1176 *poffset, gfc_index_one_node);
1180 /* Collect multiple scalar constants into a constructor. */
1188 /* Count the number of consecutive scalar constants. */
1189 while (p && !(p->iterator
1190 || p->expr->expr_type != EXPR_CONSTANT))
1192 gfc_init_se (&se, NULL);
1193 gfc_conv_constant (&se, p->expr);
1195 /* For constant character array constructors we build
1196 an array of pointers. */
1197 if (p->expr->ts.type == BT_CHARACTER
1198 && POINTER_TYPE_P (type))
1199 se.expr = gfc_build_addr_expr
1200 (gfc_get_pchar_type (p->expr->ts.kind),
1203 list = tree_cons (NULL_TREE, se.expr, list);
1208 bound = build_int_cst (NULL_TREE, n - 1);
1209 /* Create an array type to hold them. */
1210 tmptype = build_range_type (gfc_array_index_type,
1211 gfc_index_zero_node, bound);
1212 tmptype = build_array_type (type, tmptype);
1214 init = build_constructor_from_list (tmptype, nreverse (list));
1215 TREE_CONSTANT (init) = 1;
1216 TREE_STATIC (init) = 1;
1217 /* Create a static variable to hold the data. */
1218 tmp = gfc_create_var (tmptype, "data");
1219 TREE_STATIC (tmp) = 1;
1220 TREE_CONSTANT (tmp) = 1;
1221 TREE_READONLY (tmp) = 1;
1222 DECL_INITIAL (tmp) = init;
1225 /* Use BUILTIN_MEMCPY to assign the values. */
1226 tmp = gfc_conv_descriptor_data_get (desc);
1227 tmp = build_fold_indirect_ref (tmp);
1228 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1229 tmp = build_fold_addr_expr (tmp);
1230 init = build_fold_addr_expr (init);
1232 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1233 bound = build_int_cst (NULL_TREE, n * size);
1234 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1236 gfc_add_expr_to_block (&body, tmp);
1238 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1240 build_int_cst (gfc_array_index_type, n));
1242 if (!INTEGER_CST_P (*poffset))
1244 gfc_add_modify (&body, *offsetvar, *poffset);
1245 *poffset = *offsetvar;
1249 /* The frontend should already have done any expansions possible
1253 /* Pass the code as is. */
1254 tmp = gfc_finish_block (&body);
1255 gfc_add_expr_to_block (pblock, tmp);
1259 /* Build the implied do-loop. */
1269 loopbody = gfc_finish_block (&body);
1271 if (c->iterator->var->symtree->n.sym->backend_decl)
1273 gfc_init_se (&se, NULL);
1274 gfc_conv_expr (&se, c->iterator->var);
1275 gfc_add_block_to_block (pblock, &se.pre);
1280 /* If the iterator appears in a specification expression in
1281 an interface mapping, we need to make a temp for the loop
1282 variable because it is not declared locally. */
1283 loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
1284 loopvar = gfc_create_var (loopvar, "loopvar");
1287 /* Make a temporary, store the current value in that
1288 and return it, once the loop is done. */
1289 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1290 gfc_add_modify (pblock, tmp_loopvar, loopvar);
1292 /* Initialize the loop. */
1293 gfc_init_se (&se, NULL);
1294 gfc_conv_expr_val (&se, c->iterator->start);
1295 gfc_add_block_to_block (pblock, &se.pre);
1296 gfc_add_modify (pblock, loopvar, se.expr);
1298 gfc_init_se (&se, NULL);
1299 gfc_conv_expr_val (&se, c->iterator->end);
1300 gfc_add_block_to_block (pblock, &se.pre);
1301 end = gfc_evaluate_now (se.expr, pblock);
1303 gfc_init_se (&se, NULL);
1304 gfc_conv_expr_val (&se, c->iterator->step);
1305 gfc_add_block_to_block (pblock, &se.pre);
1306 step = gfc_evaluate_now (se.expr, pblock);
1308 /* If this array expands dynamically, and the number of iterations
1309 is not constant, we won't have allocated space for the static
1310 part of C->EXPR's size. Do that now. */
1311 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1313 /* Get the number of iterations. */
1314 tmp = gfc_get_iteration_count (loopvar, end, step);
1316 /* Get the static part of C->EXPR's size. */
1317 gfc_get_array_constructor_element_size (&size, c->expr);
1318 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1320 /* Grow the array by TMP * TMP2 elements. */
1321 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1322 gfc_grow_array (pblock, desc, tmp);
1325 /* Generate the loop body. */
1326 exit_label = gfc_build_label_decl (NULL_TREE);
1327 gfc_start_block (&body);
1329 /* Generate the exit condition. Depending on the sign of
1330 the step variable we have to generate the correct
1332 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1333 build_int_cst (TREE_TYPE (step), 0));
1334 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1335 fold_build2 (GT_EXPR, boolean_type_node,
1337 fold_build2 (LT_EXPR, boolean_type_node,
1339 tmp = build1_v (GOTO_EXPR, exit_label);
1340 TREE_USED (exit_label) = 1;
1341 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1342 gfc_add_expr_to_block (&body, tmp);
1344 /* The main loop body. */
1345 gfc_add_expr_to_block (&body, loopbody);
1347 /* Increase loop variable by step. */
1348 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1349 gfc_add_modify (&body, loopvar, tmp);
1351 /* Finish the loop. */
1352 tmp = gfc_finish_block (&body);
1353 tmp = build1_v (LOOP_EXPR, tmp);
1354 gfc_add_expr_to_block (pblock, tmp);
1356 /* Add the exit label. */
1357 tmp = build1_v (LABEL_EXPR, exit_label);
1358 gfc_add_expr_to_block (pblock, tmp);
1360 /* Restore the original value of the loop counter. */
1361 gfc_add_modify (pblock, loopvar, tmp_loopvar);
1368 /* Figure out the string length of a variable reference expression.
1369 Used by get_array_ctor_strlen. */
1372 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1378 /* Don't bother if we already know the length is a constant. */
1379 if (*len && INTEGER_CST_P (*len))
1382 ts = &expr->symtree->n.sym->ts;
1383 for (ref = expr->ref; ref; ref = ref->next)
1388 /* Array references don't change the string length. */
1392 /* Use the length of the component. */
1393 ts = &ref->u.c.component->ts;
1397 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1398 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1400 mpz_init_set_ui (char_len, 1);
1401 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1402 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1403 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1404 *len = convert (gfc_charlen_type_node, *len);
1405 mpz_clear (char_len);
1409 /* TODO: Substrings are tricky because we can't evaluate the
1410 expression more than once. For now we just give up, and hope
1411 we can figure it out elsewhere. */
1416 *len = ts->cl->backend_decl;
1420 /* A catch-all to obtain the string length for anything that is not a
1421 constant, array or variable. */
1423 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1428 /* Don't bother if we already know the length is a constant. */
1429 if (*len && INTEGER_CST_P (*len))
1432 if (!e->ref && e->ts.cl && e->ts.cl->length
1433 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1436 gfc_conv_const_charlen (e->ts.cl);
1437 *len = e->ts.cl->backend_decl;
1441 /* Otherwise, be brutal even if inefficient. */
1442 ss = gfc_walk_expr (e);
1443 gfc_init_se (&se, NULL);
1445 /* No function call, in case of side effects. */
1446 se.no_function_call = 1;
1447 if (ss == gfc_ss_terminator)
1448 gfc_conv_expr (&se, e);
1450 gfc_conv_expr_descriptor (&se, e, ss);
1452 /* Fix the value. */
1453 *len = gfc_evaluate_now (se.string_length, &se.pre);
1455 gfc_add_block_to_block (block, &se.pre);
1456 gfc_add_block_to_block (block, &se.post);
1458 e->ts.cl->backend_decl = *len;
1463 /* Figure out the string length of a character array constructor.
1464 If len is NULL, don't calculate the length; this happens for recursive calls
1465 when a sub-array-constructor is an element but not at the first position,
1466 so when we're not interested in the length.
1467 Returns TRUE if all elements are character constants. */
1470 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1479 *len = build_int_cstu (gfc_charlen_type_node, 0);
1483 /* Loop over all constructor elements to find out is_const, but in len we
1484 want to store the length of the first, not the last, element. We can
1485 of course exit the loop as soon as is_const is found to be false. */
1486 for (; c && is_const; c = c->next)
1488 switch (c->expr->expr_type)
1491 if (len && !(*len && INTEGER_CST_P (*len)))
1492 *len = build_int_cstu (gfc_charlen_type_node,
1493 c->expr->value.character.length);
1497 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1504 get_array_ctor_var_strlen (c->expr, len);
1510 get_array_ctor_all_strlen (block, c->expr, len);
1514 /* After the first iteration, we don't want the length modified. */
1521 /* Check whether the array constructor C consists entirely of constant
1522 elements, and if so returns the number of those elements, otherwise
1523 return zero. Note, an empty or NULL array constructor returns zero. */
1525 unsigned HOST_WIDE_INT
1526 gfc_constant_array_constructor_p (gfc_constructor * c)
1528 unsigned HOST_WIDE_INT nelem = 0;
1533 || c->expr->rank > 0
1534 || c->expr->expr_type != EXPR_CONSTANT)
1543 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1544 and the tree type of it's elements, TYPE, return a static constant
1545 variable that is compile-time initialized. */
1548 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1550 tree tmptype, list, init, tmp;
1551 HOST_WIDE_INT nelem;
1557 /* First traverse the constructor list, converting the constants
1558 to tree to build an initializer. */
1561 c = expr->value.constructor;
1564 gfc_init_se (&se, NULL);
1565 gfc_conv_constant (&se, c->expr);
1566 if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
1567 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1569 list = tree_cons (NULL_TREE, se.expr, list);
1574 /* Next determine the tree type for the array. We use the gfortran
1575 front-end's gfc_get_nodesc_array_type in order to create a suitable
1576 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1578 memset (&as, 0, sizeof (gfc_array_spec));
1580 as.rank = expr->rank;
1581 as.type = AS_EXPLICIT;
1584 as.lower[0] = gfc_int_expr (0);
1585 as.upper[0] = gfc_int_expr (nelem - 1);
1588 for (i = 0; i < expr->rank; i++)
1590 int tmp = (int) mpz_get_si (expr->shape[i]);
1591 as.lower[i] = gfc_int_expr (0);
1592 as.upper[i] = gfc_int_expr (tmp - 1);
1595 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1597 init = build_constructor_from_list (tmptype, nreverse (list));
1599 TREE_CONSTANT (init) = 1;
1600 TREE_STATIC (init) = 1;
1602 tmp = gfc_create_var (tmptype, "A");
1603 TREE_STATIC (tmp) = 1;
1604 TREE_CONSTANT (tmp) = 1;
1605 TREE_READONLY (tmp) = 1;
1606 DECL_INITIAL (tmp) = init;
1612 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1613 This mostly initializes the scalarizer state info structure with the
1614 appropriate values to directly use the array created by the function
1615 gfc_build_constant_array_constructor. */
1618 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1619 gfc_ss * ss, tree type)
1625 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1627 info = &ss->data.info;
1629 info->descriptor = tmp;
1630 info->data = build_fold_addr_expr (tmp);
1631 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1634 for (i = 0; i < info->dimen; i++)
1636 info->delta[i] = gfc_index_zero_node;
1637 info->start[i] = gfc_index_zero_node;
1638 info->end[i] = gfc_index_zero_node;
1639 info->stride[i] = gfc_index_one_node;
1643 if (info->dimen > loop->temp_dim)
1644 loop->temp_dim = info->dimen;
1647 /* Helper routine of gfc_trans_array_constructor to determine if the
1648 bounds of the loop specified by LOOP are constant and simple enough
1649 to use with gfc_trans_constant_array_constructor. Returns the
1650 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1653 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1655 tree size = gfc_index_one_node;
1659 for (i = 0; i < loop->dimen; i++)
1661 /* If the bounds aren't constant, return NULL_TREE. */
1662 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1664 if (!integer_zerop (loop->from[i]))
1666 /* Only allow nonzero "from" in one-dimensional arrays. */
1667 if (loop->dimen != 1)
1669 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1670 loop->to[i], loop->from[i]);
1674 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1675 tmp, gfc_index_one_node);
1676 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1683 /* Array constructors are handled by constructing a temporary, then using that
1684 within the scalarization loop. This is not optimal, but seems by far the
1688 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1698 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1699 typespec was given for the array constructor. */
1700 typespec_chararray_ctor = (ss->expr->ts.cl
1701 && ss->expr->ts.cl->length_from_typespec);
1703 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
1704 && !typespec_chararray_ctor)
1706 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1710 ss->data.info.dimen = loop->dimen;
1712 c = ss->expr->value.constructor;
1713 if (ss->expr->ts.type == BT_CHARACTER)
1717 /* get_array_ctor_strlen walks the elements of the constructor, if a
1718 typespec was given, we already know the string length and want the one
1720 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1721 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1725 const_string = false;
1726 gfc_init_se (&length_se, NULL);
1727 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1728 gfc_charlen_type_node);
1729 ss->string_length = length_se.expr;
1730 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1731 gfc_add_block_to_block (&loop->post, &length_se.post);
1734 const_string = get_array_ctor_strlen (&loop->pre, c,
1735 &ss->string_length);
1737 /* Complex character array constructors should have been taken care of
1738 and not end up here. */
1739 gcc_assert (ss->string_length);
1741 ss->expr->ts.cl->backend_decl = ss->string_length;
1743 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1745 type = build_pointer_type (type);
1748 type = gfc_typenode_for_spec (&ss->expr->ts);
1750 /* See if the constructor determines the loop bounds. */
1753 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1755 /* We have a multidimensional parameter. */
1757 for (n = 0; n < ss->expr->rank; n++)
1759 loop->from[n] = gfc_index_zero_node;
1760 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1761 gfc_index_integer_kind);
1762 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1763 loop->to[n], gfc_index_one_node);
1767 if (loop->to[0] == NULL_TREE)
1771 /* We should have a 1-dimensional, zero-based loop. */
1772 gcc_assert (loop->dimen == 1);
1773 gcc_assert (integer_zerop (loop->from[0]));
1775 /* Split the constructor size into a static part and a dynamic part.
1776 Allocate the static size up-front and record whether the dynamic
1777 size might be nonzero. */
1779 dynamic = gfc_get_array_constructor_size (&size, c);
1780 mpz_sub_ui (size, size, 1);
1781 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1785 /* Special case constant array constructors. */
1788 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1791 tree size = constant_array_constructor_loop_size (loop);
1792 if (size && compare_tree_int (size, nelem) == 0)
1794 gfc_trans_constant_array_constructor (loop, ss, type);
1800 /* Temporarily reset the loop variables, so that the returned temporary
1801 has the right size and bounds. This seems only to be necessary for
1803 if (!integer_zerop (loop->from[0]) && loop->dimen == 1)
1805 loopfrom = loop->from[0];
1806 loop->from[0] = gfc_index_zero_node;
1807 loop->to[0] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1808 loop->to[0], loopfrom);
1811 loopfrom = NULL_TREE;
1813 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1814 type, dynamic, true, false, where);
1816 if (loopfrom != NULL_TREE)
1818 loop->from[0] = loopfrom;
1819 loop->to[0] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1820 loop->to[0], loopfrom);
1821 /* In the case of a non-zero from, the temporary needs an offset
1822 so that subsequent indexing is correct. */
1823 ss->data.info.offset = fold_build1 (NEGATE_EXPR,
1824 gfc_array_index_type,
1828 desc = ss->data.info.descriptor;
1829 offset = gfc_index_zero_node;
1830 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1831 TREE_NO_WARNING (offsetvar) = 1;
1832 TREE_USED (offsetvar) = 0;
1833 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1834 &offset, &offsetvar, dynamic);
1836 /* If the array grows dynamically, the upper bound of the loop variable
1837 is determined by the array's final upper bound. */
1839 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1841 if (TREE_USED (offsetvar))
1842 pushdecl (offsetvar);
1844 gcc_assert (INTEGER_CST_P (offset));
1846 /* Disable bound checking for now because it's probably broken. */
1847 if (flag_bounds_check)
1855 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1856 called after evaluating all of INFO's vector dimensions. Go through
1857 each such vector dimension and see if we can now fill in any missing
1861 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1870 for (n = 0; n < loop->dimen; n++)
1873 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1874 && loop->to[n] == NULL)
1876 /* Loop variable N indexes vector dimension DIM, and we don't
1877 yet know the upper bound of loop variable N. Set it to the
1878 difference between the vector's upper and lower bounds. */
1879 gcc_assert (loop->from[n] == gfc_index_zero_node);
1880 gcc_assert (info->subscript[dim]
1881 && info->subscript[dim]->type == GFC_SS_VECTOR);
1883 gfc_init_se (&se, NULL);
1884 desc = info->subscript[dim]->data.info.descriptor;
1885 zero = gfc_rank_cst[0];
1886 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1887 gfc_conv_descriptor_ubound (desc, zero),
1888 gfc_conv_descriptor_lbound (desc, zero));
1889 tmp = gfc_evaluate_now (tmp, &loop->pre);
1896 /* Add the pre and post chains for all the scalar expressions in a SS chain
1897 to loop. This is called after the loop parameters have been calculated,
1898 but before the actual scalarizing loops. */
1901 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1907 /* TODO: This can generate bad code if there are ordering dependencies,
1908 e.g., a callee allocated function and an unknown size constructor. */
1909 gcc_assert (ss != NULL);
1911 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1918 /* Scalar expression. Evaluate this now. This includes elemental
1919 dimension indices, but not array section bounds. */
1920 gfc_init_se (&se, NULL);
1921 gfc_conv_expr (&se, ss->expr);
1922 gfc_add_block_to_block (&loop->pre, &se.pre);
1924 if (ss->expr->ts.type != BT_CHARACTER)
1926 /* Move the evaluation of scalar expressions outside the
1927 scalarization loop, except for WHERE assignments. */
1929 se.expr = convert(gfc_array_index_type, se.expr);
1931 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1932 gfc_add_block_to_block (&loop->pre, &se.post);
1935 gfc_add_block_to_block (&loop->post, &se.post);
1937 ss->data.scalar.expr = se.expr;
1938 ss->string_length = se.string_length;
1941 case GFC_SS_REFERENCE:
1942 /* Scalar reference. Evaluate this now. */
1943 gfc_init_se (&se, NULL);
1944 gfc_conv_expr_reference (&se, ss->expr);
1945 gfc_add_block_to_block (&loop->pre, &se.pre);
1946 gfc_add_block_to_block (&loop->post, &se.post);
1948 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1949 ss->string_length = se.string_length;
1952 case GFC_SS_SECTION:
1953 /* Add the expressions for scalar and vector subscripts. */
1954 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1955 if (ss->data.info.subscript[n])
1956 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
1959 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1963 /* Get the vector's descriptor and store it in SS. */
1964 gfc_init_se (&se, NULL);
1965 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1966 gfc_add_block_to_block (&loop->pre, &se.pre);
1967 gfc_add_block_to_block (&loop->post, &se.post);
1968 ss->data.info.descriptor = se.expr;
1971 case GFC_SS_INTRINSIC:
1972 gfc_add_intrinsic_ss_code (loop, ss);
1975 case GFC_SS_FUNCTION:
1976 /* Array function return value. We call the function and save its
1977 result in a temporary for use inside the loop. */
1978 gfc_init_se (&se, NULL);
1981 gfc_conv_expr (&se, ss->expr);
1982 gfc_add_block_to_block (&loop->pre, &se.pre);
1983 gfc_add_block_to_block (&loop->post, &se.post);
1984 ss->string_length = se.string_length;
1987 case GFC_SS_CONSTRUCTOR:
1988 if (ss->expr->ts.type == BT_CHARACTER
1989 && ss->string_length == NULL
1991 && ss->expr->ts.cl->length)
1993 gfc_init_se (&se, NULL);
1994 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
1995 gfc_charlen_type_node);
1996 ss->string_length = se.expr;
1997 gfc_add_block_to_block (&loop->pre, &se.pre);
1998 gfc_add_block_to_block (&loop->post, &se.post);
2000 gfc_trans_array_constructor (loop, ss, where);
2004 case GFC_SS_COMPONENT:
2005 /* Do nothing. These are handled elsewhere. */
2015 /* Translate expressions for the descriptor and data pointer of a SS. */
2019 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2024 /* Get the descriptor for the array to be scalarized. */
2025 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2026 gfc_init_se (&se, NULL);
2027 se.descriptor_only = 1;
2028 gfc_conv_expr_lhs (&se, ss->expr);
2029 gfc_add_block_to_block (block, &se.pre);
2030 ss->data.info.descriptor = se.expr;
2031 ss->string_length = se.string_length;
2035 /* Also the data pointer. */
2036 tmp = gfc_conv_array_data (se.expr);
2037 /* If this is a variable or address of a variable we use it directly.
2038 Otherwise we must evaluate it now to avoid breaking dependency
2039 analysis by pulling the expressions for elemental array indices
2042 || (TREE_CODE (tmp) == ADDR_EXPR
2043 && DECL_P (TREE_OPERAND (tmp, 0)))))
2044 tmp = gfc_evaluate_now (tmp, block);
2045 ss->data.info.data = tmp;
2047 tmp = gfc_conv_array_offset (se.expr);
2048 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2053 /* Initialize a gfc_loopinfo structure. */
2056 gfc_init_loopinfo (gfc_loopinfo * loop)
2060 memset (loop, 0, sizeof (gfc_loopinfo));
2061 gfc_init_block (&loop->pre);
2062 gfc_init_block (&loop->post);
2064 /* Initially scalarize in order. */
2065 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2068 loop->ss = gfc_ss_terminator;
2072 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2076 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2082 /* Return an expression for the data pointer of an array. */
2085 gfc_conv_array_data (tree descriptor)
2089 type = TREE_TYPE (descriptor);
2090 if (GFC_ARRAY_TYPE_P (type))
2092 if (TREE_CODE (type) == POINTER_TYPE)
2096 /* Descriptorless arrays. */
2097 return build_fold_addr_expr (descriptor);
2101 return gfc_conv_descriptor_data_get (descriptor);
2105 /* Return an expression for the base offset of an array. */
2108 gfc_conv_array_offset (tree descriptor)
2112 type = TREE_TYPE (descriptor);
2113 if (GFC_ARRAY_TYPE_P (type))
2114 return GFC_TYPE_ARRAY_OFFSET (type);
2116 return gfc_conv_descriptor_offset (descriptor);
2120 /* Get an expression for the array stride. */
2123 gfc_conv_array_stride (tree descriptor, int dim)
2128 type = TREE_TYPE (descriptor);
2130 /* For descriptorless arrays use the array size. */
2131 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2132 if (tmp != NULL_TREE)
2135 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2140 /* Like gfc_conv_array_stride, but for the lower bound. */
2143 gfc_conv_array_lbound (tree descriptor, int dim)
2148 type = TREE_TYPE (descriptor);
2150 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2151 if (tmp != NULL_TREE)
2154 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2159 /* Like gfc_conv_array_stride, but for the upper bound. */
2162 gfc_conv_array_ubound (tree descriptor, int dim)
2167 type = TREE_TYPE (descriptor);
2169 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2170 if (tmp != NULL_TREE)
2173 /* This should only ever happen when passing an assumed shape array
2174 as an actual parameter. The value will never be used. */
2175 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2176 return gfc_index_zero_node;
2178 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2183 /* Generate code to perform an array index bound check. */
2186 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2187 locus * where, bool check_upper)
2192 const char * name = NULL;
2194 if (!flag_bounds_check)
2197 index = gfc_evaluate_now (index, &se->pre);
2199 /* We find a name for the error message. */
2201 name = se->ss->expr->symtree->name;
2203 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2204 && se->loop->ss->expr->symtree)
2205 name = se->loop->ss->expr->symtree->name;
2207 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2208 && se->loop->ss->loop_chain->expr
2209 && se->loop->ss->loop_chain->expr->symtree)
2210 name = se->loop->ss->loop_chain->expr->symtree->name;
2212 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2213 && se->loop->ss->loop_chain->expr->symtree)
2214 name = se->loop->ss->loop_chain->expr->symtree->name;
2216 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2218 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2219 && se->loop->ss->expr->value.function.name)
2220 name = se->loop->ss->expr->value.function.name;
2222 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2223 || se->loop->ss->type == GFC_SS_SCALAR)
2224 name = "unnamed constant";
2227 /* Check lower bound. */
2228 tmp = gfc_conv_array_lbound (descriptor, n);
2229 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2231 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2232 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2234 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2235 gfc_msg_fault, n+1);
2236 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2237 fold_convert (long_integer_type_node, index),
2238 fold_convert (long_integer_type_node, tmp));
2241 /* Check upper bound. */
2244 tmp = gfc_conv_array_ubound (descriptor, n);
2245 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2247 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2248 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2250 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2251 gfc_msg_fault, n+1);
2252 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2253 fold_convert (long_integer_type_node, index),
2254 fold_convert (long_integer_type_node, tmp));
2262 /* Return the offset for an index. Performs bound checking for elemental
2263 dimensions. Single element references are processed separately. */
2266 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2267 gfc_array_ref * ar, tree stride)
2273 /* Get the index into the array for this dimension. */
2276 gcc_assert (ar->type != AR_ELEMENT);
2277 switch (ar->dimen_type[dim])
2280 /* Elemental dimension. */
2281 gcc_assert (info->subscript[dim]
2282 && info->subscript[dim]->type == GFC_SS_SCALAR);
2283 /* We've already translated this value outside the loop. */
2284 index = info->subscript[dim]->data.scalar.expr;
2286 index = gfc_trans_array_bound_check (se, info->descriptor,
2287 index, dim, &ar->where,
2288 (ar->as->type != AS_ASSUMED_SIZE
2289 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2293 gcc_assert (info && se->loop);
2294 gcc_assert (info->subscript[dim]
2295 && info->subscript[dim]->type == GFC_SS_VECTOR);
2296 desc = info->subscript[dim]->data.info.descriptor;
2298 /* Get a zero-based index into the vector. */
2299 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2300 se->loop->loopvar[i], se->loop->from[i]);
2302 /* Multiply the index by the stride. */
2303 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2304 index, gfc_conv_array_stride (desc, 0));
2306 /* Read the vector to get an index into info->descriptor. */
2307 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2308 index = gfc_build_array_ref (data, index, NULL);
2309 index = gfc_evaluate_now (index, &se->pre);
2311 /* Do any bounds checking on the final info->descriptor index. */
2312 index = gfc_trans_array_bound_check (se, info->descriptor,
2313 index, dim, &ar->where,
2314 (ar->as->type != AS_ASSUMED_SIZE
2315 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2319 /* Scalarized dimension. */
2320 gcc_assert (info && se->loop);
2322 /* Multiply the loop variable by the stride and delta. */
2323 index = se->loop->loopvar[i];
2324 if (!integer_onep (info->stride[i]))
2325 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2327 if (!integer_zerop (info->delta[i]))
2328 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2338 /* Temporary array or derived type component. */
2339 gcc_assert (se->loop);
2340 index = se->loop->loopvar[se->loop->order[i]];
2341 if (!integer_zerop (info->delta[i]))
2342 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2343 index, info->delta[i]);
2346 /* Multiply by the stride. */
2347 if (!integer_onep (stride))
2348 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2354 /* Build a scalarized reference to an array. */
2357 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2360 tree decl = NULL_TREE;
2365 info = &se->ss->data.info;
2367 n = se->loop->order[0];
2371 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2373 /* Add the offset for this dimension to the stored offset for all other
2375 if (!integer_zerop (info->offset))
2376 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2378 if (se->ss->expr && is_subref_array (se->ss->expr))
2379 decl = se->ss->expr->symtree->n.sym->backend_decl;
2381 tmp = build_fold_indirect_ref (info->data);
2382 se->expr = gfc_build_array_ref (tmp, index, decl);
2386 /* Translate access of temporary array. */
2389 gfc_conv_tmp_array_ref (gfc_se * se)
2391 se->string_length = se->ss->string_length;
2392 gfc_conv_scalarized_array_ref (se, NULL);
2396 /* Build an array reference. se->expr already holds the array descriptor.
2397 This should be either a variable, indirect variable reference or component
2398 reference. For arrays which do not have a descriptor, se->expr will be
2400 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2403 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2412 /* Handle scalarized references separately. */
2413 if (ar->type != AR_ELEMENT)
2415 gfc_conv_scalarized_array_ref (se, ar);
2416 gfc_advance_se_ss_chain (se);
2420 index = gfc_index_zero_node;
2422 /* Calculate the offsets from all the dimensions. */
2423 for (n = 0; n < ar->dimen; n++)
2425 /* Calculate the index for this dimension. */
2426 gfc_init_se (&indexse, se);
2427 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2428 gfc_add_block_to_block (&se->pre, &indexse.pre);
2430 if (flag_bounds_check)
2432 /* Check array bounds. */
2436 /* Evaluate the indexse.expr only once. */
2437 indexse.expr = save_expr (indexse.expr);
2440 tmp = gfc_conv_array_lbound (se->expr, n);
2441 cond = fold_build2 (LT_EXPR, boolean_type_node,
2443 asprintf (&msg, "%s for array '%s', "
2444 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2445 gfc_msg_fault, sym->name, n+1);
2446 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2447 fold_convert (long_integer_type_node,
2449 fold_convert (long_integer_type_node, tmp));
2452 /* Upper bound, but not for the last dimension of assumed-size
2454 if (n < ar->dimen - 1
2455 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2457 tmp = gfc_conv_array_ubound (se->expr, n);
2458 cond = fold_build2 (GT_EXPR, boolean_type_node,
2460 asprintf (&msg, "%s for array '%s', "
2461 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2462 gfc_msg_fault, sym->name, n+1);
2463 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2464 fold_convert (long_integer_type_node,
2466 fold_convert (long_integer_type_node, tmp));
2471 /* Multiply the index by the stride. */
2472 stride = gfc_conv_array_stride (se->expr, n);
2473 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2476 /* And add it to the total. */
2477 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2480 tmp = gfc_conv_array_offset (se->expr);
2481 if (!integer_zerop (tmp))
2482 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2484 /* Access the calculated element. */
2485 tmp = gfc_conv_array_data (se->expr);
2486 tmp = build_fold_indirect_ref (tmp);
2487 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2491 /* Generate the code to be executed immediately before entering a
2492 scalarization loop. */
2495 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2496 stmtblock_t * pblock)
2505 /* This code will be executed before entering the scalarization loop
2506 for this dimension. */
2507 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2509 if ((ss->useflags & flag) == 0)
2512 if (ss->type != GFC_SS_SECTION
2513 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2514 && ss->type != GFC_SS_COMPONENT)
2517 info = &ss->data.info;
2519 if (dim >= info->dimen)
2522 if (dim == info->dimen - 1)
2524 /* For the outermost loop calculate the offset due to any
2525 elemental dimensions. It will have been initialized with the
2526 base offset of the array. */
2529 for (i = 0; i < info->ref->u.ar.dimen; i++)
2531 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2534 gfc_init_se (&se, NULL);
2536 se.expr = info->descriptor;
2537 stride = gfc_conv_array_stride (info->descriptor, i);
2538 index = gfc_conv_array_index_offset (&se, info, i, -1,
2541 gfc_add_block_to_block (pblock, &se.pre);
2543 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2544 info->offset, index);
2545 info->offset = gfc_evaluate_now (info->offset, pblock);
2549 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2552 stride = gfc_conv_array_stride (info->descriptor, 0);
2554 /* Calculate the stride of the innermost loop. Hopefully this will
2555 allow the backend optimizers to do their stuff more effectively.
2557 info->stride0 = gfc_evaluate_now (stride, pblock);
2561 /* Add the offset for the previous loop dimension. */
2566 ar = &info->ref->u.ar;
2567 i = loop->order[dim + 1];
2575 gfc_init_se (&se, NULL);
2577 se.expr = info->descriptor;
2578 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2579 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2581 gfc_add_block_to_block (pblock, &se.pre);
2582 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2583 info->offset, index);
2584 info->offset = gfc_evaluate_now (info->offset, pblock);
2587 /* Remember this offset for the second loop. */
2588 if (dim == loop->temp_dim - 1)
2589 info->saved_offset = info->offset;
2594 /* Start a scalarized expression. Creates a scope and declares loop
2598 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2604 gcc_assert (!loop->array_parameter);
2606 for (dim = loop->dimen - 1; dim >= 0; dim--)
2608 n = loop->order[dim];
2610 gfc_start_block (&loop->code[n]);
2612 /* Create the loop variable. */
2613 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2615 if (dim < loop->temp_dim)
2619 /* Calculate values that will be constant within this loop. */
2620 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2622 gfc_start_block (pbody);
2626 /* Generates the actual loop code for a scalarization loop. */
2629 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2630 stmtblock_t * pbody)
2638 loopbody = gfc_finish_block (pbody);
2640 /* Initialize the loopvar. */
2641 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2643 exit_label = gfc_build_label_decl (NULL_TREE);
2645 /* Generate the loop body. */
2646 gfc_init_block (&block);
2648 /* The exit condition. */
2649 cond = fold_build2 (GT_EXPR, boolean_type_node,
2650 loop->loopvar[n], loop->to[n]);
2651 tmp = build1_v (GOTO_EXPR, exit_label);
2652 TREE_USED (exit_label) = 1;
2653 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2654 gfc_add_expr_to_block (&block, tmp);
2656 /* The main body. */
2657 gfc_add_expr_to_block (&block, loopbody);
2659 /* Increment the loopvar. */
2660 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2661 loop->loopvar[n], gfc_index_one_node);
2662 gfc_add_modify (&block, loop->loopvar[n], tmp);
2664 /* Build the loop. */
2665 tmp = gfc_finish_block (&block);
2666 tmp = build1_v (LOOP_EXPR, tmp);
2667 gfc_add_expr_to_block (&loop->code[n], tmp);
2669 /* Add the exit label. */
2670 tmp = build1_v (LABEL_EXPR, exit_label);
2671 gfc_add_expr_to_block (&loop->code[n], tmp);
2675 /* Finishes and generates the loops for a scalarized expression. */
2678 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2683 stmtblock_t *pblock;
2687 /* Generate the loops. */
2688 for (dim = 0; dim < loop->dimen; dim++)
2690 n = loop->order[dim];
2691 gfc_trans_scalarized_loop_end (loop, n, pblock);
2692 loop->loopvar[n] = NULL_TREE;
2693 pblock = &loop->code[n];
2696 tmp = gfc_finish_block (pblock);
2697 gfc_add_expr_to_block (&loop->pre, tmp);
2699 /* Clear all the used flags. */
2700 for (ss = loop->ss; ss; ss = ss->loop_chain)
2705 /* Finish the main body of a scalarized expression, and start the secondary
2709 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2713 stmtblock_t *pblock;
2717 /* We finish as many loops as are used by the temporary. */
2718 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2720 n = loop->order[dim];
2721 gfc_trans_scalarized_loop_end (loop, n, pblock);
2722 loop->loopvar[n] = NULL_TREE;
2723 pblock = &loop->code[n];
2726 /* We don't want to finish the outermost loop entirely. */
2727 n = loop->order[loop->temp_dim - 1];
2728 gfc_trans_scalarized_loop_end (loop, n, pblock);
2730 /* Restore the initial offsets. */
2731 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2733 if ((ss->useflags & 2) == 0)
2736 if (ss->type != GFC_SS_SECTION
2737 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2738 && ss->type != GFC_SS_COMPONENT)
2741 ss->data.info.offset = ss->data.info.saved_offset;
2744 /* Restart all the inner loops we just finished. */
2745 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2747 n = loop->order[dim];
2749 gfc_start_block (&loop->code[n]);
2751 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2753 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2756 /* Start a block for the secondary copying code. */
2757 gfc_start_block (body);
2761 /* Calculate the upper bound of an array section. */
2764 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2773 gcc_assert (ss->type == GFC_SS_SECTION);
2775 info = &ss->data.info;
2778 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2779 /* We'll calculate the upper bound once we have access to the
2780 vector's descriptor. */
2783 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2784 desc = info->descriptor;
2785 end = info->ref->u.ar.end[dim];
2789 /* The upper bound was specified. */
2790 gfc_init_se (&se, NULL);
2791 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2792 gfc_add_block_to_block (pblock, &se.pre);
2797 /* No upper bound was specified, so use the bound of the array. */
2798 bound = gfc_conv_array_ubound (desc, dim);
2805 /* Calculate the lower bound of an array section. */
2808 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2818 gcc_assert (ss->type == GFC_SS_SECTION);
2820 info = &ss->data.info;
2823 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2825 /* We use a zero-based index to access the vector. */
2826 info->start[n] = gfc_index_zero_node;
2827 info->end[n] = gfc_index_zero_node;
2828 info->stride[n] = gfc_index_one_node;
2832 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2833 desc = info->descriptor;
2834 start = info->ref->u.ar.start[dim];
2835 end = info->ref->u.ar.end[dim];
2836 stride = info->ref->u.ar.stride[dim];
2838 /* Calculate the start of the range. For vector subscripts this will
2839 be the range of the vector. */
2842 /* Specified section start. */
2843 gfc_init_se (&se, NULL);
2844 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2845 gfc_add_block_to_block (&loop->pre, &se.pre);
2846 info->start[n] = se.expr;
2850 /* No lower bound specified so use the bound of the array. */
2851 info->start[n] = gfc_conv_array_lbound (desc, dim);
2853 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2855 /* Similarly calculate the end. Although this is not used in the
2856 scalarizer, it is needed when checking bounds and where the end
2857 is an expression with side-effects. */
2860 /* Specified section start. */
2861 gfc_init_se (&se, NULL);
2862 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2863 gfc_add_block_to_block (&loop->pre, &se.pre);
2864 info->end[n] = se.expr;
2868 /* No upper bound specified so use the bound of the array. */
2869 info->end[n] = gfc_conv_array_ubound (desc, dim);
2871 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2873 /* Calculate the stride. */
2875 info->stride[n] = gfc_index_one_node;
2878 gfc_init_se (&se, NULL);
2879 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2880 gfc_add_block_to_block (&loop->pre, &se.pre);
2881 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2886 /* Calculates the range start and stride for a SS chain. Also gets the
2887 descriptor and data pointer. The range of vector subscripts is the size
2888 of the vector. Array bounds are also checked. */
2891 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2899 /* Determine the rank of the loop. */
2901 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2905 case GFC_SS_SECTION:
2906 case GFC_SS_CONSTRUCTOR:
2907 case GFC_SS_FUNCTION:
2908 case GFC_SS_COMPONENT:
2909 loop->dimen = ss->data.info.dimen;
2912 /* As usual, lbound and ubound are exceptions!. */
2913 case GFC_SS_INTRINSIC:
2914 switch (ss->expr->value.function.isym->id)
2916 case GFC_ISYM_LBOUND:
2917 case GFC_ISYM_UBOUND:
2918 loop->dimen = ss->data.info.dimen;
2929 /* We should have determined the rank of the expression by now. If
2930 not, that's bad news. */
2931 gcc_assert (loop->dimen != 0);
2933 /* Loop over all the SS in the chain. */
2934 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2936 if (ss->expr && ss->expr->shape && !ss->shape)
2937 ss->shape = ss->expr->shape;
2941 case GFC_SS_SECTION:
2942 /* Get the descriptor for the array. */
2943 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2945 for (n = 0; n < ss->data.info.dimen; n++)
2946 gfc_conv_section_startstride (loop, ss, n);
2949 case GFC_SS_INTRINSIC:
2950 switch (ss->expr->value.function.isym->id)
2952 /* Fall through to supply start and stride. */
2953 case GFC_ISYM_LBOUND:
2954 case GFC_ISYM_UBOUND:
2960 case GFC_SS_CONSTRUCTOR:
2961 case GFC_SS_FUNCTION:
2962 for (n = 0; n < ss->data.info.dimen; n++)
2964 ss->data.info.start[n] = gfc_index_zero_node;
2965 ss->data.info.end[n] = gfc_index_zero_node;
2966 ss->data.info.stride[n] = gfc_index_one_node;
2975 /* The rest is just runtime bound checking. */
2976 if (flag_bounds_check)
2979 tree lbound, ubound;
2981 tree size[GFC_MAX_DIMENSIONS];
2982 tree stride_pos, stride_neg, non_zerosized, tmp2;
2987 gfc_start_block (&block);
2989 for (n = 0; n < loop->dimen; n++)
2990 size[n] = NULL_TREE;
2992 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2996 if (ss->type != GFC_SS_SECTION)
2999 gfc_start_block (&inner);
3001 /* TODO: range checking for mapped dimensions. */
3002 info = &ss->data.info;
3004 /* This code only checks ranges. Elemental and vector
3005 dimensions are checked later. */
3006 for (n = 0; n < loop->dimen; n++)
3011 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3014 if (dim == info->ref->u.ar.dimen - 1
3015 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3016 || info->ref->u.ar.as->cp_was_assumed))
3017 check_upper = false;
3021 /* Zero stride is not allowed. */
3022 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3023 gfc_index_zero_node);
3024 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3025 "of array '%s'", info->dim[n]+1,
3026 ss->expr->symtree->name);
3027 gfc_trans_runtime_check (true, false, tmp, &inner,
3028 &ss->expr->where, msg);
3031 desc = ss->data.info.descriptor;
3033 /* This is the run-time equivalent of resolve.c's
3034 check_dimension(). The logical is more readable there
3035 than it is here, with all the trees. */
3036 lbound = gfc_conv_array_lbound (desc, dim);
3039 ubound = gfc_conv_array_ubound (desc, dim);
3043 /* non_zerosized is true when the selected range is not
3045 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3046 info->stride[n], gfc_index_zero_node);
3047 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3049 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3052 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3053 info->stride[n], gfc_index_zero_node);
3054 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3056 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3058 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3059 stride_pos, stride_neg);
3061 /* Check the start of the range against the lower and upper
3062 bounds of the array, if the range is not empty. */
3063 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3065 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3066 non_zerosized, tmp);
3067 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3068 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3069 info->dim[n]+1, ss->expr->symtree->name);
3070 gfc_trans_runtime_check (true, false, tmp, &inner,
3071 &ss->expr->where, msg,
3072 fold_convert (long_integer_type_node,
3074 fold_convert (long_integer_type_node,
3080 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3081 info->start[n], ubound);
3082 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3083 non_zerosized, tmp);
3084 asprintf (&msg, "%s, upper bound of dimension %d of array "
3085 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3086 info->dim[n]+1, ss->expr->symtree->name);
3087 gfc_trans_runtime_check (true, false, tmp, &inner,
3088 &ss->expr->where, msg,
3089 fold_convert (long_integer_type_node, info->start[n]),
3090 fold_convert (long_integer_type_node, ubound));
3094 /* Compute the last element of the range, which is not
3095 necessarily "end" (think 0:5:3, which doesn't contain 5)
3096 and check it against both lower and upper bounds. */
3097 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3099 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3101 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3104 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3105 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3106 non_zerosized, tmp);
3107 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3108 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3109 info->dim[n]+1, ss->expr->symtree->name);
3110 gfc_trans_runtime_check (true, false, tmp, &inner,
3111 &ss->expr->where, msg,
3112 fold_convert (long_integer_type_node,
3114 fold_convert (long_integer_type_node,
3120 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3121 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3122 non_zerosized, tmp);
3123 asprintf (&msg, "%s, upper bound of dimension %d of array "
3124 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3125 info->dim[n]+1, ss->expr->symtree->name);
3126 gfc_trans_runtime_check (true, false, tmp, &inner,
3127 &ss->expr->where, msg,
3128 fold_convert (long_integer_type_node, tmp2),
3129 fold_convert (long_integer_type_node, ubound));
3133 /* Check the section sizes match. */
3134 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3136 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3138 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3139 build_int_cst (gfc_array_index_type, 0));
3140 /* We remember the size of the first section, and check all the
3141 others against this. */
3146 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3147 asprintf (&msg, "%s, size mismatch for dimension %d "
3148 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3149 info->dim[n]+1, ss->expr->symtree->name);
3150 gfc_trans_runtime_check (true, false, tmp3, &inner,
3151 &ss->expr->where, msg,
3152 fold_convert (long_integer_type_node, tmp),
3153 fold_convert (long_integer_type_node, size[n]));
3157 size[n] = gfc_evaluate_now (tmp, &inner);
3160 tmp = gfc_finish_block (&inner);
3162 /* For optional arguments, only check bounds if the argument is
3164 if (ss->expr->symtree->n.sym->attr.optional
3165 || ss->expr->symtree->n.sym->attr.not_always_present)
3166 tmp = build3_v (COND_EXPR,
3167 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3168 tmp, build_empty_stmt ());
3170 gfc_add_expr_to_block (&block, tmp);
3174 tmp = gfc_finish_block (&block);
3175 gfc_add_expr_to_block (&loop->pre, tmp);
3180 /* Return true if the two SS could be aliased, i.e. both point to the same data
3182 /* TODO: resolve aliases based on frontend expressions. */
3185 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3192 lsym = lss->expr->symtree->n.sym;
3193 rsym = rss->expr->symtree->n.sym;
3194 if (gfc_symbols_could_alias (lsym, rsym))
3197 if (rsym->ts.type != BT_DERIVED
3198 && lsym->ts.type != BT_DERIVED)
3201 /* For derived types we must check all the component types. We can ignore
3202 array references as these will have the same base type as the previous
3204 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3206 if (lref->type != REF_COMPONENT)
3209 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3212 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3215 if (rref->type != REF_COMPONENT)
3218 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3223 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3225 if (rref->type != REF_COMPONENT)
3228 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3236 /* Resolve array data dependencies. Creates a temporary if required. */
3237 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3241 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3251 loop->temp_ss = NULL;
3252 aref = dest->data.info.ref;
3255 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3257 if (ss->type != GFC_SS_SECTION)
3260 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3262 if (gfc_could_be_alias (dest, ss)
3263 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3271 lref = dest->expr->ref;
3272 rref = ss->expr->ref;
3274 nDepend = gfc_dep_resolver (lref, rref);
3278 /* TODO : loop shifting. */
3281 /* Mark the dimensions for LOOP SHIFTING */
3282 for (n = 0; n < loop->dimen; n++)
3284 int dim = dest->data.info.dim[n];
3286 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3288 else if (! gfc_is_same_range (&lref->u.ar,
3289 &rref->u.ar, dim, 0))
3293 /* Put all the dimensions with dependencies in the
3296 for (n = 0; n < loop->dimen; n++)
3298 gcc_assert (loop->order[n] == n);
3300 loop->order[dim++] = n;
3303 for (n = 0; n < loop->dimen; n++)
3306 loop->order[dim++] = n;
3309 gcc_assert (dim == loop->dimen);
3318 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3319 if (GFC_ARRAY_TYPE_P (base_type)
3320 || GFC_DESCRIPTOR_TYPE_P (base_type))
3321 base_type = gfc_get_element_type (base_type);
3322 loop->temp_ss = gfc_get_ss ();
3323 loop->temp_ss->type = GFC_SS_TEMP;
3324 loop->temp_ss->data.temp.type = base_type;
3325 loop->temp_ss->string_length = dest->string_length;
3326 loop->temp_ss->data.temp.dimen = loop->dimen;
3327 loop->temp_ss->next = gfc_ss_terminator;
3328 gfc_add_ss_to_loop (loop, loop->temp_ss);
3331 loop->temp_ss = NULL;
3335 /* Initialize the scalarization loop. Creates the loop variables. Determines
3336 the range of the loop variables. Creates a temporary if required.
3337 Calculates how to transform from loop variables to array indices for each
3338 expression. Also generates code for scalar expressions which have been
3339 moved outside the loop. */
3342 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3347 gfc_ss_info *specinfo;
3351 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3352 bool dynamic[GFC_MAX_DIMENSIONS];
3358 for (n = 0; n < loop->dimen; n++)
3362 /* We use one SS term, and use that to determine the bounds of the
3363 loop for this dimension. We try to pick the simplest term. */
3364 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3368 /* The frontend has worked out the size for us. */
3373 if (ss->type == GFC_SS_CONSTRUCTOR)
3375 /* An unknown size constructor will always be rank one.
3376 Higher rank constructors will either have known shape,
3377 or still be wrapped in a call to reshape. */
3378 gcc_assert (loop->dimen == 1);
3380 /* Always prefer to use the constructor bounds if the size
3381 can be determined at compile time. Prefer not to otherwise,
3382 since the general case involves realloc, and it's better to
3383 avoid that overhead if possible. */
3384 c = ss->expr->value.constructor;
3385 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3386 if (!dynamic[n] || !loopspec[n])
3391 /* TODO: Pick the best bound if we have a choice between a
3392 function and something else. */
3393 if (ss->type == GFC_SS_FUNCTION)
3399 if (ss->type != GFC_SS_SECTION)
3403 specinfo = &loopspec[n]->data.info;
3406 info = &ss->data.info;
3410 /* Criteria for choosing a loop specifier (most important first):
3411 doesn't need realloc
3417 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3419 else if (integer_onep (info->stride[n])
3420 && !integer_onep (specinfo->stride[n]))
3422 else if (INTEGER_CST_P (info->stride[n])
3423 && !INTEGER_CST_P (specinfo->stride[n]))
3425 else if (INTEGER_CST_P (info->start[n])
3426 && !INTEGER_CST_P (specinfo->start[n]))
3428 /* We don't work out the upper bound.
3429 else if (INTEGER_CST_P (info->finish[n])
3430 && ! INTEGER_CST_P (specinfo->finish[n]))
3431 loopspec[n] = ss; */
3434 /* We should have found the scalarization loop specifier. If not,
3436 gcc_assert (loopspec[n]);
3438 info = &loopspec[n]->data.info;
3440 /* Set the extents of this range. */
3441 cshape = loopspec[n]->shape;
3442 if (cshape && INTEGER_CST_P (info->start[n])
3443 && INTEGER_CST_P (info->stride[n]))
3445 loop->from[n] = info->start[n];
3446 mpz_set (i, cshape[n]);
3447 mpz_sub_ui (i, i, 1);
3448 /* To = from + (size - 1) * stride. */
3449 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3450 if (!integer_onep (info->stride[n]))
3451 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3452 tmp, info->stride[n]);
3453 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3454 loop->from[n], tmp);
3458 loop->from[n] = info->start[n];
3459 switch (loopspec[n]->type)
3461 case GFC_SS_CONSTRUCTOR:
3462 /* The upper bound is calculated when we expand the
3464 gcc_assert (loop->to[n] == NULL_TREE);
3467 case GFC_SS_SECTION:
3468 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3472 case GFC_SS_FUNCTION:
3473 /* The loop bound will be set when we generate the call. */
3474 gcc_assert (loop->to[n] == NULL_TREE);
3482 /* Transform everything so we have a simple incrementing variable. */
3483 if (integer_onep (info->stride[n]))
3484 info->delta[n] = gfc_index_zero_node;
3487 /* Set the delta for this section. */
3488 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3489 /* Number of iterations is (end - start + step) / step.
3490 with start = 0, this simplifies to
3492 for (i = 0; i<=last; i++){...}; */
3493 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3494 loop->to[n], loop->from[n]);
3495 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3496 tmp, info->stride[n]);
3497 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3498 build_int_cst (gfc_array_index_type, -1));
3499 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3500 /* Make the loop variable start at 0. */
3501 loop->from[n] = gfc_index_zero_node;
3505 /* Add all the scalar code that can be taken out of the loops.
3506 This may include calculating the loop bounds, so do it before
3507 allocating the temporary. */
3508 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3510 /* If we want a temporary then create it. */
3511 if (loop->temp_ss != NULL)
3513 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3515 /* Make absolutely sure that this is a complete type. */
3516 if (loop->temp_ss->string_length)
3517 loop->temp_ss->data.temp.type
3518 = gfc_get_character_type_len_for_eltype
3519 (TREE_TYPE (loop->temp_ss->data.temp.type),
3520 loop->temp_ss->string_length);
3522 tmp = loop->temp_ss->data.temp.type;
3523 len = loop->temp_ss->string_length;
3524 n = loop->temp_ss->data.temp.dimen;
3525 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3526 loop->temp_ss->type = GFC_SS_SECTION;
3527 loop->temp_ss->data.info.dimen = n;
3528 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3529 &loop->temp_ss->data.info, tmp, false, true,
3533 for (n = 0; n < loop->temp_dim; n++)
3534 loopspec[loop->order[n]] = NULL;
3538 /* For array parameters we don't have loop variables, so don't calculate the
3540 if (loop->array_parameter)
3543 /* Calculate the translation from loop variables to array indices. */
3544 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3546 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3549 info = &ss->data.info;
3551 for (n = 0; n < info->dimen; n++)
3555 /* If we are specifying the range the delta is already set. */
3556 if (loopspec[n] != ss)
3558 /* Calculate the offset relative to the loop variable.
3559 First multiply by the stride. */
3560 tmp = loop->from[n];
3561 if (!integer_onep (info->stride[n]))
3562 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3563 tmp, info->stride[n]);
3565 /* Then subtract this from our starting value. */
3566 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3567 info->start[n], tmp);
3569 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3576 /* Fills in an array descriptor, and returns the size of the array. The size
3577 will be a simple_val, ie a variable or a constant. Also calculates the
3578 offset of the base. Returns the size of the array.
3582 for (n = 0; n < rank; n++)
3584 a.lbound[n] = specified_lower_bound;
3585 offset = offset + a.lbond[n] * stride;
3587 a.ubound[n] = specified_upper_bound;
3588 a.stride[n] = stride;
3589 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3590 stride = stride * size;
3597 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3598 gfc_expr ** lower, gfc_expr ** upper,
3599 stmtblock_t * pblock)
3611 stmtblock_t thenblock;
3612 stmtblock_t elseblock;
3617 type = TREE_TYPE (descriptor);
3619 stride = gfc_index_one_node;
3620 offset = gfc_index_zero_node;
3622 /* Set the dtype. */
3623 tmp = gfc_conv_descriptor_dtype (descriptor);
3624 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3626 or_expr = NULL_TREE;
3628 for (n = 0; n < rank; n++)
3630 /* We have 3 possibilities for determining the size of the array:
3631 lower == NULL => lbound = 1, ubound = upper[n]
3632 upper[n] = NULL => lbound = 1, ubound = lower[n]
3633 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3636 /* Set lower bound. */
3637 gfc_init_se (&se, NULL);
3639 se.expr = gfc_index_one_node;
3642 gcc_assert (lower[n]);
3645 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3646 gfc_add_block_to_block (pblock, &se.pre);
3650 se.expr = gfc_index_one_node;
3654 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3655 gfc_add_modify (pblock, tmp, se.expr);
3657 /* Work out the offset for this component. */
3658 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3659 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3661 /* Start the calculation for the size of this dimension. */
3662 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3663 gfc_index_one_node, se.expr);
3665 /* Set upper bound. */
3666 gfc_init_se (&se, NULL);
3667 gcc_assert (ubound);
3668 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3669 gfc_add_block_to_block (pblock, &se.pre);
3671 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3672 gfc_add_modify (pblock, tmp, se.expr);
3674 /* Store the stride. */
3675 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3676 gfc_add_modify (pblock, tmp, stride);
3678 /* Calculate the size of this dimension. */
3679 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3681 /* Check whether the size for this dimension is negative. */
3682 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3683 gfc_index_zero_node);
3687 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3689 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3690 gfc_index_zero_node, size);
3692 /* Multiply the stride by the number of elements in this dimension. */
3693 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3694 stride = gfc_evaluate_now (stride, pblock);
3697 /* The stride is the number of elements in the array, so multiply by the
3698 size of an element to get the total size. */
3699 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3700 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3701 fold_convert (gfc_array_index_type, tmp));
3703 if (poffset != NULL)
3705 offset = gfc_evaluate_now (offset, pblock);
3709 if (integer_zerop (or_expr))
3711 if (integer_onep (or_expr))
3712 return gfc_index_zero_node;
3714 var = gfc_create_var (TREE_TYPE (size), "size");
3715 gfc_start_block (&thenblock);
3716 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3717 thencase = gfc_finish_block (&thenblock);
3719 gfc_start_block (&elseblock);
3720 gfc_add_modify (&elseblock, var, size);
3721 elsecase = gfc_finish_block (&elseblock);
3723 tmp = gfc_evaluate_now (or_expr, pblock);
3724 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3725 gfc_add_expr_to_block (pblock, tmp);
3731 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3732 the work for an ALLOCATE statement. */
3736 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3744 gfc_ref *ref, *prev_ref = NULL;
3745 bool allocatable_array;
3749 /* Find the last reference in the chain. */
3750 while (ref && ref->next != NULL)
3752 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3757 if (ref == NULL || ref->type != REF_ARRAY)
3761 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3763 allocatable_array = prev_ref->u.c.component->allocatable;
3765 /* Figure out the size of the array. */
3766 switch (ref->u.ar.type)
3770 upper = ref->u.ar.start;
3774 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3776 lower = ref->u.ar.as->lower;
3777 upper = ref->u.ar.as->upper;
3781 lower = ref->u.ar.start;
3782 upper = ref->u.ar.end;
3790 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3791 lower, upper, &se->pre);
3793 /* Allocate memory to store the data. */
3794 pointer = gfc_conv_descriptor_data_get (se->expr);
3795 STRIP_NOPS (pointer);
3797 /* The allocate_array variants take the old pointer as first argument. */
3798 if (allocatable_array)
3799 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
3801 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3802 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3803 gfc_add_expr_to_block (&se->pre, tmp);
3805 tmp = gfc_conv_descriptor_offset (se->expr);
3806 gfc_add_modify (&se->pre, tmp, offset);
3808 if (expr->ts.type == BT_DERIVED
3809 && expr->ts.derived->attr.alloc_comp)
3811 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3812 ref->u.ar.as->rank);
3813 gfc_add_expr_to_block (&se->pre, tmp);
3820 /* Deallocate an array variable. Also used when an allocated variable goes
3825 gfc_array_deallocate (tree descriptor, tree pstat)
3831 gfc_start_block (&block);
3832 /* Get a pointer to the data. */
3833 var = gfc_conv_descriptor_data_get (descriptor);
3836 /* Parameter is the address of the data component. */
3837 tmp = gfc_deallocate_with_status (var, pstat, false);
3838 gfc_add_expr_to_block (&block, tmp);
3840 /* Zero the data pointer. */
3841 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3842 var, build_int_cst (TREE_TYPE (var), 0));
3843 gfc_add_expr_to_block (&block, tmp);
3845 return gfc_finish_block (&block);
3849 /* Create an array constructor from an initialization expression.
3850 We assume the frontend already did any expansions and conversions. */
3853 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3860 unsigned HOST_WIDE_INT lo;
3862 VEC(constructor_elt,gc) *v = NULL;
3864 switch (expr->expr_type)
3867 case EXPR_STRUCTURE:
3868 /* A single scalar or derived type value. Create an array with all
3869 elements equal to that value. */
3870 gfc_init_se (&se, NULL);
3872 if (expr->expr_type == EXPR_CONSTANT)
3873 gfc_conv_constant (&se, expr);
3875 gfc_conv_structure (&se, expr, 1);
3877 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3878 gcc_assert (tmp && INTEGER_CST_P (tmp));
3879 hi = TREE_INT_CST_HIGH (tmp);
3880 lo = TREE_INT_CST_LOW (tmp);
3884 /* This will probably eat buckets of memory for large arrays. */
3885 while (hi != 0 || lo != 0)
3887 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3895 /* Create a vector of all the elements. */
3896 for (c = expr->value.constructor; c; c = c->next)
3900 /* Problems occur when we get something like
3901 integer :: a(lots) = (/(i, i=1,lots)/) */
3902 /* TODO: Unexpanded array initializers. */
3904 ("Possible frontend bug: array constructor not expanded");
3906 if (mpz_cmp_si (c->n.offset, 0) != 0)
3907 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3911 if (mpz_cmp_si (c->repeat, 0) != 0)
3915 mpz_set (maxval, c->repeat);
3916 mpz_add (maxval, c->n.offset, maxval);
3917 mpz_sub_ui (maxval, maxval, 1);
3918 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3919 if (mpz_cmp_si (c->n.offset, 0) != 0)
3921 mpz_add_ui (maxval, c->n.offset, 1);
3922 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3925 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3927 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3933 gfc_init_se (&se, NULL);
3934 switch (c->expr->expr_type)
3937 gfc_conv_constant (&se, c->expr);
3938 if (range == NULL_TREE)
3939 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3942 if (index != NULL_TREE)
3943 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3944 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3948 case EXPR_STRUCTURE:
3949 gfc_conv_structure (&se, c->expr, 1);
3950 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3960 return gfc_build_null_descriptor (type);
3966 /* Create a constructor from the list of elements. */
3967 tmp = build_constructor (type, v);
3968 TREE_CONSTANT (tmp) = 1;
3973 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3974 returns the size (in elements) of the array. */
3977 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3978 stmtblock_t * pblock)
3993 size = gfc_index_one_node;
3994 offset = gfc_index_zero_node;
3995 for (dim = 0; dim < as->rank; dim++)
3997 /* Evaluate non-constant array bound expressions. */
3998 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3999 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4001 gfc_init_se (&se, NULL);
4002 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4003 gfc_add_block_to_block (pblock, &se.pre);
4004 gfc_add_modify (pblock, lbound, se.expr);
4006 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4007 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4009 gfc_init_se (&se, NULL);
4010 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4011 gfc_add_block_to_block (pblock, &se.pre);
4012 gfc_add_modify (pblock, ubound, se.expr);
4014 /* The offset of this dimension. offset = offset - lbound * stride. */
4015 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4016 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4018 /* The size of this dimension, and the stride of the next. */
4019 if (dim + 1 < as->rank)
4020 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4022 stride = GFC_TYPE_ARRAY_SIZE (type);
4024 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4026 /* Calculate stride = size * (ubound + 1 - lbound). */
4027 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4028 gfc_index_one_node, lbound);
4029 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4030 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4032 gfc_add_modify (pblock, stride, tmp);
4034 stride = gfc_evaluate_now (tmp, pblock);
4036 /* Make sure that negative size arrays are translated
4037 to being zero size. */
4038 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4039 stride, gfc_index_zero_node);
4040 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4041 stride, gfc_index_zero_node);
4042 gfc_add_modify (pblock, stride, tmp);
4048 gfc_trans_vla_type_sizes (sym, pblock);
4055 /* Generate code to initialize/allocate an array variable. */
4058 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4067 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4069 /* Do nothing for USEd variables. */
4070 if (sym->attr.use_assoc)
4073 type = TREE_TYPE (decl);
4074 gcc_assert (GFC_ARRAY_TYPE_P (type));
4075 onstack = TREE_CODE (type) != POINTER_TYPE;
4077 gfc_start_block (&block);
4079 /* Evaluate character string length. */
4080 if (sym->ts.type == BT_CHARACTER
4081 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4083 gfc_conv_string_length (sym->ts.cl, &block);
4085 gfc_trans_vla_type_sizes (sym, &block);
4087 /* Emit a DECL_EXPR for this variable, which will cause the
4088 gimplifier to allocate storage, and all that good stuff. */
4089 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4090 gfc_add_expr_to_block (&block, tmp);
4095 gfc_add_expr_to_block (&block, fnbody);
4096 return gfc_finish_block (&block);
4099 type = TREE_TYPE (type);
4101 gcc_assert (!sym->attr.use_assoc);
4102 gcc_assert (!TREE_STATIC (decl));
4103 gcc_assert (!sym->module);
4105 if (sym->ts.type == BT_CHARACTER
4106 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4107 gfc_conv_string_length (sym->ts.cl, &block);
4109 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4111 /* Don't actually allocate space for Cray Pointees. */
4112 if (sym->attr.cray_pointee)
4114 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4115 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4116 gfc_add_expr_to_block (&block, fnbody);
4117 return gfc_finish_block (&block);
4120 /* The size is the number of elements in the array, so multiply by the
4121 size of an element to get the total size. */
4122 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4123 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4124 fold_convert (gfc_array_index_type, tmp));
4126 /* Allocate memory to hold the data. */
4127 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4128 gfc_add_modify (&block, decl, tmp);
4130 /* Set offset of the array. */
4131 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4132 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4135 /* Automatic arrays should not have initializers. */
4136 gcc_assert (!sym->value);
4138 gfc_add_expr_to_block (&block, fnbody);
4140 /* Free the temporary. */
4141 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4142 gfc_add_expr_to_block (&block, tmp);
4144 return gfc_finish_block (&block);
4148 /* Generate entry and exit code for g77 calling convention arrays. */
4151 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4161 gfc_get_backend_locus (&loc);
4162 gfc_set_backend_locus (&sym->declared_at);
4164 /* Descriptor type. */
4165 parm = sym->backend_decl;
4166 type = TREE_TYPE (parm);
4167 gcc_assert (GFC_ARRAY_TYPE_P (type));
4169 gfc_start_block (&block);
4171 if (sym->ts.type == BT_CHARACTER
4172 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4173 gfc_conv_string_length (sym->ts.cl, &block);
4175 /* Evaluate the bounds of the array. */
4176 gfc_trans_array_bounds (type, sym, &offset, &block);
4178 /* Set the offset. */
4179 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4180 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4182 /* Set the pointer itself if we aren't using the parameter directly. */
4183 if (TREE_CODE (parm) != PARM_DECL)
4185 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4186 gfc_add_modify (&block, parm, tmp);
4188 stmt = gfc_finish_block (&block);
4190 gfc_set_backend_locus (&loc);
4192 gfc_start_block (&block);
4194 /* Add the initialization code to the start of the function. */
4196 if (sym->attr.optional || sym->attr.not_always_present)
4198 tmp = gfc_conv_expr_present (sym);
4199 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4202 gfc_add_expr_to_block (&block, stmt);
4203 gfc_add_expr_to_block (&block, body);
4205 return gfc_finish_block (&block);
4209 /* Modify the descriptor of an array parameter so that it has the
4210 correct lower bound. Also move the upper bound accordingly.
4211 If the array is not packed, it will be copied into a temporary.
4212 For each dimension we set the new lower and upper bounds. Then we copy the
4213 stride and calculate the offset for this dimension. We also work out
4214 what the stride of a packed array would be, and see it the two match.
4215 If the array need repacking, we set the stride to the values we just
4216 calculated, recalculate the offset and copy the array data.
4217 Code is also added to copy the data back at the end of the function.
4221 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4228 stmtblock_t cleanup;
4236 tree stride, stride2;
4246 /* Do nothing for pointer and allocatable arrays. */
4247 if (sym->attr.pointer || sym->attr.allocatable)
4250 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4251 return gfc_trans_g77_array (sym, body);
4253 gfc_get_backend_locus (&loc);
4254 gfc_set_backend_locus (&sym->declared_at);
4256 /* Descriptor type. */
4257 type = TREE_TYPE (tmpdesc);
4258 gcc_assert (GFC_ARRAY_TYPE_P (type));
4259 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4260 dumdesc = build_fold_indirect_ref (dumdesc);
4261 gfc_start_block (&block);
4263 if (sym->ts.type == BT_CHARACTER
4264 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4265 gfc_conv_string_length (sym->ts.cl, &block);
4267 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4269 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4270 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4272 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4274 /* For non-constant shape arrays we only check if the first dimension
4275 is contiguous. Repacking higher dimensions wouldn't gain us
4276 anything as we still don't know the array stride. */
4277 partial = gfc_create_var (boolean_type_node, "partial");
4278 TREE_USED (partial) = 1;
4279 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4280 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4281 gfc_add_modify (&block, partial, tmp);
4285 partial = NULL_TREE;
4288 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4289 here, however I think it does the right thing. */
4292 /* Set the first stride. */
4293 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4294 stride = gfc_evaluate_now (stride, &block);
4296 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4297 stride, gfc_index_zero_node);
4298 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4299 gfc_index_one_node, stride);
4300 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4301 gfc_add_modify (&block, stride, tmp);
4303 /* Allow the user to disable array repacking. */
4304 stmt_unpacked = NULL_TREE;
4308 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4309 /* A library call to repack the array if necessary. */
4310 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4311 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4313 stride = gfc_index_one_node;
4315 if (gfc_option.warn_array_temp)
4316 gfc_warning ("Creating array temporary at %L", &loc);
4319 /* This is for the case where the array data is used directly without
4320 calling the repack function. */
4321 if (no_repack || partial != NULL_TREE)
4322 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4324 stmt_packed = NULL_TREE;
4326 /* Assign the data pointer. */
4327 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4329 /* Don't repack unknown shape arrays when the first stride is 1. */
4330 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4331 partial, stmt_packed, stmt_unpacked);
4334 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4335 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4337 offset = gfc_index_zero_node;
4338 size = gfc_index_one_node;
4340 /* Evaluate the bounds of the array. */
4341 for (n = 0; n < sym->as->rank; n++)
4343 if (checkparm || !sym->as->upper[n])
4345 /* Get the bounds of the actual parameter. */
4346 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4347 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4351 dubound = NULL_TREE;
4352 dlbound = NULL_TREE;
4355 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4356 if (!INTEGER_CST_P (lbound))
4358 gfc_init_se (&se, NULL);
4359 gfc_conv_expr_type (&se, sym->as->lower[n],
4360 gfc_array_index_type);
4361 gfc_add_block_to_block (&block, &se.pre);
4362 gfc_add_modify (&block, lbound, se.expr);
4365 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4366 /* Set the desired upper bound. */
4367 if (sym->as->upper[n])
4369 /* We know what we want the upper bound to be. */
4370 if (!INTEGER_CST_P (ubound))
4372 gfc_init_se (&se, NULL);
4373 gfc_conv_expr_type (&se, sym->as->upper[n],
4374 gfc_array_index_type);
4375 gfc_add_block_to_block (&block, &se.pre);
4376 gfc_add_modify (&block, ubound, se.expr);
4379 /* Check the sizes match. */
4382 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4385 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4387 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4389 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4390 asprintf (&msg, "%s for dimension %d of array '%s'",
4391 gfc_msg_bounds, n+1, sym->name);
4392 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4398 /* For assumed shape arrays move the upper bound by the same amount
4399 as the lower bound. */
4400 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4402 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4403 gfc_add_modify (&block, ubound, tmp);
4405 /* The offset of this dimension. offset = offset - lbound * stride. */
4406 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4407 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4409 /* The size of this dimension, and the stride of the next. */
4410 if (n + 1 < sym->as->rank)
4412 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4414 if (no_repack || partial != NULL_TREE)
4417 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4420 /* Figure out the stride if not a known constant. */
4421 if (!INTEGER_CST_P (stride))
4424 stmt_packed = NULL_TREE;
4427 /* Calculate stride = size * (ubound + 1 - lbound). */
4428 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4429 gfc_index_one_node, lbound);
4430 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4432 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4437 /* Assign the stride. */
4438 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4439 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4440 stmt_unpacked, stmt_packed);
4442 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4443 gfc_add_modify (&block, stride, tmp);
4448 stride = GFC_TYPE_ARRAY_SIZE (type);
4450 if (stride && !INTEGER_CST_P (stride))
4452 /* Calculate size = stride * (ubound + 1 - lbound). */
4453 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4454 gfc_index_one_node, lbound);
4455 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4457 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4458 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4459 gfc_add_modify (&block, stride, tmp);
4464 /* Set the offset. */
4465 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4466 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4468 gfc_trans_vla_type_sizes (sym, &block);
4470 stmt = gfc_finish_block (&block);
4472 gfc_start_block (&block);
4474 /* Only do the entry/initialization code if the arg is present. */
4475 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4476 optional_arg = (sym->attr.optional
4477 || (sym->ns->proc_name->attr.entry_master
4478 && sym->attr.dummy));
4481 tmp = gfc_conv_expr_present (sym);
4482 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4484 gfc_add_expr_to_block (&block, stmt);
4486 /* Add the main function body. */
4487 gfc_add_expr_to_block (&block, body);
4492 gfc_start_block (&cleanup);
4494 if (sym->attr.intent != INTENT_IN)
4496 /* Copy the data back. */
4497 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4498 gfc_add_expr_to_block (&cleanup, tmp);
4501 /* Free the temporary. */
4502 tmp = gfc_call_free (tmpdesc);
4503 gfc_add_expr_to_block (&cleanup, tmp);
4505 stmt = gfc_finish_block (&cleanup);
4507 /* Only do the cleanup if the array was repacked. */
4508 tmp = build_fold_indirect_ref (dumdesc);
4509 tmp = gfc_conv_descriptor_data_get (tmp);
4510 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4511 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4515 tmp = gfc_conv_expr_present (sym);
4516 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4518 gfc_add_expr_to_block (&block, stmt);
4520 /* We don't need to free any memory allocated by internal_pack as it will
4521 be freed at the end of the function by pop_context. */
4522 return gfc_finish_block (&block);
4526 /* Calculate the overall offset, including subreferences. */
4528 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4529 bool subref, gfc_expr *expr)
4539 /* If offset is NULL and this is not a subreferenced array, there is
4541 if (offset == NULL_TREE)
4544 offset = gfc_index_zero_node;
4549 tmp = gfc_conv_array_data (desc);
4550 tmp = build_fold_indirect_ref (tmp);
4551 tmp = gfc_build_array_ref (tmp, offset, NULL);
4553 /* Offset the data pointer for pointer assignments from arrays with
4554 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4557 /* Go past the array reference. */
4558 for (ref = expr->ref; ref; ref = ref->next)
4559 if (ref->type == REF_ARRAY &&
4560 ref->u.ar.type != AR_ELEMENT)
4566 /* Calculate the offset for each subsequent subreference. */
4567 for (; ref; ref = ref->next)
4572 field = ref->u.c.component->backend_decl;
4573 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4574 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4575 tmp, field, NULL_TREE);
4579 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4580 gfc_init_se (&start, NULL);
4581 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4582 gfc_add_block_to_block (block, &start.pre);
4583 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4587 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4588 && ref->u.ar.type == AR_ELEMENT);
4590 /* TODO - Add bounds checking. */
4591 stride = gfc_index_one_node;
4592 index = gfc_index_zero_node;
4593 for (n = 0; n < ref->u.ar.dimen; n++)
4598 /* Update the index. */
4599 gfc_init_se (&start, NULL);
4600 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4601 itmp = gfc_evaluate_now (start.expr, block);
4602 gfc_init_se (&start, NULL);
4603 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4604 jtmp = gfc_evaluate_now (start.expr, block);
4605 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4606 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4607 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4608 index = gfc_evaluate_now (index, block);
4610 /* Update the stride. */
4611 gfc_init_se (&start, NULL);
4612 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4613 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4614 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4615 gfc_index_one_node, itmp);
4616 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4617 stride = gfc_evaluate_now (stride, block);
4620 /* Apply the index to obtain the array element. */
4621 tmp = gfc_build_array_ref (tmp, index, NULL);
4631 /* Set the target data pointer. */
4632 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4633 gfc_conv_descriptor_data_set (block, parm, offset);
4637 /* gfc_conv_expr_descriptor needs the character length of elemental
4638 functions before the function is called so that the size of the
4639 temporary can be obtained. The only way to do this is to convert
4640 the expression, mapping onto the actual arguments. */
4642 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4644 gfc_interface_mapping mapping;
4645 gfc_formal_arglist *formal;
4646 gfc_actual_arglist *arg;
4649 formal = expr->symtree->n.sym->formal;
4650 arg = expr->value.function.actual;
4651 gfc_init_interface_mapping (&mapping);
4653 /* Set se = NULL in the calls to the interface mapping, to suppress any
4655 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4660 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4663 gfc_init_se (&tse, NULL);
4665 /* Build the expression for the character length and convert it. */
4666 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4668 gfc_add_block_to_block (&se->pre, &tse.pre);
4669 gfc_add_block_to_block (&se->post, &tse.post);
4670 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4671 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4672 build_int_cst (gfc_charlen_type_node, 0));
4673 expr->ts.cl->backend_decl = tse.expr;
4674 gfc_free_interface_mapping (&mapping);
4678 /* Convert an array for passing as an actual argument. Expressions and
4679 vector subscripts are evaluated and stored in a temporary, which is then
4680 passed. For whole arrays the descriptor is passed. For array sections
4681 a modified copy of the descriptor is passed, but using the original data.
4683 This function is also used for array pointer assignments, and there
4686 - se->want_pointer && !se->direct_byref
4687 EXPR is an actual argument. On exit, se->expr contains a
4688 pointer to the array descriptor.
4690 - !se->want_pointer && !se->direct_byref
4691 EXPR is an actual argument to an intrinsic function or the
4692 left-hand side of a pointer assignment. On exit, se->expr
4693 contains the descriptor for EXPR.
4695 - !se->want_pointer && se->direct_byref
4696 EXPR is the right-hand side of a pointer assignment and
4697 se->expr is the descriptor for the previously-evaluated
4698 left-hand side. The function creates an assignment from
4699 EXPR to se->expr. */
4702 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4715 bool subref_array_target = false;
4717 gcc_assert (ss != gfc_ss_terminator);
4719 /* Special case things we know we can pass easily. */
4720 switch (expr->expr_type)
4723 /* If we have a linear array section, we can pass it directly.
4724 Otherwise we need to copy it into a temporary. */
4726 /* Find the SS for the array section. */
4728 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4729 secss = secss->next;
4731 gcc_assert (secss != gfc_ss_terminator);
4732 info = &secss->data.info;
4734 /* Get the descriptor for the array. */
4735 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4736 desc = info->descriptor;
4738 subref_array_target = se->direct_byref && is_subref_array (expr);
4739 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4740 && !subref_array_target;
4744 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4746 /* Create a new descriptor if the array doesn't have one. */
4749 else if (info->ref->u.ar.type == AR_FULL)
4751 else if (se->direct_byref)
4754 full = gfc_full_array_ref_p (info->ref);
4758 if (se->direct_byref)
4760 /* Copy the descriptor for pointer assignments. */
4761 gfc_add_modify (&se->pre, se->expr, desc);
4763 /* Add any offsets from subreferences. */
4764 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4765 subref_array_target, expr);
4767 else if (se->want_pointer)
4769 /* We pass full arrays directly. This means that pointers and
4770 allocatable arrays should also work. */
4771 se->expr = build_fold_addr_expr (desc);
4778 if (expr->ts.type == BT_CHARACTER)
4779 se->string_length = gfc_get_expr_charlen (expr);
4786 /* A transformational function return value will be a temporary
4787 array descriptor. We still need to go through the scalarizer
4788 to create the descriptor. Elemental functions ar handled as
4789 arbitrary expressions, i.e. copy to a temporary. */
4791 /* Look for the SS for this function. */
4792 while (secss != gfc_ss_terminator
4793 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4794 secss = secss->next;
4796 if (se->direct_byref)
4798 gcc_assert (secss != gfc_ss_terminator);
4800 /* For pointer assignments pass the descriptor directly. */
4802 se->expr = build_fold_addr_expr (se->expr);
4803 gfc_conv_expr (se, expr);
4807 if (secss == gfc_ss_terminator)
4809 /* Elemental function. */
4811 if (expr->ts.type == BT_CHARACTER
4812 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4813 get_elemental_fcn_charlen (expr, se);
4819 /* Transformational function. */
4820 info = &secss->data.info;
4826 /* Constant array constructors don't need a temporary. */
4827 if (ss->type == GFC_SS_CONSTRUCTOR
4828 && expr->ts.type != BT_CHARACTER
4829 && gfc_constant_array_constructor_p (expr->value.constructor))
4832 info = &ss->data.info;
4844 /* Something complicated. Copy it into a temporary. */
4852 gfc_init_loopinfo (&loop);
4854 /* Associate the SS with the loop. */
4855 gfc_add_ss_to_loop (&loop, ss);
4857 /* Tell the scalarizer not to bother creating loop variables, etc. */
4859 loop.array_parameter = 1;
4861 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4862 gcc_assert (!se->direct_byref);
4864 /* Setup the scalarizing loops and bounds. */
4865 gfc_conv_ss_startstride (&loop);
4869 /* Tell the scalarizer to make a temporary. */
4870 loop.temp_ss = gfc_get_ss ();
4871 loop.temp_ss->type = GFC_SS_TEMP;
4872 loop.temp_ss->next = gfc_ss_terminator;
4874 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4875 gfc_conv_string_length (expr->ts.cl, &se->pre);
4877 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4879 if (expr->ts.type == BT_CHARACTER)
4880 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4882 loop.temp_ss->string_length = NULL;
4884 se->string_length = loop.temp_ss->string_length;
4885 loop.temp_ss->data.temp.dimen = loop.dimen;
4886 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4889 gfc_conv_loop_setup (&loop, & expr->where);
4893 /* Copy into a temporary and pass that. We don't need to copy the data
4894 back because expressions and vector subscripts must be INTENT_IN. */
4895 /* TODO: Optimize passing function return values. */
4899 /* Start the copying loops. */
4900 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4901 gfc_mark_ss_chain_used (ss, 1);
4902 gfc_start_scalarized_body (&loop, &block);
4904 /* Copy each data element. */
4905 gfc_init_se (&lse, NULL);
4906 gfc_copy_loopinfo_to_se (&lse, &loop);
4907 gfc_init_se (&rse, NULL);
4908 gfc_copy_loopinfo_to_se (&rse, &loop);
4910 lse.ss = loop.temp_ss;
4913 gfc_conv_scalarized_array_ref (&lse, NULL);
4914 if (expr->ts.type == BT_CHARACTER)
4916 gfc_conv_expr (&rse, expr);
4917 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4918 rse.expr = build_fold_indirect_ref (rse.expr);
4921 gfc_conv_expr_val (&rse, expr);
4923 gfc_add_block_to_block (&block, &rse.pre);
4924 gfc_add_block_to_block (&block, &lse.pre);
4926 lse.string_length = rse.string_length;
4927 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4928 expr->expr_type == EXPR_VARIABLE);
4929 gfc_add_expr_to_block (&block, tmp);
4931 /* Finish the copying loops. */
4932 gfc_trans_scalarizing_loops (&loop, &block);
4934 desc = loop.temp_ss->data.info.descriptor;
4936 gcc_assert (is_gimple_lvalue (desc));
4938 else if (expr->expr_type == EXPR_FUNCTION)
4940 desc = info->descriptor;
4941 se->string_length = ss->string_length;
4945 /* We pass sections without copying to a temporary. Make a new
4946 descriptor and point it at the section we want. The loop variable
4947 limits will be the limits of the section.
4948 A function may decide to repack the array to speed up access, but
4949 we're not bothered about that here. */
4958 /* Set the string_length for a character array. */
4959 if (expr->ts.type == BT_CHARACTER)
4960 se->string_length = gfc_get_expr_charlen (expr);
4962 desc = info->descriptor;
4963 gcc_assert (secss && secss != gfc_ss_terminator);
4964 if (se->direct_byref)
4966 /* For pointer assignments we fill in the destination. */
4968 parmtype = TREE_TYPE (parm);
4972 /* Otherwise make a new one. */
4973 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4974 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4975 loop.from, loop.to, 0,
4977 parm = gfc_create_var (parmtype, "parm");
4980 offset = gfc_index_zero_node;
4983 /* The following can be somewhat confusing. We have two
4984 descriptors, a new one and the original array.
4985 {parm, parmtype, dim} refer to the new one.
4986 {desc, type, n, secss, loop} refer to the original, which maybe
4987 a descriptorless array.
4988 The bounds of the scalarization are the bounds of the section.
4989 We don't have to worry about numeric overflows when calculating
4990 the offsets because all elements are within the array data. */
4992 /* Set the dtype. */
4993 tmp = gfc_conv_descriptor_dtype (parm);
4994 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
4996 /* Set offset for assignments to pointer only to zero if it is not
4998 if (se->direct_byref
4999 && info->ref && info->ref->u.ar.type != AR_FULL)
5000 base = gfc_index_zero_node;
5001 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5002 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5006 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5007 for (n = 0; n < ndim; n++)
5009 stride = gfc_conv_array_stride (desc, n);
5011 /* Work out the offset. */
5013 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5015 gcc_assert (info->subscript[n]
5016 && info->subscript[n]->type == GFC_SS_SCALAR);
5017 start = info->subscript[n]->data.scalar.expr;
5021 /* Check we haven't somehow got out of sync. */
5022 gcc_assert (info->dim[dim] == n);
5024 /* Evaluate and remember the start of the section. */
5025 start = info->start[dim];
5026 stride = gfc_evaluate_now (stride, &loop.pre);
5029 tmp = gfc_conv_array_lbound (desc, n);
5030 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5032 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5033 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5036 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5038 /* For elemental dimensions, we only need the offset. */
5042 /* Vector subscripts need copying and are handled elsewhere. */
5044 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5046 /* Set the new lower bound. */
5047 from = loop.from[dim];
5050 /* If we have an array section or are assigning make sure that
5051 the lower bound is 1. References to the full
5052 array should otherwise keep the original bounds. */
5054 || info->ref->u.ar.type != AR_FULL)
5055 && !integer_onep (from))
5057 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5058 gfc_index_one_node, from);
5059 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5060 from = gfc_index_one_node;
5062 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5063 gfc_add_modify (&loop.pre, tmp, from);
5065 /* Set the new upper bound. */
5066 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5067 gfc_add_modify (&loop.pre, tmp, to);
5069 /* Multiply the stride by the section stride to get the
5071 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5072 stride, info->stride[dim]);
5074 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5076 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5079 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5081 tmp = gfc_conv_array_lbound (desc, n);
5082 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5083 tmp, loop.from[dim]);
5084 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5085 tmp, gfc_conv_array_stride (desc, n));
5086 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5090 /* Store the new stride. */
5091 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5092 gfc_add_modify (&loop.pre, tmp, stride);
5097 if (se->data_not_needed)
5098 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5100 /* Point the data pointer at the first element in the section. */
5101 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5102 subref_array_target, expr);
5104 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5105 && !se->data_not_needed)
5107 /* Set the offset. */
5108 tmp = gfc_conv_descriptor_offset (parm);
5109 gfc_add_modify (&loop.pre, tmp, base);
5113 /* Only the callee knows what the correct offset it, so just set
5115 tmp = gfc_conv_descriptor_offset (parm);
5116 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5121 if (!se->direct_byref)
5123 /* Get a pointer to the new descriptor. */
5124 if (se->want_pointer)
5125 se->expr = build_fold_addr_expr (desc);
5130 gfc_add_block_to_block (&se->pre, &loop.pre);
5131 gfc_add_block_to_block (&se->post, &loop.post);
5133 /* Cleanup the scalarizer. */
5134 gfc_cleanup_loop (&loop);
5138 /* Convert an array for passing as an actual parameter. */
5139 /* TODO: Optimize passing g77 arrays. */
5142 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5143 const gfc_symbol *fsym, const char *proc_name)
5147 tree tmp = NULL_TREE;
5149 tree parent = DECL_CONTEXT (current_function_decl);
5150 bool full_array_var, this_array_result;
5154 full_array_var = (expr->expr_type == EXPR_VARIABLE
5155 && expr->ref->u.ar.type == AR_FULL);
5156 sym = full_array_var ? expr->symtree->n.sym : NULL;
5158 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5160 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5161 expr->ts.cl->backend_decl = tmp;
5162 se->string_length = tmp;
5165 /* Is this the result of the enclosing procedure? */
5166 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5167 if (this_array_result
5168 && (sym->backend_decl != current_function_decl)
5169 && (sym->backend_decl != parent))
5170 this_array_result = false;
5172 /* Passing address of the array if it is not pointer or assumed-shape. */
5173 if (full_array_var && g77 && !this_array_result)
5175 tmp = gfc_get_symbol_decl (sym);
5177 if (sym->ts.type == BT_CHARACTER)
5178 se->string_length = sym->ts.cl->backend_decl;
5179 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5180 && !sym->attr.allocatable)
5182 /* Some variables are declared directly, others are declared as
5183 pointers and allocated on the heap. */
5184 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5187 se->expr = build_fold_addr_expr (tmp);
5190 if (sym->attr.allocatable)
5192 if (sym->attr.dummy || sym->attr.result)
5194 gfc_conv_expr_descriptor (se, expr, ss);
5195 se->expr = gfc_conv_array_data (se->expr);
5198 se->expr = gfc_conv_array_data (tmp);
5203 if (this_array_result)
5205 /* Result of the enclosing function. */
5206 gfc_conv_expr_descriptor (se, expr, ss);
5207 se->expr = build_fold_addr_expr (se->expr);
5209 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5210 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5211 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5217 /* Every other type of array. */
5218 se->want_pointer = 1;
5219 gfc_conv_expr_descriptor (se, expr, ss);
5223 /* Deallocate the allocatable components of structures that are
5225 if (expr->ts.type == BT_DERIVED
5226 && expr->ts.derived->attr.alloc_comp
5227 && expr->expr_type != EXPR_VARIABLE)
5229 tmp = build_fold_indirect_ref (se->expr);
5230 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5231 gfc_add_expr_to_block (&se->post, tmp);
5237 /* Repack the array. */
5239 if (gfc_option.warn_array_temp)
5242 gfc_warning ("Creating array temporary at %L for argument '%s'",
5243 &expr->where, fsym->name);
5245 gfc_warning ("Creating array temporary at %L", &expr->where);
5248 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5250 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5252 tmp = gfc_conv_expr_present (sym);
5253 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp, ptr,
5257 ptr = gfc_evaluate_now (ptr, &se->pre);
5261 if (gfc_option.flag_check_array_temporaries)
5265 if (fsym && proc_name)
5266 asprintf (&msg, "An array temporary was created for argument "
5267 "'%s' of procedure '%s'", fsym->name, proc_name);
5269 asprintf (&msg, "An array temporary was created");
5271 tmp = build_fold_indirect_ref (desc);
5272 tmp = gfc_conv_array_data (tmp);
5273 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5274 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5276 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5277 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5278 gfc_conv_expr_present (sym), tmp);
5280 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5285 gfc_start_block (&block);
5287 /* Copy the data back. */
5288 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5290 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5291 gfc_add_expr_to_block (&block, tmp);
5294 /* Free the temporary. */
5295 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5296 gfc_add_expr_to_block (&block, tmp);
5298 stmt = gfc_finish_block (&block);
5300 gfc_init_block (&block);
5301 /* Only if it was repacked. This code needs to be executed before the
5302 loop cleanup code. */
5303 tmp = build_fold_indirect_ref (desc);
5304 tmp = gfc_conv_array_data (tmp);
5305 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5306 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5308 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5309 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5310 gfc_conv_expr_present (sym), tmp);
5312 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5314 gfc_add_expr_to_block (&block, tmp);
5315 gfc_add_block_to_block (&block, &se->post);
5317 gfc_init_block (&se->post);
5318 gfc_add_block_to_block (&se->post, &block);
5323 /* Generate code to deallocate an array, if it is allocated. */
5326 gfc_trans_dealloc_allocated (tree descriptor)
5332 gfc_start_block (&block);
5334 var = gfc_conv_descriptor_data_get (descriptor);
5337 /* Call array_deallocate with an int * present in the second argument.
5338 Although it is ignored here, it's presence ensures that arrays that
5339 are already deallocated are ignored. */
5340 tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
5341 gfc_add_expr_to_block (&block, tmp);
5343 /* Zero the data pointer. */
5344 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5345 var, build_int_cst (TREE_TYPE (var), 0));
5346 gfc_add_expr_to_block (&block, tmp);
5348 return gfc_finish_block (&block);
5352 /* This helper function calculates the size in words of a full array. */
5355 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5360 idx = gfc_rank_cst[rank - 1];
5361 nelems = gfc_conv_descriptor_ubound (decl, idx);
5362 tmp = gfc_conv_descriptor_lbound (decl, idx);
5363 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5364 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5365 tmp, gfc_index_one_node);
5366 tmp = gfc_evaluate_now (tmp, block);
5368 nelems = gfc_conv_descriptor_stride (decl, idx);
5369 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5370 return gfc_evaluate_now (tmp, block);
5374 /* Allocate dest to the same size as src, and copy src -> dest. */
5377 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5386 /* If the source is null, set the destination to null. */
5387 gfc_init_block (&block);
5388 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5389 null_data = gfc_finish_block (&block);
5391 gfc_init_block (&block);
5393 nelems = get_full_array_size (&block, src, rank);
5394 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5395 fold_convert (gfc_array_index_type,
5396 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5398 /* Allocate memory to the destination. */
5399 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5401 gfc_conv_descriptor_data_set (&block, dest, tmp);
5403 /* We know the temporary and the value will be the same length,
5404 so can use memcpy. */
5405 tmp = built_in_decls[BUILT_IN_MEMCPY];
5406 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5407 gfc_conv_descriptor_data_get (src), size);
5408 gfc_add_expr_to_block (&block, tmp);
5409 tmp = gfc_finish_block (&block);
5411 /* Null the destination if the source is null; otherwise do
5412 the allocate and copy. */
5413 null_cond = gfc_conv_descriptor_data_get (src);
5414 null_cond = convert (pvoid_type_node, null_cond);
5415 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5416 null_cond, null_pointer_node);
5417 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5421 /* Recursively traverse an object of derived type, generating code to
5422 deallocate, nullify or copy allocatable components. This is the work horse
5423 function for the functions named in this enum. */
5425 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5428 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5429 tree dest, int rank, int purpose)
5433 stmtblock_t fnblock;
5434 stmtblock_t loopbody;
5444 tree null_cond = NULL_TREE;
5446 gfc_init_block (&fnblock);
5448 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5449 decl = build_fold_indirect_ref (decl);
5451 /* If this an array of derived types with allocatable components
5452 build a loop and recursively call this function. */
5453 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5454 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5456 tmp = gfc_conv_array_data (decl);
5457 var = build_fold_indirect_ref (tmp);
5459 /* Get the number of elements - 1 and set the counter. */
5460 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5462 /* Use the descriptor for an allocatable array. Since this
5463 is a full array reference, we only need the descriptor
5464 information from dimension = rank. */
5465 tmp = get_full_array_size (&fnblock, decl, rank);
5466 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5467 tmp, gfc_index_one_node);
5469 null_cond = gfc_conv_descriptor_data_get (decl);
5470 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5471 build_int_cst (TREE_TYPE (null_cond), 0));
5475 /* Otherwise use the TYPE_DOMAIN information. */
5476 tmp = array_type_nelts (TREE_TYPE (decl));
5477 tmp = fold_convert (gfc_array_index_type, tmp);
5480 /* Remember that this is, in fact, the no. of elements - 1. */
5481 nelems = gfc_evaluate_now (tmp, &fnblock);
5482 index = gfc_create_var (gfc_array_index_type, "S");
5484 /* Build the body of the loop. */
5485 gfc_init_block (&loopbody);
5487 vref = gfc_build_array_ref (var, index, NULL);
5489 if (purpose == COPY_ALLOC_COMP)
5491 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5492 gfc_add_expr_to_block (&fnblock, tmp);
5494 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5495 dref = gfc_build_array_ref (tmp, index, NULL);
5496 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5499 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5501 gfc_add_expr_to_block (&loopbody, tmp);
5503 /* Build the loop and return. */
5504 gfc_init_loopinfo (&loop);
5506 loop.from[0] = gfc_index_zero_node;
5507 loop.loopvar[0] = index;
5508 loop.to[0] = nelems;
5509 gfc_trans_scalarizing_loops (&loop, &loopbody);
5510 gfc_add_block_to_block (&fnblock, &loop.pre);
5512 tmp = gfc_finish_block (&fnblock);
5513 if (null_cond != NULL_TREE)
5514 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5519 /* Otherwise, act on the components or recursively call self to
5520 act on a chain of components. */
5521 for (c = der_type->components; c; c = c->next)
5523 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5524 && c->ts.derived->attr.alloc_comp;
5525 cdecl = c->backend_decl;
5526 ctype = TREE_TYPE (cdecl);
5530 case DEALLOCATE_ALLOC_COMP:
5531 /* Do not deallocate the components of ultimate pointer
5533 if (cmp_has_alloc_comps && !c->pointer)
5535 comp = fold_build3 (COMPONENT_REF, ctype,
5536 decl, cdecl, NULL_TREE);
5537 rank = c->as ? c->as->rank : 0;
5538 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5540 gfc_add_expr_to_block (&fnblock, tmp);
5545 comp = fold_build3 (COMPONENT_REF, ctype,
5546 decl, cdecl, NULL_TREE);
5547 tmp = gfc_trans_dealloc_allocated (comp);
5548 gfc_add_expr_to_block (&fnblock, tmp);
5552 case NULLIFY_ALLOC_COMP:
5555 else if (c->allocatable)
5557 comp = fold_build3 (COMPONENT_REF, ctype,
5558 decl, cdecl, NULL_TREE);
5559 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5561 else if (cmp_has_alloc_comps)
5563 comp = fold_build3 (COMPONENT_REF, ctype,
5564 decl, cdecl, NULL_TREE);
5565 rank = c->as ? c->as->rank : 0;
5566 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5568 gfc_add_expr_to_block (&fnblock, tmp);
5572 case COPY_ALLOC_COMP:
5576 /* We need source and destination components. */
5577 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5578 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5579 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5581 if (c->allocatable && !cmp_has_alloc_comps)
5583 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5584 gfc_add_expr_to_block (&fnblock, tmp);
5587 if (cmp_has_alloc_comps)
5589 rank = c->as ? c->as->rank : 0;
5590 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5591 gfc_add_modify (&fnblock, dcmp, tmp);
5592 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5594 gfc_add_expr_to_block (&fnblock, tmp);
5604 return gfc_finish_block (&fnblock);
5607 /* Recursively traverse an object of derived type, generating code to
5608 nullify allocatable components. */
5611 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5613 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5614 NULLIFY_ALLOC_COMP);
5618 /* Recursively traverse an object of derived type, generating code to
5619 deallocate allocatable components. */
5622 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5624 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5625 DEALLOCATE_ALLOC_COMP);
5629 /* Recursively traverse an object of derived type, generating code to
5630 copy its allocatable components. */
5633 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5635 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5639 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5640 Do likewise, recursively if necessary, with the allocatable components of
5644 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5649 stmtblock_t fnblock;
5652 bool sym_has_alloc_comp;
5654 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5655 && sym->ts.derived->attr.alloc_comp;
5657 /* Make sure the frontend gets these right. */
5658 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5659 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5660 "allocatable attribute or derived type without allocatable "
5663 gfc_init_block (&fnblock);
5665 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5666 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5668 if (sym->ts.type == BT_CHARACTER
5669 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5671 gfc_conv_string_length (sym->ts.cl, &fnblock);
5672 gfc_trans_vla_type_sizes (sym, &fnblock);
5675 /* Dummy and use associated variables don't need anything special. */
5676 if (sym->attr.dummy || sym->attr.use_assoc)
5678 gfc_add_expr_to_block (&fnblock, body);
5680 return gfc_finish_block (&fnblock);
5683 gfc_get_backend_locus (&loc);
5684 gfc_set_backend_locus (&sym->declared_at);
5685 descriptor = sym->backend_decl;
5687 /* Although static, derived types with default initializers and
5688 allocatable components must not be nulled wholesale; instead they
5689 are treated component by component. */
5690 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5692 /* SAVEd variables are not freed on exit. */
5693 gfc_trans_static_array_pointer (sym);
5697 /* Get the descriptor type. */
5698 type = TREE_TYPE (sym->backend_decl);
5700 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5702 if (!sym->attr.save)
5704 rank = sym->as ? sym->as->rank : 0;
5705 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5706 gfc_add_expr_to_block (&fnblock, tmp);
5709 tmp = gfc_init_default_dt (sym, NULL);
5710 gfc_add_expr_to_block (&fnblock, tmp);
5714 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5716 /* If the backend_decl is not a descriptor, we must have a pointer
5718 descriptor = build_fold_indirect_ref (sym->backend_decl);
5719 type = TREE_TYPE (descriptor);
5722 /* NULLIFY the data pointer. */
5723 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5724 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5726 gfc_add_expr_to_block (&fnblock, body);
5728 gfc_set_backend_locus (&loc);
5730 /* Allocatable arrays need to be freed when they go out of scope.
5731 The allocatable components of pointers must not be touched. */
5732 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5733 && !sym->attr.pointer && !sym->attr.save)
5736 rank = sym->as ? sym->as->rank : 0;
5737 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5738 gfc_add_expr_to_block (&fnblock, tmp);
5741 if (sym->attr.allocatable && !sym->attr.save)
5743 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5744 gfc_add_expr_to_block (&fnblock, tmp);
5747 return gfc_finish_block (&fnblock);
5750 /************ Expression Walking Functions ******************/
5752 /* Walk a variable reference.
5754 Possible extension - multiple component subscripts.
5755 x(:,:) = foo%a(:)%b(:)
5757 forall (i=..., j=...)
5758 x(i,j) = foo%a(j)%b(i)
5760 This adds a fair amount of complexity because you need to deal with more
5761 than one ref. Maybe handle in a similar manner to vector subscripts.
5762 Maybe not worth the effort. */
5766 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5774 for (ref = expr->ref; ref; ref = ref->next)
5775 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5778 for (; ref; ref = ref->next)
5780 if (ref->type == REF_SUBSTRING)
5782 newss = gfc_get_ss ();
5783 newss->type = GFC_SS_SCALAR;
5784 newss->expr = ref->u.ss.start;
5788 newss = gfc_get_ss ();
5789 newss->type = GFC_SS_SCALAR;
5790 newss->expr = ref->u.ss.end;
5795 /* We're only interested in array sections from now on. */
5796 if (ref->type != REF_ARRAY)
5803 for (n = 0; n < ar->dimen; n++)
5805 newss = gfc_get_ss ();
5806 newss->type = GFC_SS_SCALAR;
5807 newss->expr = ar->start[n];
5814 newss = gfc_get_ss ();
5815 newss->type = GFC_SS_SECTION;
5818 newss->data.info.dimen = ar->as->rank;
5819 newss->data.info.ref = ref;
5821 /* Make sure array is the same as array(:,:), this way
5822 we don't need to special case all the time. */
5823 ar->dimen = ar->as->rank;
5824 for (n = 0; n < ar->dimen; n++)
5826 newss->data.info.dim[n] = n;
5827 ar->dimen_type[n] = DIMEN_RANGE;
5829 gcc_assert (ar->start[n] == NULL);
5830 gcc_assert (ar->end[n] == NULL);
5831 gcc_assert (ar->stride[n] == NULL);
5837 newss = gfc_get_ss ();
5838 newss->type = GFC_SS_SECTION;
5841 newss->data.info.dimen = 0;
5842 newss->data.info.ref = ref;
5846 /* We add SS chains for all the subscripts in the section. */
5847 for (n = 0; n < ar->dimen; n++)
5851 switch (ar->dimen_type[n])
5854 /* Add SS for elemental (scalar) subscripts. */
5855 gcc_assert (ar->start[n]);
5856 indexss = gfc_get_ss ();
5857 indexss->type = GFC_SS_SCALAR;
5858 indexss->expr = ar->start[n];
5859 indexss->next = gfc_ss_terminator;
5860 indexss->loop_chain = gfc_ss_terminator;
5861 newss->data.info.subscript[n] = indexss;
5865 /* We don't add anything for sections, just remember this
5866 dimension for later. */
5867 newss->data.info.dim[newss->data.info.dimen] = n;
5868 newss->data.info.dimen++;
5872 /* Create a GFC_SS_VECTOR index in which we can store
5873 the vector's descriptor. */
5874 indexss = gfc_get_ss ();
5875 indexss->type = GFC_SS_VECTOR;
5876 indexss->expr = ar->start[n];
5877 indexss->next = gfc_ss_terminator;
5878 indexss->loop_chain = gfc_ss_terminator;
5879 newss->data.info.subscript[n] = indexss;
5880 newss->data.info.dim[newss->data.info.dimen] = n;
5881 newss->data.info.dimen++;
5885 /* We should know what sort of section it is by now. */
5889 /* We should have at least one non-elemental dimension. */
5890 gcc_assert (newss->data.info.dimen > 0);
5895 /* We should know what sort of section it is by now. */
5904 /* Walk an expression operator. If only one operand of a binary expression is
5905 scalar, we must also add the scalar term to the SS chain. */
5908 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5914 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5915 if (expr->value.op.op2 == NULL)
5918 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5920 /* All operands are scalar. Pass back and let the caller deal with it. */
5924 /* All operands require scalarization. */
5925 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5928 /* One of the operands needs scalarization, the other is scalar.
5929 Create a gfc_ss for the scalar expression. */
5930 newss = gfc_get_ss ();
5931 newss->type = GFC_SS_SCALAR;
5934 /* First operand is scalar. We build the chain in reverse order, so
5935 add the scalar SS after the second operand. */
5937 while (head && head->next != ss)
5939 /* Check we haven't somehow broken the chain. */
5943 newss->expr = expr->value.op.op1;
5945 else /* head2 == head */
5947 gcc_assert (head2 == head);
5948 /* Second operand is scalar. */
5949 newss->next = head2;
5951 newss->expr = expr->value.op.op2;
5958 /* Reverse a SS chain. */
5961 gfc_reverse_ss (gfc_ss * ss)
5966 gcc_assert (ss != NULL);
5968 head = gfc_ss_terminator;
5969 while (ss != gfc_ss_terminator)
5972 /* Check we didn't somehow break the chain. */
5973 gcc_assert (next != NULL);
5983 /* Walk the arguments of an elemental function. */
5986 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5994 head = gfc_ss_terminator;
5997 for (; arg; arg = arg->next)
6002 newss = gfc_walk_subexpr (head, arg->expr);
6005 /* Scalar argument. */
6006 newss = gfc_get_ss ();
6008 newss->expr = arg->expr;
6018 while (tail->next != gfc_ss_terminator)
6025 /* If all the arguments are scalar we don't need the argument SS. */
6026 gfc_free_ss_chain (head);
6031 /* Add it onto the existing chain. */
6037 /* Walk a function call. Scalar functions are passed back, and taken out of
6038 scalarization loops. For elemental functions we walk their arguments.
6039 The result of functions returning arrays is stored in a temporary outside
6040 the loop, so that the function is only called once. Hence we do not need
6041 to walk their arguments. */
6044 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6047 gfc_intrinsic_sym *isym;
6050 isym = expr->value.function.isym;
6052 /* Handle intrinsic functions separately. */
6054 return gfc_walk_intrinsic_function (ss, expr, isym);
6056 sym = expr->value.function.esym;
6058 sym = expr->symtree->n.sym;
6060 /* A function that returns arrays. */
6061 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6063 newss = gfc_get_ss ();
6064 newss->type = GFC_SS_FUNCTION;
6067 newss->data.info.dimen = expr->rank;
6071 /* Walk the parameters of an elemental function. For now we always pass
6073 if (sym->attr.elemental)
6074 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6077 /* Scalar functions are OK as these are evaluated outside the scalarization
6078 loop. Pass back and let the caller deal with it. */
6083 /* An array temporary is constructed for array constructors. */
6086 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6091 newss = gfc_get_ss ();
6092 newss->type = GFC_SS_CONSTRUCTOR;
6095 newss->data.info.dimen = expr->rank;
6096 for (n = 0; n < expr->rank; n++)
6097 newss->data.info.dim[n] = n;
6103 /* Walk an expression. Add walked expressions to the head of the SS chain.
6104 A wholly scalar expression will not be added. */
6107 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6111 switch (expr->expr_type)
6114 head = gfc_walk_variable_expr (ss, expr);
6118 head = gfc_walk_op_expr (ss, expr);
6122 head = gfc_walk_function_expr (ss, expr);
6127 case EXPR_STRUCTURE:
6128 /* Pass back and let the caller deal with it. */
6132 head = gfc_walk_array_constructor (ss, expr);
6135 case EXPR_SUBSTRING:
6136 /* Pass back and let the caller deal with it. */
6140 internal_error ("bad expression type during walk (%d)",
6147 /* Entry point for expression walking.
6148 A return value equal to the passed chain means this is
6149 a scalar expression. It is up to the caller to take whatever action is
6150 necessary to translate these. */
6153 gfc_walk_expr (gfc_expr * expr)
6157 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6158 return gfc_reverse_ss (res);