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)
1697 bool old_first_len, old_typespec_chararray_ctor;
1698 tree old_first_len_val;
1700 /* Save the old values for nested checking. */
1701 old_first_len = first_len;
1702 old_first_len_val = first_len_val;
1703 old_typespec_chararray_ctor = typespec_chararray_ctor;
1705 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1706 typespec was given for the array constructor. */
1707 typespec_chararray_ctor = (ss->expr->ts.cl
1708 && ss->expr->ts.cl->length_from_typespec);
1710 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
1711 && !typespec_chararray_ctor)
1713 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1717 ss->data.info.dimen = loop->dimen;
1719 c = ss->expr->value.constructor;
1720 if (ss->expr->ts.type == BT_CHARACTER)
1724 /* get_array_ctor_strlen walks the elements of the constructor, if a
1725 typespec was given, we already know the string length and want the one
1727 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1728 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1732 const_string = false;
1733 gfc_init_se (&length_se, NULL);
1734 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1735 gfc_charlen_type_node);
1736 ss->string_length = length_se.expr;
1737 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1738 gfc_add_block_to_block (&loop->post, &length_se.post);
1741 const_string = get_array_ctor_strlen (&loop->pre, c,
1742 &ss->string_length);
1744 /* Complex character array constructors should have been taken care of
1745 and not end up here. */
1746 gcc_assert (ss->string_length);
1748 ss->expr->ts.cl->backend_decl = ss->string_length;
1750 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1752 type = build_pointer_type (type);
1755 type = gfc_typenode_for_spec (&ss->expr->ts);
1757 /* See if the constructor determines the loop bounds. */
1760 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1762 /* We have a multidimensional parameter. */
1764 for (n = 0; n < ss->expr->rank; n++)
1766 loop->from[n] = gfc_index_zero_node;
1767 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1768 gfc_index_integer_kind);
1769 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1770 loop->to[n], gfc_index_one_node);
1774 if (loop->to[0] == NULL_TREE)
1778 /* We should have a 1-dimensional, zero-based loop. */
1779 gcc_assert (loop->dimen == 1);
1780 gcc_assert (integer_zerop (loop->from[0]));
1782 /* Split the constructor size into a static part and a dynamic part.
1783 Allocate the static size up-front and record whether the dynamic
1784 size might be nonzero. */
1786 dynamic = gfc_get_array_constructor_size (&size, c);
1787 mpz_sub_ui (size, size, 1);
1788 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1792 /* Special case constant array constructors. */
1795 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1798 tree size = constant_array_constructor_loop_size (loop);
1799 if (size && compare_tree_int (size, nelem) == 0)
1801 gfc_trans_constant_array_constructor (loop, ss, type);
1807 /* Temporarily reset the loop variables, so that the returned temporary
1808 has the right size and bounds. This seems only to be necessary for
1810 if (!integer_zerop (loop->from[0]) && loop->dimen == 1)
1812 loopfrom = loop->from[0];
1813 loop->from[0] = gfc_index_zero_node;
1814 loop->to[0] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1815 loop->to[0], loopfrom);
1818 loopfrom = NULL_TREE;
1820 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1821 type, dynamic, true, false, where);
1823 if (loopfrom != NULL_TREE)
1825 loop->from[0] = loopfrom;
1826 loop->to[0] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1827 loop->to[0], loopfrom);
1828 /* In the case of a non-zero from, the temporary needs an offset
1829 so that subsequent indexing is correct. */
1830 ss->data.info.offset = fold_build1 (NEGATE_EXPR,
1831 gfc_array_index_type,
1835 desc = ss->data.info.descriptor;
1836 offset = gfc_index_zero_node;
1837 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1838 TREE_NO_WARNING (offsetvar) = 1;
1839 TREE_USED (offsetvar) = 0;
1840 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1841 &offset, &offsetvar, dynamic);
1843 /* If the array grows dynamically, the upper bound of the loop variable
1844 is determined by the array's final upper bound. */
1846 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1848 if (TREE_USED (offsetvar))
1849 pushdecl (offsetvar);
1851 gcc_assert (INTEGER_CST_P (offset));
1853 /* Disable bound checking for now because it's probably broken. */
1854 if (flag_bounds_check)
1861 /* Restore old values of globals. */
1862 first_len = old_first_len;
1863 first_len_val = old_first_len_val;
1864 typespec_chararray_ctor = old_typespec_chararray_ctor;
1868 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1869 called after evaluating all of INFO's vector dimensions. Go through
1870 each such vector dimension and see if we can now fill in any missing
1874 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1883 for (n = 0; n < loop->dimen; n++)
1886 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1887 && loop->to[n] == NULL)
1889 /* Loop variable N indexes vector dimension DIM, and we don't
1890 yet know the upper bound of loop variable N. Set it to the
1891 difference between the vector's upper and lower bounds. */
1892 gcc_assert (loop->from[n] == gfc_index_zero_node);
1893 gcc_assert (info->subscript[dim]
1894 && info->subscript[dim]->type == GFC_SS_VECTOR);
1896 gfc_init_se (&se, NULL);
1897 desc = info->subscript[dim]->data.info.descriptor;
1898 zero = gfc_rank_cst[0];
1899 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1900 gfc_conv_descriptor_ubound (desc, zero),
1901 gfc_conv_descriptor_lbound (desc, zero));
1902 tmp = gfc_evaluate_now (tmp, &loop->pre);
1909 /* Add the pre and post chains for all the scalar expressions in a SS chain
1910 to loop. This is called after the loop parameters have been calculated,
1911 but before the actual scalarizing loops. */
1914 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1920 /* TODO: This can generate bad code if there are ordering dependencies,
1921 e.g., a callee allocated function and an unknown size constructor. */
1922 gcc_assert (ss != NULL);
1924 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1931 /* Scalar expression. Evaluate this now. This includes elemental
1932 dimension indices, but not array section bounds. */
1933 gfc_init_se (&se, NULL);
1934 gfc_conv_expr (&se, ss->expr);
1935 gfc_add_block_to_block (&loop->pre, &se.pre);
1937 if (ss->expr->ts.type != BT_CHARACTER)
1939 /* Move the evaluation of scalar expressions outside the
1940 scalarization loop, except for WHERE assignments. */
1942 se.expr = convert(gfc_array_index_type, se.expr);
1944 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1945 gfc_add_block_to_block (&loop->pre, &se.post);
1948 gfc_add_block_to_block (&loop->post, &se.post);
1950 ss->data.scalar.expr = se.expr;
1951 ss->string_length = se.string_length;
1954 case GFC_SS_REFERENCE:
1955 /* Scalar reference. Evaluate this now. */
1956 gfc_init_se (&se, NULL);
1957 gfc_conv_expr_reference (&se, ss->expr);
1958 gfc_add_block_to_block (&loop->pre, &se.pre);
1959 gfc_add_block_to_block (&loop->post, &se.post);
1961 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1962 ss->string_length = se.string_length;
1965 case GFC_SS_SECTION:
1966 /* Add the expressions for scalar and vector subscripts. */
1967 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1968 if (ss->data.info.subscript[n])
1969 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
1972 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1976 /* Get the vector's descriptor and store it in SS. */
1977 gfc_init_se (&se, NULL);
1978 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1979 gfc_add_block_to_block (&loop->pre, &se.pre);
1980 gfc_add_block_to_block (&loop->post, &se.post);
1981 ss->data.info.descriptor = se.expr;
1984 case GFC_SS_INTRINSIC:
1985 gfc_add_intrinsic_ss_code (loop, ss);
1988 case GFC_SS_FUNCTION:
1989 /* Array function return value. We call the function and save its
1990 result in a temporary for use inside the loop. */
1991 gfc_init_se (&se, NULL);
1994 gfc_conv_expr (&se, ss->expr);
1995 gfc_add_block_to_block (&loop->pre, &se.pre);
1996 gfc_add_block_to_block (&loop->post, &se.post);
1997 ss->string_length = se.string_length;
2000 case GFC_SS_CONSTRUCTOR:
2001 if (ss->expr->ts.type == BT_CHARACTER
2002 && ss->string_length == NULL
2004 && ss->expr->ts.cl->length)
2006 gfc_init_se (&se, NULL);
2007 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
2008 gfc_charlen_type_node);
2009 ss->string_length = se.expr;
2010 gfc_add_block_to_block (&loop->pre, &se.pre);
2011 gfc_add_block_to_block (&loop->post, &se.post);
2013 gfc_trans_array_constructor (loop, ss, where);
2017 case GFC_SS_COMPONENT:
2018 /* Do nothing. These are handled elsewhere. */
2028 /* Translate expressions for the descriptor and data pointer of a SS. */
2032 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2037 /* Get the descriptor for the array to be scalarized. */
2038 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2039 gfc_init_se (&se, NULL);
2040 se.descriptor_only = 1;
2041 gfc_conv_expr_lhs (&se, ss->expr);
2042 gfc_add_block_to_block (block, &se.pre);
2043 ss->data.info.descriptor = se.expr;
2044 ss->string_length = se.string_length;
2048 /* Also the data pointer. */
2049 tmp = gfc_conv_array_data (se.expr);
2050 /* If this is a variable or address of a variable we use it directly.
2051 Otherwise we must evaluate it now to avoid breaking dependency
2052 analysis by pulling the expressions for elemental array indices
2055 || (TREE_CODE (tmp) == ADDR_EXPR
2056 && DECL_P (TREE_OPERAND (tmp, 0)))))
2057 tmp = gfc_evaluate_now (tmp, block);
2058 ss->data.info.data = tmp;
2060 tmp = gfc_conv_array_offset (se.expr);
2061 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2066 /* Initialize a gfc_loopinfo structure. */
2069 gfc_init_loopinfo (gfc_loopinfo * loop)
2073 memset (loop, 0, sizeof (gfc_loopinfo));
2074 gfc_init_block (&loop->pre);
2075 gfc_init_block (&loop->post);
2077 /* Initially scalarize in order. */
2078 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2081 loop->ss = gfc_ss_terminator;
2085 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2089 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2095 /* Return an expression for the data pointer of an array. */
2098 gfc_conv_array_data (tree descriptor)
2102 type = TREE_TYPE (descriptor);
2103 if (GFC_ARRAY_TYPE_P (type))
2105 if (TREE_CODE (type) == POINTER_TYPE)
2109 /* Descriptorless arrays. */
2110 return build_fold_addr_expr (descriptor);
2114 return gfc_conv_descriptor_data_get (descriptor);
2118 /* Return an expression for the base offset of an array. */
2121 gfc_conv_array_offset (tree descriptor)
2125 type = TREE_TYPE (descriptor);
2126 if (GFC_ARRAY_TYPE_P (type))
2127 return GFC_TYPE_ARRAY_OFFSET (type);
2129 return gfc_conv_descriptor_offset (descriptor);
2133 /* Get an expression for the array stride. */
2136 gfc_conv_array_stride (tree descriptor, int dim)
2141 type = TREE_TYPE (descriptor);
2143 /* For descriptorless arrays use the array size. */
2144 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2145 if (tmp != NULL_TREE)
2148 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2153 /* Like gfc_conv_array_stride, but for the lower bound. */
2156 gfc_conv_array_lbound (tree descriptor, int dim)
2161 type = TREE_TYPE (descriptor);
2163 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2164 if (tmp != NULL_TREE)
2167 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2172 /* Like gfc_conv_array_stride, but for the upper bound. */
2175 gfc_conv_array_ubound (tree descriptor, int dim)
2180 type = TREE_TYPE (descriptor);
2182 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2183 if (tmp != NULL_TREE)
2186 /* This should only ever happen when passing an assumed shape array
2187 as an actual parameter. The value will never be used. */
2188 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2189 return gfc_index_zero_node;
2191 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2196 /* Generate code to perform an array index bound check. */
2199 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2200 locus * where, bool check_upper)
2205 const char * name = NULL;
2207 if (!flag_bounds_check)
2210 index = gfc_evaluate_now (index, &se->pre);
2212 /* We find a name for the error message. */
2214 name = se->ss->expr->symtree->name;
2216 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2217 && se->loop->ss->expr->symtree)
2218 name = se->loop->ss->expr->symtree->name;
2220 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2221 && se->loop->ss->loop_chain->expr
2222 && se->loop->ss->loop_chain->expr->symtree)
2223 name = se->loop->ss->loop_chain->expr->symtree->name;
2225 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2226 && se->loop->ss->loop_chain->expr->symtree)
2227 name = se->loop->ss->loop_chain->expr->symtree->name;
2229 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2231 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2232 && se->loop->ss->expr->value.function.name)
2233 name = se->loop->ss->expr->value.function.name;
2235 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2236 || se->loop->ss->type == GFC_SS_SCALAR)
2237 name = "unnamed constant";
2240 /* Check lower bound. */
2241 tmp = gfc_conv_array_lbound (descriptor, n);
2242 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2244 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2245 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2247 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2248 gfc_msg_fault, n+1);
2249 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2250 fold_convert (long_integer_type_node, index),
2251 fold_convert (long_integer_type_node, tmp));
2254 /* Check upper bound. */
2257 tmp = gfc_conv_array_ubound (descriptor, n);
2258 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2260 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2261 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2263 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2264 gfc_msg_fault, n+1);
2265 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2266 fold_convert (long_integer_type_node, index),
2267 fold_convert (long_integer_type_node, tmp));
2275 /* Return the offset for an index. Performs bound checking for elemental
2276 dimensions. Single element references are processed separately. */
2279 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2280 gfc_array_ref * ar, tree stride)
2286 /* Get the index into the array for this dimension. */
2289 gcc_assert (ar->type != AR_ELEMENT);
2290 switch (ar->dimen_type[dim])
2293 /* Elemental dimension. */
2294 gcc_assert (info->subscript[dim]
2295 && info->subscript[dim]->type == GFC_SS_SCALAR);
2296 /* We've already translated this value outside the loop. */
2297 index = info->subscript[dim]->data.scalar.expr;
2299 index = gfc_trans_array_bound_check (se, info->descriptor,
2300 index, dim, &ar->where,
2301 (ar->as->type != AS_ASSUMED_SIZE
2302 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2306 gcc_assert (info && se->loop);
2307 gcc_assert (info->subscript[dim]
2308 && info->subscript[dim]->type == GFC_SS_VECTOR);
2309 desc = info->subscript[dim]->data.info.descriptor;
2311 /* Get a zero-based index into the vector. */
2312 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2313 se->loop->loopvar[i], se->loop->from[i]);
2315 /* Multiply the index by the stride. */
2316 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2317 index, gfc_conv_array_stride (desc, 0));
2319 /* Read the vector to get an index into info->descriptor. */
2320 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2321 index = gfc_build_array_ref (data, index, NULL);
2322 index = gfc_evaluate_now (index, &se->pre);
2324 /* Do any bounds checking on the final info->descriptor index. */
2325 index = gfc_trans_array_bound_check (se, info->descriptor,
2326 index, dim, &ar->where,
2327 (ar->as->type != AS_ASSUMED_SIZE
2328 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2332 /* Scalarized dimension. */
2333 gcc_assert (info && se->loop);
2335 /* Multiply the loop variable by the stride and delta. */
2336 index = se->loop->loopvar[i];
2337 if (!integer_onep (info->stride[i]))
2338 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2340 if (!integer_zerop (info->delta[i]))
2341 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2351 /* Temporary array or derived type component. */
2352 gcc_assert (se->loop);
2353 index = se->loop->loopvar[se->loop->order[i]];
2354 if (!integer_zerop (info->delta[i]))
2355 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2356 index, info->delta[i]);
2359 /* Multiply by the stride. */
2360 if (!integer_onep (stride))
2361 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2367 /* Build a scalarized reference to an array. */
2370 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2373 tree decl = NULL_TREE;
2378 info = &se->ss->data.info;
2380 n = se->loop->order[0];
2384 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2386 /* Add the offset for this dimension to the stored offset for all other
2388 if (!integer_zerop (info->offset))
2389 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2391 if (se->ss->expr && is_subref_array (se->ss->expr))
2392 decl = se->ss->expr->symtree->n.sym->backend_decl;
2394 tmp = build_fold_indirect_ref (info->data);
2395 se->expr = gfc_build_array_ref (tmp, index, decl);
2399 /* Translate access of temporary array. */
2402 gfc_conv_tmp_array_ref (gfc_se * se)
2404 se->string_length = se->ss->string_length;
2405 gfc_conv_scalarized_array_ref (se, NULL);
2409 /* Build an array reference. se->expr already holds the array descriptor.
2410 This should be either a variable, indirect variable reference or component
2411 reference. For arrays which do not have a descriptor, se->expr will be
2413 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2416 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2425 /* Handle scalarized references separately. */
2426 if (ar->type != AR_ELEMENT)
2428 gfc_conv_scalarized_array_ref (se, ar);
2429 gfc_advance_se_ss_chain (se);
2433 index = gfc_index_zero_node;
2435 /* Calculate the offsets from all the dimensions. */
2436 for (n = 0; n < ar->dimen; n++)
2438 /* Calculate the index for this dimension. */
2439 gfc_init_se (&indexse, se);
2440 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2441 gfc_add_block_to_block (&se->pre, &indexse.pre);
2443 if (flag_bounds_check)
2445 /* Check array bounds. */
2449 /* Evaluate the indexse.expr only once. */
2450 indexse.expr = save_expr (indexse.expr);
2453 tmp = gfc_conv_array_lbound (se->expr, n);
2454 cond = fold_build2 (LT_EXPR, boolean_type_node,
2456 asprintf (&msg, "%s for array '%s', "
2457 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2458 gfc_msg_fault, sym->name, n+1);
2459 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2460 fold_convert (long_integer_type_node,
2462 fold_convert (long_integer_type_node, tmp));
2465 /* Upper bound, but not for the last dimension of assumed-size
2467 if (n < ar->dimen - 1
2468 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2470 tmp = gfc_conv_array_ubound (se->expr, n);
2471 cond = fold_build2 (GT_EXPR, boolean_type_node,
2473 asprintf (&msg, "%s for array '%s', "
2474 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2475 gfc_msg_fault, sym->name, n+1);
2476 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2477 fold_convert (long_integer_type_node,
2479 fold_convert (long_integer_type_node, tmp));
2484 /* Multiply the index by the stride. */
2485 stride = gfc_conv_array_stride (se->expr, n);
2486 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2489 /* And add it to the total. */
2490 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2493 tmp = gfc_conv_array_offset (se->expr);
2494 if (!integer_zerop (tmp))
2495 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2497 /* Access the calculated element. */
2498 tmp = gfc_conv_array_data (se->expr);
2499 tmp = build_fold_indirect_ref (tmp);
2500 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2504 /* Generate the code to be executed immediately before entering a
2505 scalarization loop. */
2508 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2509 stmtblock_t * pblock)
2518 /* This code will be executed before entering the scalarization loop
2519 for this dimension. */
2520 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2522 if ((ss->useflags & flag) == 0)
2525 if (ss->type != GFC_SS_SECTION
2526 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2527 && ss->type != GFC_SS_COMPONENT)
2530 info = &ss->data.info;
2532 if (dim >= info->dimen)
2535 if (dim == info->dimen - 1)
2537 /* For the outermost loop calculate the offset due to any
2538 elemental dimensions. It will have been initialized with the
2539 base offset of the array. */
2542 for (i = 0; i < info->ref->u.ar.dimen; i++)
2544 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2547 gfc_init_se (&se, NULL);
2549 se.expr = info->descriptor;
2550 stride = gfc_conv_array_stride (info->descriptor, i);
2551 index = gfc_conv_array_index_offset (&se, info, i, -1,
2554 gfc_add_block_to_block (pblock, &se.pre);
2556 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2557 info->offset, index);
2558 info->offset = gfc_evaluate_now (info->offset, pblock);
2562 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2565 stride = gfc_conv_array_stride (info->descriptor, 0);
2567 /* Calculate the stride of the innermost loop. Hopefully this will
2568 allow the backend optimizers to do their stuff more effectively.
2570 info->stride0 = gfc_evaluate_now (stride, pblock);
2574 /* Add the offset for the previous loop dimension. */
2579 ar = &info->ref->u.ar;
2580 i = loop->order[dim + 1];
2588 gfc_init_se (&se, NULL);
2590 se.expr = info->descriptor;
2591 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2592 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2594 gfc_add_block_to_block (pblock, &se.pre);
2595 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2596 info->offset, index);
2597 info->offset = gfc_evaluate_now (info->offset, pblock);
2600 /* Remember this offset for the second loop. */
2601 if (dim == loop->temp_dim - 1)
2602 info->saved_offset = info->offset;
2607 /* Start a scalarized expression. Creates a scope and declares loop
2611 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2617 gcc_assert (!loop->array_parameter);
2619 for (dim = loop->dimen - 1; dim >= 0; dim--)
2621 n = loop->order[dim];
2623 gfc_start_block (&loop->code[n]);
2625 /* Create the loop variable. */
2626 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2628 if (dim < loop->temp_dim)
2632 /* Calculate values that will be constant within this loop. */
2633 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2635 gfc_start_block (pbody);
2639 /* Generates the actual loop code for a scalarization loop. */
2642 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2643 stmtblock_t * pbody)
2651 loopbody = gfc_finish_block (pbody);
2653 /* Initialize the loopvar. */
2654 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2656 exit_label = gfc_build_label_decl (NULL_TREE);
2658 /* Generate the loop body. */
2659 gfc_init_block (&block);
2661 /* The exit condition. */
2662 cond = fold_build2 (GT_EXPR, boolean_type_node,
2663 loop->loopvar[n], loop->to[n]);
2664 tmp = build1_v (GOTO_EXPR, exit_label);
2665 TREE_USED (exit_label) = 1;
2666 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2667 gfc_add_expr_to_block (&block, tmp);
2669 /* The main body. */
2670 gfc_add_expr_to_block (&block, loopbody);
2672 /* Increment the loopvar. */
2673 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2674 loop->loopvar[n], gfc_index_one_node);
2675 gfc_add_modify (&block, loop->loopvar[n], tmp);
2677 /* Build the loop. */
2678 tmp = gfc_finish_block (&block);
2679 tmp = build1_v (LOOP_EXPR, tmp);
2680 gfc_add_expr_to_block (&loop->code[n], tmp);
2682 /* Add the exit label. */
2683 tmp = build1_v (LABEL_EXPR, exit_label);
2684 gfc_add_expr_to_block (&loop->code[n], tmp);
2688 /* Finishes and generates the loops for a scalarized expression. */
2691 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2696 stmtblock_t *pblock;
2700 /* Generate the loops. */
2701 for (dim = 0; dim < loop->dimen; dim++)
2703 n = loop->order[dim];
2704 gfc_trans_scalarized_loop_end (loop, n, pblock);
2705 loop->loopvar[n] = NULL_TREE;
2706 pblock = &loop->code[n];
2709 tmp = gfc_finish_block (pblock);
2710 gfc_add_expr_to_block (&loop->pre, tmp);
2712 /* Clear all the used flags. */
2713 for (ss = loop->ss; ss; ss = ss->loop_chain)
2718 /* Finish the main body of a scalarized expression, and start the secondary
2722 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2726 stmtblock_t *pblock;
2730 /* We finish as many loops as are used by the temporary. */
2731 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2733 n = loop->order[dim];
2734 gfc_trans_scalarized_loop_end (loop, n, pblock);
2735 loop->loopvar[n] = NULL_TREE;
2736 pblock = &loop->code[n];
2739 /* We don't want to finish the outermost loop entirely. */
2740 n = loop->order[loop->temp_dim - 1];
2741 gfc_trans_scalarized_loop_end (loop, n, pblock);
2743 /* Restore the initial offsets. */
2744 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2746 if ((ss->useflags & 2) == 0)
2749 if (ss->type != GFC_SS_SECTION
2750 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2751 && ss->type != GFC_SS_COMPONENT)
2754 ss->data.info.offset = ss->data.info.saved_offset;
2757 /* Restart all the inner loops we just finished. */
2758 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2760 n = loop->order[dim];
2762 gfc_start_block (&loop->code[n]);
2764 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2766 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2769 /* Start a block for the secondary copying code. */
2770 gfc_start_block (body);
2774 /* Calculate the upper bound of an array section. */
2777 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2786 gcc_assert (ss->type == GFC_SS_SECTION);
2788 info = &ss->data.info;
2791 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2792 /* We'll calculate the upper bound once we have access to the
2793 vector's descriptor. */
2796 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2797 desc = info->descriptor;
2798 end = info->ref->u.ar.end[dim];
2802 /* The upper bound was specified. */
2803 gfc_init_se (&se, NULL);
2804 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2805 gfc_add_block_to_block (pblock, &se.pre);
2810 /* No upper bound was specified, so use the bound of the array. */
2811 bound = gfc_conv_array_ubound (desc, dim);
2818 /* Calculate the lower bound of an array section. */
2821 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2831 gcc_assert (ss->type == GFC_SS_SECTION);
2833 info = &ss->data.info;
2836 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2838 /* We use a zero-based index to access the vector. */
2839 info->start[n] = gfc_index_zero_node;
2840 info->end[n] = gfc_index_zero_node;
2841 info->stride[n] = gfc_index_one_node;
2845 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2846 desc = info->descriptor;
2847 start = info->ref->u.ar.start[dim];
2848 end = info->ref->u.ar.end[dim];
2849 stride = info->ref->u.ar.stride[dim];
2851 /* Calculate the start of the range. For vector subscripts this will
2852 be the range of the vector. */
2855 /* Specified section start. */
2856 gfc_init_se (&se, NULL);
2857 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2858 gfc_add_block_to_block (&loop->pre, &se.pre);
2859 info->start[n] = se.expr;
2863 /* No lower bound specified so use the bound of the array. */
2864 info->start[n] = gfc_conv_array_lbound (desc, dim);
2866 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2868 /* Similarly calculate the end. Although this is not used in the
2869 scalarizer, it is needed when checking bounds and where the end
2870 is an expression with side-effects. */
2873 /* Specified section start. */
2874 gfc_init_se (&se, NULL);
2875 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2876 gfc_add_block_to_block (&loop->pre, &se.pre);
2877 info->end[n] = se.expr;
2881 /* No upper bound specified so use the bound of the array. */
2882 info->end[n] = gfc_conv_array_ubound (desc, dim);
2884 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2886 /* Calculate the stride. */
2888 info->stride[n] = gfc_index_one_node;
2891 gfc_init_se (&se, NULL);
2892 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2893 gfc_add_block_to_block (&loop->pre, &se.pre);
2894 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2899 /* Calculates the range start and stride for a SS chain. Also gets the
2900 descriptor and data pointer. The range of vector subscripts is the size
2901 of the vector. Array bounds are also checked. */
2904 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2912 /* Determine the rank of the loop. */
2914 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2918 case GFC_SS_SECTION:
2919 case GFC_SS_CONSTRUCTOR:
2920 case GFC_SS_FUNCTION:
2921 case GFC_SS_COMPONENT:
2922 loop->dimen = ss->data.info.dimen;
2925 /* As usual, lbound and ubound are exceptions!. */
2926 case GFC_SS_INTRINSIC:
2927 switch (ss->expr->value.function.isym->id)
2929 case GFC_ISYM_LBOUND:
2930 case GFC_ISYM_UBOUND:
2931 loop->dimen = ss->data.info.dimen;
2942 /* We should have determined the rank of the expression by now. If
2943 not, that's bad news. */
2944 gcc_assert (loop->dimen != 0);
2946 /* Loop over all the SS in the chain. */
2947 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2949 if (ss->expr && ss->expr->shape && !ss->shape)
2950 ss->shape = ss->expr->shape;
2954 case GFC_SS_SECTION:
2955 /* Get the descriptor for the array. */
2956 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2958 for (n = 0; n < ss->data.info.dimen; n++)
2959 gfc_conv_section_startstride (loop, ss, n);
2962 case GFC_SS_INTRINSIC:
2963 switch (ss->expr->value.function.isym->id)
2965 /* Fall through to supply start and stride. */
2966 case GFC_ISYM_LBOUND:
2967 case GFC_ISYM_UBOUND:
2973 case GFC_SS_CONSTRUCTOR:
2974 case GFC_SS_FUNCTION:
2975 for (n = 0; n < ss->data.info.dimen; n++)
2977 ss->data.info.start[n] = gfc_index_zero_node;
2978 ss->data.info.end[n] = gfc_index_zero_node;
2979 ss->data.info.stride[n] = gfc_index_one_node;
2988 /* The rest is just runtime bound checking. */
2989 if (flag_bounds_check)
2992 tree lbound, ubound;
2994 tree size[GFC_MAX_DIMENSIONS];
2995 tree stride_pos, stride_neg, non_zerosized, tmp2;
3000 gfc_start_block (&block);
3002 for (n = 0; n < loop->dimen; n++)
3003 size[n] = NULL_TREE;
3005 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3009 if (ss->type != GFC_SS_SECTION)
3012 gfc_start_block (&inner);
3014 /* TODO: range checking for mapped dimensions. */
3015 info = &ss->data.info;
3017 /* This code only checks ranges. Elemental and vector
3018 dimensions are checked later. */
3019 for (n = 0; n < loop->dimen; n++)
3024 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3027 if (dim == info->ref->u.ar.dimen - 1
3028 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3029 || info->ref->u.ar.as->cp_was_assumed))
3030 check_upper = false;
3034 /* Zero stride is not allowed. */
3035 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3036 gfc_index_zero_node);
3037 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3038 "of array '%s'", info->dim[n]+1,
3039 ss->expr->symtree->name);
3040 gfc_trans_runtime_check (true, false, tmp, &inner,
3041 &ss->expr->where, msg);
3044 desc = ss->data.info.descriptor;
3046 /* This is the run-time equivalent of resolve.c's
3047 check_dimension(). The logical is more readable there
3048 than it is here, with all the trees. */
3049 lbound = gfc_conv_array_lbound (desc, dim);
3052 ubound = gfc_conv_array_ubound (desc, dim);
3056 /* non_zerosized is true when the selected range is not
3058 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3059 info->stride[n], gfc_index_zero_node);
3060 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3062 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3065 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3066 info->stride[n], gfc_index_zero_node);
3067 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3069 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3071 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3072 stride_pos, stride_neg);
3074 /* Check the start of the range against the lower and upper
3075 bounds of the array, if the range is not empty. */
3076 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3078 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3079 non_zerosized, tmp);
3080 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3081 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3082 info->dim[n]+1, ss->expr->symtree->name);
3083 gfc_trans_runtime_check (true, false, tmp, &inner,
3084 &ss->expr->where, msg,
3085 fold_convert (long_integer_type_node,
3087 fold_convert (long_integer_type_node,
3093 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3094 info->start[n], ubound);
3095 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3096 non_zerosized, tmp);
3097 asprintf (&msg, "%s, upper bound of dimension %d of array "
3098 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3099 info->dim[n]+1, ss->expr->symtree->name);
3100 gfc_trans_runtime_check (true, false, tmp, &inner,
3101 &ss->expr->where, msg,
3102 fold_convert (long_integer_type_node, info->start[n]),
3103 fold_convert (long_integer_type_node, ubound));
3107 /* Compute the last element of the range, which is not
3108 necessarily "end" (think 0:5:3, which doesn't contain 5)
3109 and check it against both lower and upper bounds. */
3110 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3112 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3114 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3117 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3118 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3119 non_zerosized, tmp);
3120 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3121 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3122 info->dim[n]+1, ss->expr->symtree->name);
3123 gfc_trans_runtime_check (true, false, tmp, &inner,
3124 &ss->expr->where, msg,
3125 fold_convert (long_integer_type_node,
3127 fold_convert (long_integer_type_node,
3133 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3134 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3135 non_zerosized, tmp);
3136 asprintf (&msg, "%s, upper bound of dimension %d of array "
3137 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3138 info->dim[n]+1, ss->expr->symtree->name);
3139 gfc_trans_runtime_check (true, false, tmp, &inner,
3140 &ss->expr->where, msg,
3141 fold_convert (long_integer_type_node, tmp2),
3142 fold_convert (long_integer_type_node, ubound));
3146 /* Check the section sizes match. */
3147 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3149 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3151 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3152 build_int_cst (gfc_array_index_type, 0));
3153 /* We remember the size of the first section, and check all the
3154 others against this. */
3159 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3160 asprintf (&msg, "%s, size mismatch for dimension %d "
3161 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3162 info->dim[n]+1, ss->expr->symtree->name);
3163 gfc_trans_runtime_check (true, false, tmp3, &inner,
3164 &ss->expr->where, msg,
3165 fold_convert (long_integer_type_node, tmp),
3166 fold_convert (long_integer_type_node, size[n]));
3170 size[n] = gfc_evaluate_now (tmp, &inner);
3173 tmp = gfc_finish_block (&inner);
3175 /* For optional arguments, only check bounds if the argument is
3177 if (ss->expr->symtree->n.sym->attr.optional
3178 || ss->expr->symtree->n.sym->attr.not_always_present)
3179 tmp = build3_v (COND_EXPR,
3180 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3181 tmp, build_empty_stmt ());
3183 gfc_add_expr_to_block (&block, tmp);
3187 tmp = gfc_finish_block (&block);
3188 gfc_add_expr_to_block (&loop->pre, tmp);
3193 /* Return true if the two SS could be aliased, i.e. both point to the same data
3195 /* TODO: resolve aliases based on frontend expressions. */
3198 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3205 lsym = lss->expr->symtree->n.sym;
3206 rsym = rss->expr->symtree->n.sym;
3207 if (gfc_symbols_could_alias (lsym, rsym))
3210 if (rsym->ts.type != BT_DERIVED
3211 && lsym->ts.type != BT_DERIVED)
3214 /* For derived types we must check all the component types. We can ignore
3215 array references as these will have the same base type as the previous
3217 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3219 if (lref->type != REF_COMPONENT)
3222 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3225 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3228 if (rref->type != REF_COMPONENT)
3231 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3236 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3238 if (rref->type != REF_COMPONENT)
3241 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3249 /* Resolve array data dependencies. Creates a temporary if required. */
3250 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3254 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3264 loop->temp_ss = NULL;
3265 aref = dest->data.info.ref;
3268 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3270 if (ss->type != GFC_SS_SECTION)
3273 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3275 if (gfc_could_be_alias (dest, ss)
3276 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3284 lref = dest->expr->ref;
3285 rref = ss->expr->ref;
3287 nDepend = gfc_dep_resolver (lref, rref);
3291 /* TODO : loop shifting. */
3294 /* Mark the dimensions for LOOP SHIFTING */
3295 for (n = 0; n < loop->dimen; n++)
3297 int dim = dest->data.info.dim[n];
3299 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3301 else if (! gfc_is_same_range (&lref->u.ar,
3302 &rref->u.ar, dim, 0))
3306 /* Put all the dimensions with dependencies in the
3309 for (n = 0; n < loop->dimen; n++)
3311 gcc_assert (loop->order[n] == n);
3313 loop->order[dim++] = n;
3316 for (n = 0; n < loop->dimen; n++)
3319 loop->order[dim++] = n;
3322 gcc_assert (dim == loop->dimen);
3331 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3332 if (GFC_ARRAY_TYPE_P (base_type)
3333 || GFC_DESCRIPTOR_TYPE_P (base_type))
3334 base_type = gfc_get_element_type (base_type);
3335 loop->temp_ss = gfc_get_ss ();
3336 loop->temp_ss->type = GFC_SS_TEMP;
3337 loop->temp_ss->data.temp.type = base_type;
3338 loop->temp_ss->string_length = dest->string_length;
3339 loop->temp_ss->data.temp.dimen = loop->dimen;
3340 loop->temp_ss->next = gfc_ss_terminator;
3341 gfc_add_ss_to_loop (loop, loop->temp_ss);
3344 loop->temp_ss = NULL;
3348 /* Initialize the scalarization loop. Creates the loop variables. Determines
3349 the range of the loop variables. Creates a temporary if required.
3350 Calculates how to transform from loop variables to array indices for each
3351 expression. Also generates code for scalar expressions which have been
3352 moved outside the loop. */
3355 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3360 gfc_ss_info *specinfo;
3364 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3365 bool dynamic[GFC_MAX_DIMENSIONS];
3371 for (n = 0; n < loop->dimen; n++)
3375 /* We use one SS term, and use that to determine the bounds of the
3376 loop for this dimension. We try to pick the simplest term. */
3377 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3381 /* The frontend has worked out the size for us. */
3386 if (ss->type == GFC_SS_CONSTRUCTOR)
3388 /* An unknown size constructor will always be rank one.
3389 Higher rank constructors will either have known shape,
3390 or still be wrapped in a call to reshape. */
3391 gcc_assert (loop->dimen == 1);
3393 /* Always prefer to use the constructor bounds if the size
3394 can be determined at compile time. Prefer not to otherwise,
3395 since the general case involves realloc, and it's better to
3396 avoid that overhead if possible. */
3397 c = ss->expr->value.constructor;
3398 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3399 if (!dynamic[n] || !loopspec[n])
3404 /* TODO: Pick the best bound if we have a choice between a
3405 function and something else. */
3406 if (ss->type == GFC_SS_FUNCTION)
3412 if (ss->type != GFC_SS_SECTION)
3416 specinfo = &loopspec[n]->data.info;
3419 info = &ss->data.info;
3423 /* Criteria for choosing a loop specifier (most important first):
3424 doesn't need realloc
3430 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3432 else if (integer_onep (info->stride[n])
3433 && !integer_onep (specinfo->stride[n]))
3435 else if (INTEGER_CST_P (info->stride[n])
3436 && !INTEGER_CST_P (specinfo->stride[n]))
3438 else if (INTEGER_CST_P (info->start[n])
3439 && !INTEGER_CST_P (specinfo->start[n]))
3441 /* We don't work out the upper bound.
3442 else if (INTEGER_CST_P (info->finish[n])
3443 && ! INTEGER_CST_P (specinfo->finish[n]))
3444 loopspec[n] = ss; */
3447 /* We should have found the scalarization loop specifier. If not,
3449 gcc_assert (loopspec[n]);
3451 info = &loopspec[n]->data.info;
3453 /* Set the extents of this range. */
3454 cshape = loopspec[n]->shape;
3455 if (cshape && INTEGER_CST_P (info->start[n])
3456 && INTEGER_CST_P (info->stride[n]))
3458 loop->from[n] = info->start[n];
3459 mpz_set (i, cshape[n]);
3460 mpz_sub_ui (i, i, 1);
3461 /* To = from + (size - 1) * stride. */
3462 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3463 if (!integer_onep (info->stride[n]))
3464 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3465 tmp, info->stride[n]);
3466 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3467 loop->from[n], tmp);
3471 loop->from[n] = info->start[n];
3472 switch (loopspec[n]->type)
3474 case GFC_SS_CONSTRUCTOR:
3475 /* The upper bound is calculated when we expand the
3477 gcc_assert (loop->to[n] == NULL_TREE);
3480 case GFC_SS_SECTION:
3481 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3485 case GFC_SS_FUNCTION:
3486 /* The loop bound will be set when we generate the call. */
3487 gcc_assert (loop->to[n] == NULL_TREE);
3495 /* Transform everything so we have a simple incrementing variable. */
3496 if (integer_onep (info->stride[n]))
3497 info->delta[n] = gfc_index_zero_node;
3500 /* Set the delta for this section. */
3501 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3502 /* Number of iterations is (end - start + step) / step.
3503 with start = 0, this simplifies to
3505 for (i = 0; i<=last; i++){...}; */
3506 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3507 loop->to[n], loop->from[n]);
3508 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3509 tmp, info->stride[n]);
3510 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3511 build_int_cst (gfc_array_index_type, -1));
3512 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3513 /* Make the loop variable start at 0. */
3514 loop->from[n] = gfc_index_zero_node;
3518 /* Add all the scalar code that can be taken out of the loops.
3519 This may include calculating the loop bounds, so do it before
3520 allocating the temporary. */
3521 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3523 /* If we want a temporary then create it. */
3524 if (loop->temp_ss != NULL)
3526 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3528 /* Make absolutely sure that this is a complete type. */
3529 if (loop->temp_ss->string_length)
3530 loop->temp_ss->data.temp.type
3531 = gfc_get_character_type_len_for_eltype
3532 (TREE_TYPE (loop->temp_ss->data.temp.type),
3533 loop->temp_ss->string_length);
3535 tmp = loop->temp_ss->data.temp.type;
3536 len = loop->temp_ss->string_length;
3537 n = loop->temp_ss->data.temp.dimen;
3538 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3539 loop->temp_ss->type = GFC_SS_SECTION;
3540 loop->temp_ss->data.info.dimen = n;
3541 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3542 &loop->temp_ss->data.info, tmp, false, true,
3546 for (n = 0; n < loop->temp_dim; n++)
3547 loopspec[loop->order[n]] = NULL;
3551 /* For array parameters we don't have loop variables, so don't calculate the
3553 if (loop->array_parameter)
3556 /* Calculate the translation from loop variables to array indices. */
3557 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3559 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3562 info = &ss->data.info;
3564 for (n = 0; n < info->dimen; n++)
3568 /* If we are specifying the range the delta is already set. */
3569 if (loopspec[n] != ss)
3571 /* Calculate the offset relative to the loop variable.
3572 First multiply by the stride. */
3573 tmp = loop->from[n];
3574 if (!integer_onep (info->stride[n]))
3575 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3576 tmp, info->stride[n]);
3578 /* Then subtract this from our starting value. */
3579 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3580 info->start[n], tmp);
3582 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3589 /* Fills in an array descriptor, and returns the size of the array. The size
3590 will be a simple_val, ie a variable or a constant. Also calculates the
3591 offset of the base. Returns the size of the array.
3595 for (n = 0; n < rank; n++)
3597 a.lbound[n] = specified_lower_bound;
3598 offset = offset + a.lbond[n] * stride;
3600 a.ubound[n] = specified_upper_bound;
3601 a.stride[n] = stride;
3602 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3603 stride = stride * size;
3610 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3611 gfc_expr ** lower, gfc_expr ** upper,
3612 stmtblock_t * pblock)
3624 stmtblock_t thenblock;
3625 stmtblock_t elseblock;
3630 type = TREE_TYPE (descriptor);
3632 stride = gfc_index_one_node;
3633 offset = gfc_index_zero_node;
3635 /* Set the dtype. */
3636 tmp = gfc_conv_descriptor_dtype (descriptor);
3637 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3639 or_expr = NULL_TREE;
3641 for (n = 0; n < rank; n++)
3643 /* We have 3 possibilities for determining the size of the array:
3644 lower == NULL => lbound = 1, ubound = upper[n]
3645 upper[n] = NULL => lbound = 1, ubound = lower[n]
3646 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3649 /* Set lower bound. */
3650 gfc_init_se (&se, NULL);
3652 se.expr = gfc_index_one_node;
3655 gcc_assert (lower[n]);
3658 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3659 gfc_add_block_to_block (pblock, &se.pre);
3663 se.expr = gfc_index_one_node;
3667 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3668 gfc_add_modify (pblock, tmp, se.expr);
3670 /* Work out the offset for this component. */
3671 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3672 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3674 /* Start the calculation for the size of this dimension. */
3675 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3676 gfc_index_one_node, se.expr);
3678 /* Set upper bound. */
3679 gfc_init_se (&se, NULL);
3680 gcc_assert (ubound);
3681 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3682 gfc_add_block_to_block (pblock, &se.pre);
3684 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3685 gfc_add_modify (pblock, tmp, se.expr);
3687 /* Store the stride. */
3688 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3689 gfc_add_modify (pblock, tmp, stride);
3691 /* Calculate the size of this dimension. */
3692 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3694 /* Check whether the size for this dimension is negative. */
3695 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3696 gfc_index_zero_node);
3700 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3702 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3703 gfc_index_zero_node, size);
3705 /* Multiply the stride by the number of elements in this dimension. */
3706 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3707 stride = gfc_evaluate_now (stride, pblock);
3710 /* The stride is the number of elements in the array, so multiply by the
3711 size of an element to get the total size. */
3712 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3713 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3714 fold_convert (gfc_array_index_type, tmp));
3716 if (poffset != NULL)
3718 offset = gfc_evaluate_now (offset, pblock);
3722 if (integer_zerop (or_expr))
3724 if (integer_onep (or_expr))
3725 return gfc_index_zero_node;
3727 var = gfc_create_var (TREE_TYPE (size), "size");
3728 gfc_start_block (&thenblock);
3729 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3730 thencase = gfc_finish_block (&thenblock);
3732 gfc_start_block (&elseblock);
3733 gfc_add_modify (&elseblock, var, size);
3734 elsecase = gfc_finish_block (&elseblock);
3736 tmp = gfc_evaluate_now (or_expr, pblock);
3737 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3738 gfc_add_expr_to_block (pblock, tmp);
3744 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3745 the work for an ALLOCATE statement. */
3749 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3757 gfc_ref *ref, *prev_ref = NULL;
3758 bool allocatable_array;
3762 /* Find the last reference in the chain. */
3763 while (ref && ref->next != NULL)
3765 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3770 if (ref == NULL || ref->type != REF_ARRAY)
3774 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3776 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3778 /* Figure out the size of the array. */
3779 switch (ref->u.ar.type)
3783 upper = ref->u.ar.start;
3787 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3789 lower = ref->u.ar.as->lower;
3790 upper = ref->u.ar.as->upper;
3794 lower = ref->u.ar.start;
3795 upper = ref->u.ar.end;
3803 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3804 lower, upper, &se->pre);
3806 /* Allocate memory to store the data. */
3807 pointer = gfc_conv_descriptor_data_get (se->expr);
3808 STRIP_NOPS (pointer);
3810 /* The allocate_array variants take the old pointer as first argument. */
3811 if (allocatable_array)
3812 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3814 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3815 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3816 gfc_add_expr_to_block (&se->pre, tmp);
3818 tmp = gfc_conv_descriptor_offset (se->expr);
3819 gfc_add_modify (&se->pre, tmp, offset);
3821 if (expr->ts.type == BT_DERIVED
3822 && expr->ts.derived->attr.alloc_comp)
3824 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3825 ref->u.ar.as->rank);
3826 gfc_add_expr_to_block (&se->pre, tmp);
3833 /* Deallocate an array variable. Also used when an allocated variable goes
3838 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3844 gfc_start_block (&block);
3845 /* Get a pointer to the data. */
3846 var = gfc_conv_descriptor_data_get (descriptor);
3849 /* Parameter is the address of the data component. */
3850 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3851 gfc_add_expr_to_block (&block, tmp);
3853 /* Zero the data pointer. */
3854 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3855 var, build_int_cst (TREE_TYPE (var), 0));
3856 gfc_add_expr_to_block (&block, tmp);
3858 return gfc_finish_block (&block);
3862 /* Create an array constructor from an initialization expression.
3863 We assume the frontend already did any expansions and conversions. */
3866 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3873 unsigned HOST_WIDE_INT lo;
3875 VEC(constructor_elt,gc) *v = NULL;
3877 switch (expr->expr_type)
3880 case EXPR_STRUCTURE:
3881 /* A single scalar or derived type value. Create an array with all
3882 elements equal to that value. */
3883 gfc_init_se (&se, NULL);
3885 if (expr->expr_type == EXPR_CONSTANT)
3886 gfc_conv_constant (&se, expr);
3888 gfc_conv_structure (&se, expr, 1);
3890 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3891 gcc_assert (tmp && INTEGER_CST_P (tmp));
3892 hi = TREE_INT_CST_HIGH (tmp);
3893 lo = TREE_INT_CST_LOW (tmp);
3897 /* This will probably eat buckets of memory for large arrays. */
3898 while (hi != 0 || lo != 0)
3900 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3908 /* Create a vector of all the elements. */
3909 for (c = expr->value.constructor; c; c = c->next)
3913 /* Problems occur when we get something like
3914 integer :: a(lots) = (/(i, i=1,lots)/) */
3915 /* TODO: Unexpanded array initializers. */
3917 ("Possible frontend bug: array constructor not expanded");
3919 if (mpz_cmp_si (c->n.offset, 0) != 0)
3920 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3924 if (mpz_cmp_si (c->repeat, 0) != 0)
3928 mpz_set (maxval, c->repeat);
3929 mpz_add (maxval, c->n.offset, maxval);
3930 mpz_sub_ui (maxval, maxval, 1);
3931 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3932 if (mpz_cmp_si (c->n.offset, 0) != 0)
3934 mpz_add_ui (maxval, c->n.offset, 1);
3935 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3938 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3940 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3946 gfc_init_se (&se, NULL);
3947 switch (c->expr->expr_type)
3950 gfc_conv_constant (&se, c->expr);
3951 if (range == NULL_TREE)
3952 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3955 if (index != NULL_TREE)
3956 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3957 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3961 case EXPR_STRUCTURE:
3962 gfc_conv_structure (&se, c->expr, 1);
3963 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3973 return gfc_build_null_descriptor (type);
3979 /* Create a constructor from the list of elements. */
3980 tmp = build_constructor (type, v);
3981 TREE_CONSTANT (tmp) = 1;
3986 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3987 returns the size (in elements) of the array. */
3990 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3991 stmtblock_t * pblock)
4006 size = gfc_index_one_node;
4007 offset = gfc_index_zero_node;
4008 for (dim = 0; dim < as->rank; dim++)
4010 /* Evaluate non-constant array bound expressions. */
4011 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4012 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4014 gfc_init_se (&se, NULL);
4015 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4016 gfc_add_block_to_block (pblock, &se.pre);
4017 gfc_add_modify (pblock, lbound, se.expr);
4019 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4020 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4022 gfc_init_se (&se, NULL);
4023 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4024 gfc_add_block_to_block (pblock, &se.pre);
4025 gfc_add_modify (pblock, ubound, se.expr);
4027 /* The offset of this dimension. offset = offset - lbound * stride. */
4028 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4029 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4031 /* The size of this dimension, and the stride of the next. */
4032 if (dim + 1 < as->rank)
4033 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4035 stride = GFC_TYPE_ARRAY_SIZE (type);
4037 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4039 /* Calculate stride = size * (ubound + 1 - lbound). */
4040 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4041 gfc_index_one_node, lbound);
4042 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4043 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4045 gfc_add_modify (pblock, stride, tmp);
4047 stride = gfc_evaluate_now (tmp, pblock);
4049 /* Make sure that negative size arrays are translated
4050 to being zero size. */
4051 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4052 stride, gfc_index_zero_node);
4053 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4054 stride, gfc_index_zero_node);
4055 gfc_add_modify (pblock, stride, tmp);
4061 gfc_trans_vla_type_sizes (sym, pblock);
4068 /* Generate code to initialize/allocate an array variable. */
4071 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4080 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4082 /* Do nothing for USEd variables. */
4083 if (sym->attr.use_assoc)
4086 type = TREE_TYPE (decl);
4087 gcc_assert (GFC_ARRAY_TYPE_P (type));
4088 onstack = TREE_CODE (type) != POINTER_TYPE;
4090 gfc_start_block (&block);
4092 /* Evaluate character string length. */
4093 if (sym->ts.type == BT_CHARACTER
4094 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4096 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4098 gfc_trans_vla_type_sizes (sym, &block);
4100 /* Emit a DECL_EXPR for this variable, which will cause the
4101 gimplifier to allocate storage, and all that good stuff. */
4102 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4103 gfc_add_expr_to_block (&block, tmp);
4108 gfc_add_expr_to_block (&block, fnbody);
4109 return gfc_finish_block (&block);
4112 type = TREE_TYPE (type);
4114 gcc_assert (!sym->attr.use_assoc);
4115 gcc_assert (!TREE_STATIC (decl));
4116 gcc_assert (!sym->module);
4118 if (sym->ts.type == BT_CHARACTER
4119 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4120 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4122 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4124 /* Don't actually allocate space for Cray Pointees. */
4125 if (sym->attr.cray_pointee)
4127 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4128 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4129 gfc_add_expr_to_block (&block, fnbody);
4130 return gfc_finish_block (&block);
4133 /* The size is the number of elements in the array, so multiply by the
4134 size of an element to get the total size. */
4135 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4136 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4137 fold_convert (gfc_array_index_type, tmp));
4139 /* Allocate memory to hold the data. */
4140 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4141 gfc_add_modify (&block, decl, tmp);
4143 /* Set offset of the array. */
4144 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4145 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4148 /* Automatic arrays should not have initializers. */
4149 gcc_assert (!sym->value);
4151 gfc_add_expr_to_block (&block, fnbody);
4153 /* Free the temporary. */
4154 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4155 gfc_add_expr_to_block (&block, tmp);
4157 return gfc_finish_block (&block);
4161 /* Generate entry and exit code for g77 calling convention arrays. */
4164 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4174 gfc_get_backend_locus (&loc);
4175 gfc_set_backend_locus (&sym->declared_at);
4177 /* Descriptor type. */
4178 parm = sym->backend_decl;
4179 type = TREE_TYPE (parm);
4180 gcc_assert (GFC_ARRAY_TYPE_P (type));
4182 gfc_start_block (&block);
4184 if (sym->ts.type == BT_CHARACTER
4185 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4186 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4188 /* Evaluate the bounds of the array. */
4189 gfc_trans_array_bounds (type, sym, &offset, &block);
4191 /* Set the offset. */
4192 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4193 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4195 /* Set the pointer itself if we aren't using the parameter directly. */
4196 if (TREE_CODE (parm) != PARM_DECL)
4198 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4199 gfc_add_modify (&block, parm, tmp);
4201 stmt = gfc_finish_block (&block);
4203 gfc_set_backend_locus (&loc);
4205 gfc_start_block (&block);
4207 /* Add the initialization code to the start of the function. */
4209 if (sym->attr.optional || sym->attr.not_always_present)
4211 tmp = gfc_conv_expr_present (sym);
4212 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4215 gfc_add_expr_to_block (&block, stmt);
4216 gfc_add_expr_to_block (&block, body);
4218 return gfc_finish_block (&block);
4222 /* Modify the descriptor of an array parameter so that it has the
4223 correct lower bound. Also move the upper bound accordingly.
4224 If the array is not packed, it will be copied into a temporary.
4225 For each dimension we set the new lower and upper bounds. Then we copy the
4226 stride and calculate the offset for this dimension. We also work out
4227 what the stride of a packed array would be, and see it the two match.
4228 If the array need repacking, we set the stride to the values we just
4229 calculated, recalculate the offset and copy the array data.
4230 Code is also added to copy the data back at the end of the function.
4234 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4241 stmtblock_t cleanup;
4249 tree stride, stride2;
4259 /* Do nothing for pointer and allocatable arrays. */
4260 if (sym->attr.pointer || sym->attr.allocatable)
4263 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4264 return gfc_trans_g77_array (sym, body);
4266 gfc_get_backend_locus (&loc);
4267 gfc_set_backend_locus (&sym->declared_at);
4269 /* Descriptor type. */
4270 type = TREE_TYPE (tmpdesc);
4271 gcc_assert (GFC_ARRAY_TYPE_P (type));
4272 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4273 dumdesc = build_fold_indirect_ref (dumdesc);
4274 gfc_start_block (&block);
4276 if (sym->ts.type == BT_CHARACTER
4277 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4278 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4280 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4282 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4283 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4285 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4287 /* For non-constant shape arrays we only check if the first dimension
4288 is contiguous. Repacking higher dimensions wouldn't gain us
4289 anything as we still don't know the array stride. */
4290 partial = gfc_create_var (boolean_type_node, "partial");
4291 TREE_USED (partial) = 1;
4292 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4293 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4294 gfc_add_modify (&block, partial, tmp);
4298 partial = NULL_TREE;
4301 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4302 here, however I think it does the right thing. */
4305 /* Set the first stride. */
4306 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4307 stride = gfc_evaluate_now (stride, &block);
4309 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4310 stride, gfc_index_zero_node);
4311 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4312 gfc_index_one_node, stride);
4313 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4314 gfc_add_modify (&block, stride, tmp);
4316 /* Allow the user to disable array repacking. */
4317 stmt_unpacked = NULL_TREE;
4321 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4322 /* A library call to repack the array if necessary. */
4323 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4324 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4326 stride = gfc_index_one_node;
4328 if (gfc_option.warn_array_temp)
4329 gfc_warning ("Creating array temporary at %L", &loc);
4332 /* This is for the case where the array data is used directly without
4333 calling the repack function. */
4334 if (no_repack || partial != NULL_TREE)
4335 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4337 stmt_packed = NULL_TREE;
4339 /* Assign the data pointer. */
4340 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4342 /* Don't repack unknown shape arrays when the first stride is 1. */
4343 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4344 partial, stmt_packed, stmt_unpacked);
4347 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4348 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4350 offset = gfc_index_zero_node;
4351 size = gfc_index_one_node;
4353 /* Evaluate the bounds of the array. */
4354 for (n = 0; n < sym->as->rank; n++)
4356 if (checkparm || !sym->as->upper[n])
4358 /* Get the bounds of the actual parameter. */
4359 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4360 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4364 dubound = NULL_TREE;
4365 dlbound = NULL_TREE;
4368 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4369 if (!INTEGER_CST_P (lbound))
4371 gfc_init_se (&se, NULL);
4372 gfc_conv_expr_type (&se, sym->as->lower[n],
4373 gfc_array_index_type);
4374 gfc_add_block_to_block (&block, &se.pre);
4375 gfc_add_modify (&block, lbound, se.expr);
4378 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4379 /* Set the desired upper bound. */
4380 if (sym->as->upper[n])
4382 /* We know what we want the upper bound to be. */
4383 if (!INTEGER_CST_P (ubound))
4385 gfc_init_se (&se, NULL);
4386 gfc_conv_expr_type (&se, sym->as->upper[n],
4387 gfc_array_index_type);
4388 gfc_add_block_to_block (&block, &se.pre);
4389 gfc_add_modify (&block, ubound, se.expr);
4392 /* Check the sizes match. */
4395 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4398 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4400 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4402 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4403 asprintf (&msg, "%s for dimension %d of array '%s'",
4404 gfc_msg_bounds, n+1, sym->name);
4405 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4411 /* For assumed shape arrays move the upper bound by the same amount
4412 as the lower bound. */
4413 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4415 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4416 gfc_add_modify (&block, ubound, tmp);
4418 /* The offset of this dimension. offset = offset - lbound * stride. */
4419 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4420 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4422 /* The size of this dimension, and the stride of the next. */
4423 if (n + 1 < sym->as->rank)
4425 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4427 if (no_repack || partial != NULL_TREE)
4430 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4433 /* Figure out the stride if not a known constant. */
4434 if (!INTEGER_CST_P (stride))
4437 stmt_packed = NULL_TREE;
4440 /* Calculate stride = size * (ubound + 1 - lbound). */
4441 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4442 gfc_index_one_node, lbound);
4443 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4445 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4450 /* Assign the stride. */
4451 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4452 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4453 stmt_unpacked, stmt_packed);
4455 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4456 gfc_add_modify (&block, stride, tmp);
4461 stride = GFC_TYPE_ARRAY_SIZE (type);
4463 if (stride && !INTEGER_CST_P (stride))
4465 /* Calculate size = stride * (ubound + 1 - lbound). */
4466 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4467 gfc_index_one_node, lbound);
4468 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4470 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4471 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4472 gfc_add_modify (&block, stride, tmp);
4477 /* Set the offset. */
4478 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4479 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4481 gfc_trans_vla_type_sizes (sym, &block);
4483 stmt = gfc_finish_block (&block);
4485 gfc_start_block (&block);
4487 /* Only do the entry/initialization code if the arg is present. */
4488 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4489 optional_arg = (sym->attr.optional
4490 || (sym->ns->proc_name->attr.entry_master
4491 && sym->attr.dummy));
4494 tmp = gfc_conv_expr_present (sym);
4495 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4497 gfc_add_expr_to_block (&block, stmt);
4499 /* Add the main function body. */
4500 gfc_add_expr_to_block (&block, body);
4505 gfc_start_block (&cleanup);
4507 if (sym->attr.intent != INTENT_IN)
4509 /* Copy the data back. */
4510 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4511 gfc_add_expr_to_block (&cleanup, tmp);
4514 /* Free the temporary. */
4515 tmp = gfc_call_free (tmpdesc);
4516 gfc_add_expr_to_block (&cleanup, tmp);
4518 stmt = gfc_finish_block (&cleanup);
4520 /* Only do the cleanup if the array was repacked. */
4521 tmp = build_fold_indirect_ref (dumdesc);
4522 tmp = gfc_conv_descriptor_data_get (tmp);
4523 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4524 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4528 tmp = gfc_conv_expr_present (sym);
4529 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4531 gfc_add_expr_to_block (&block, stmt);
4533 /* We don't need to free any memory allocated by internal_pack as it will
4534 be freed at the end of the function by pop_context. */
4535 return gfc_finish_block (&block);
4539 /* Calculate the overall offset, including subreferences. */
4541 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4542 bool subref, gfc_expr *expr)
4552 /* If offset is NULL and this is not a subreferenced array, there is
4554 if (offset == NULL_TREE)
4557 offset = gfc_index_zero_node;
4562 tmp = gfc_conv_array_data (desc);
4563 tmp = build_fold_indirect_ref (tmp);
4564 tmp = gfc_build_array_ref (tmp, offset, NULL);
4566 /* Offset the data pointer for pointer assignments from arrays with
4567 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4570 /* Go past the array reference. */
4571 for (ref = expr->ref; ref; ref = ref->next)
4572 if (ref->type == REF_ARRAY &&
4573 ref->u.ar.type != AR_ELEMENT)
4579 /* Calculate the offset for each subsequent subreference. */
4580 for (; ref; ref = ref->next)
4585 field = ref->u.c.component->backend_decl;
4586 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4587 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4588 tmp, field, NULL_TREE);
4592 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4593 gfc_init_se (&start, NULL);
4594 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4595 gfc_add_block_to_block (block, &start.pre);
4596 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4600 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4601 && ref->u.ar.type == AR_ELEMENT);
4603 /* TODO - Add bounds checking. */
4604 stride = gfc_index_one_node;
4605 index = gfc_index_zero_node;
4606 for (n = 0; n < ref->u.ar.dimen; n++)
4611 /* Update the index. */
4612 gfc_init_se (&start, NULL);
4613 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4614 itmp = gfc_evaluate_now (start.expr, block);
4615 gfc_init_se (&start, NULL);
4616 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4617 jtmp = gfc_evaluate_now (start.expr, block);
4618 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4619 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4620 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4621 index = gfc_evaluate_now (index, block);
4623 /* Update the stride. */
4624 gfc_init_se (&start, NULL);
4625 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4626 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4627 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4628 gfc_index_one_node, itmp);
4629 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4630 stride = gfc_evaluate_now (stride, block);
4633 /* Apply the index to obtain the array element. */
4634 tmp = gfc_build_array_ref (tmp, index, NULL);
4644 /* Set the target data pointer. */
4645 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4646 gfc_conv_descriptor_data_set (block, parm, offset);
4650 /* gfc_conv_expr_descriptor needs the character length of elemental
4651 functions before the function is called so that the size of the
4652 temporary can be obtained. The only way to do this is to convert
4653 the expression, mapping onto the actual arguments. */
4655 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4657 gfc_interface_mapping mapping;
4658 gfc_formal_arglist *formal;
4659 gfc_actual_arglist *arg;
4662 formal = expr->symtree->n.sym->formal;
4663 arg = expr->value.function.actual;
4664 gfc_init_interface_mapping (&mapping);
4666 /* Set se = NULL in the calls to the interface mapping, to suppress any
4668 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4673 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4676 gfc_init_se (&tse, NULL);
4678 /* Build the expression for the character length and convert it. */
4679 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4681 gfc_add_block_to_block (&se->pre, &tse.pre);
4682 gfc_add_block_to_block (&se->post, &tse.post);
4683 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4684 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4685 build_int_cst (gfc_charlen_type_node, 0));
4686 expr->ts.cl->backend_decl = tse.expr;
4687 gfc_free_interface_mapping (&mapping);
4691 /* Convert an array for passing as an actual argument. Expressions and
4692 vector subscripts are evaluated and stored in a temporary, which is then
4693 passed. For whole arrays the descriptor is passed. For array sections
4694 a modified copy of the descriptor is passed, but using the original data.
4696 This function is also used for array pointer assignments, and there
4699 - se->want_pointer && !se->direct_byref
4700 EXPR is an actual argument. On exit, se->expr contains a
4701 pointer to the array descriptor.
4703 - !se->want_pointer && !se->direct_byref
4704 EXPR is an actual argument to an intrinsic function or the
4705 left-hand side of a pointer assignment. On exit, se->expr
4706 contains the descriptor for EXPR.
4708 - !se->want_pointer && se->direct_byref
4709 EXPR is the right-hand side of a pointer assignment and
4710 se->expr is the descriptor for the previously-evaluated
4711 left-hand side. The function creates an assignment from
4712 EXPR to se->expr. */
4715 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4728 bool subref_array_target = false;
4730 gcc_assert (ss != gfc_ss_terminator);
4732 /* Special case things we know we can pass easily. */
4733 switch (expr->expr_type)
4736 /* If we have a linear array section, we can pass it directly.
4737 Otherwise we need to copy it into a temporary. */
4739 /* Find the SS for the array section. */
4741 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4742 secss = secss->next;
4744 gcc_assert (secss != gfc_ss_terminator);
4745 info = &secss->data.info;
4747 /* Get the descriptor for the array. */
4748 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4749 desc = info->descriptor;
4751 subref_array_target = se->direct_byref && is_subref_array (expr);
4752 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4753 && !subref_array_target;
4757 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4759 /* Create a new descriptor if the array doesn't have one. */
4762 else if (info->ref->u.ar.type == AR_FULL)
4764 else if (se->direct_byref)
4767 full = gfc_full_array_ref_p (info->ref);
4771 if (se->direct_byref)
4773 /* Copy the descriptor for pointer assignments. */
4774 gfc_add_modify (&se->pre, se->expr, desc);
4776 /* Add any offsets from subreferences. */
4777 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4778 subref_array_target, expr);
4780 else if (se->want_pointer)
4782 /* We pass full arrays directly. This means that pointers and
4783 allocatable arrays should also work. */
4784 se->expr = build_fold_addr_expr (desc);
4791 if (expr->ts.type == BT_CHARACTER)
4792 se->string_length = gfc_get_expr_charlen (expr);
4799 /* A transformational function return value will be a temporary
4800 array descriptor. We still need to go through the scalarizer
4801 to create the descriptor. Elemental functions ar handled as
4802 arbitrary expressions, i.e. copy to a temporary. */
4804 /* Look for the SS for this function. */
4805 while (secss != gfc_ss_terminator
4806 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4807 secss = secss->next;
4809 if (se->direct_byref)
4811 gcc_assert (secss != gfc_ss_terminator);
4813 /* For pointer assignments pass the descriptor directly. */
4815 se->expr = build_fold_addr_expr (se->expr);
4816 gfc_conv_expr (se, expr);
4820 if (secss == gfc_ss_terminator)
4822 /* Elemental function. */
4824 if (expr->ts.type == BT_CHARACTER
4825 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4826 get_elemental_fcn_charlen (expr, se);
4832 /* Transformational function. */
4833 info = &secss->data.info;
4839 /* Constant array constructors don't need a temporary. */
4840 if (ss->type == GFC_SS_CONSTRUCTOR
4841 && expr->ts.type != BT_CHARACTER
4842 && gfc_constant_array_constructor_p (expr->value.constructor))
4845 info = &ss->data.info;
4857 /* Something complicated. Copy it into a temporary. */
4864 gfc_init_loopinfo (&loop);
4866 /* Associate the SS with the loop. */
4867 gfc_add_ss_to_loop (&loop, ss);
4869 /* Tell the scalarizer not to bother creating loop variables, etc. */
4871 loop.array_parameter = 1;
4873 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4874 gcc_assert (!se->direct_byref);
4876 /* Setup the scalarizing loops and bounds. */
4877 gfc_conv_ss_startstride (&loop);
4881 /* Tell the scalarizer to make a temporary. */
4882 loop.temp_ss = gfc_get_ss ();
4883 loop.temp_ss->type = GFC_SS_TEMP;
4884 loop.temp_ss->next = gfc_ss_terminator;
4886 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4887 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4889 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4891 if (expr->ts.type == BT_CHARACTER)
4892 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4894 loop.temp_ss->string_length = NULL;
4896 se->string_length = loop.temp_ss->string_length;
4897 loop.temp_ss->data.temp.dimen = loop.dimen;
4898 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4901 gfc_conv_loop_setup (&loop, & expr->where);
4905 /* Copy into a temporary and pass that. We don't need to copy the data
4906 back because expressions and vector subscripts must be INTENT_IN. */
4907 /* TODO: Optimize passing function return values. */
4911 /* Start the copying loops. */
4912 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4913 gfc_mark_ss_chain_used (ss, 1);
4914 gfc_start_scalarized_body (&loop, &block);
4916 /* Copy each data element. */
4917 gfc_init_se (&lse, NULL);
4918 gfc_copy_loopinfo_to_se (&lse, &loop);
4919 gfc_init_se (&rse, NULL);
4920 gfc_copy_loopinfo_to_se (&rse, &loop);
4922 lse.ss = loop.temp_ss;
4925 gfc_conv_scalarized_array_ref (&lse, NULL);
4926 if (expr->ts.type == BT_CHARACTER)
4928 gfc_conv_expr (&rse, expr);
4929 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4930 rse.expr = build_fold_indirect_ref (rse.expr);
4933 gfc_conv_expr_val (&rse, expr);
4935 gfc_add_block_to_block (&block, &rse.pre);
4936 gfc_add_block_to_block (&block, &lse.pre);
4938 lse.string_length = rse.string_length;
4939 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4940 expr->expr_type == EXPR_VARIABLE);
4941 gfc_add_expr_to_block (&block, tmp);
4943 /* Finish the copying loops. */
4944 gfc_trans_scalarizing_loops (&loop, &block);
4946 desc = loop.temp_ss->data.info.descriptor;
4948 gcc_assert (is_gimple_lvalue (desc));
4950 else if (expr->expr_type == EXPR_FUNCTION)
4952 desc = info->descriptor;
4953 se->string_length = ss->string_length;
4957 /* We pass sections without copying to a temporary. Make a new
4958 descriptor and point it at the section we want. The loop variable
4959 limits will be the limits of the section.
4960 A function may decide to repack the array to speed up access, but
4961 we're not bothered about that here. */
4970 /* Set the string_length for a character array. */
4971 if (expr->ts.type == BT_CHARACTER)
4972 se->string_length = gfc_get_expr_charlen (expr);
4974 desc = info->descriptor;
4975 gcc_assert (secss && secss != gfc_ss_terminator);
4976 if (se->direct_byref)
4978 /* For pointer assignments we fill in the destination. */
4980 parmtype = TREE_TYPE (parm);
4984 /* Otherwise make a new one. */
4985 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4986 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4987 loop.from, loop.to, 0,
4989 parm = gfc_create_var (parmtype, "parm");
4992 offset = gfc_index_zero_node;
4995 /* The following can be somewhat confusing. We have two
4996 descriptors, a new one and the original array.
4997 {parm, parmtype, dim} refer to the new one.
4998 {desc, type, n, secss, loop} refer to the original, which maybe
4999 a descriptorless array.
5000 The bounds of the scalarization are the bounds of the section.
5001 We don't have to worry about numeric overflows when calculating
5002 the offsets because all elements are within the array data. */
5004 /* Set the dtype. */
5005 tmp = gfc_conv_descriptor_dtype (parm);
5006 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5008 /* Set offset for assignments to pointer only to zero if it is not
5010 if (se->direct_byref
5011 && info->ref && info->ref->u.ar.type != AR_FULL)
5012 base = gfc_index_zero_node;
5013 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5014 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5018 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5019 for (n = 0; n < ndim; n++)
5021 stride = gfc_conv_array_stride (desc, n);
5023 /* Work out the offset. */
5025 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5027 gcc_assert (info->subscript[n]
5028 && info->subscript[n]->type == GFC_SS_SCALAR);
5029 start = info->subscript[n]->data.scalar.expr;
5033 /* Check we haven't somehow got out of sync. */
5034 gcc_assert (info->dim[dim] == n);
5036 /* Evaluate and remember the start of the section. */
5037 start = info->start[dim];
5038 stride = gfc_evaluate_now (stride, &loop.pre);
5041 tmp = gfc_conv_array_lbound (desc, n);
5042 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5044 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5045 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5048 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5050 /* For elemental dimensions, we only need the offset. */
5054 /* Vector subscripts need copying and are handled elsewhere. */
5056 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5058 /* Set the new lower bound. */
5059 from = loop.from[dim];
5062 /* If we have an array section or are assigning make sure that
5063 the lower bound is 1. References to the full
5064 array should otherwise keep the original bounds. */
5066 || info->ref->u.ar.type != AR_FULL)
5067 && !integer_onep (from))
5069 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5070 gfc_index_one_node, from);
5071 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5072 from = gfc_index_one_node;
5074 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5075 gfc_add_modify (&loop.pre, tmp, from);
5077 /* Set the new upper bound. */
5078 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5079 gfc_add_modify (&loop.pre, tmp, to);
5081 /* Multiply the stride by the section stride to get the
5083 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5084 stride, info->stride[dim]);
5086 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5088 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5091 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5093 tmp = gfc_conv_array_lbound (desc, n);
5094 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5095 tmp, loop.from[dim]);
5096 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5097 tmp, gfc_conv_array_stride (desc, n));
5098 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5102 /* Store the new stride. */
5103 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5104 gfc_add_modify (&loop.pre, tmp, stride);
5109 if (se->data_not_needed)
5110 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5112 /* Point the data pointer at the first element in the section. */
5113 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5114 subref_array_target, expr);
5116 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5117 && !se->data_not_needed)
5119 /* Set the offset. */
5120 tmp = gfc_conv_descriptor_offset (parm);
5121 gfc_add_modify (&loop.pre, tmp, base);
5125 /* Only the callee knows what the correct offset it, so just set
5127 tmp = gfc_conv_descriptor_offset (parm);
5128 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5133 if (!se->direct_byref)
5135 /* Get a pointer to the new descriptor. */
5136 if (se->want_pointer)
5137 se->expr = build_fold_addr_expr (desc);
5142 gfc_add_block_to_block (&se->pre, &loop.pre);
5143 gfc_add_block_to_block (&se->post, &loop.post);
5145 /* Cleanup the scalarizer. */
5146 gfc_cleanup_loop (&loop);
5150 /* Convert an array for passing as an actual parameter. */
5151 /* TODO: Optimize passing g77 arrays. */
5154 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5155 const gfc_symbol *fsym, const char *proc_name)
5159 tree tmp = NULL_TREE;
5161 tree parent = DECL_CONTEXT (current_function_decl);
5162 bool full_array_var, this_array_result;
5166 full_array_var = (expr->expr_type == EXPR_VARIABLE
5167 && expr->ref->u.ar.type == AR_FULL);
5168 sym = full_array_var ? expr->symtree->n.sym : NULL;
5170 /* The symbol should have an array specification. */
5171 gcc_assert (!sym || sym->as);
5173 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5175 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5176 expr->ts.cl->backend_decl = tmp;
5177 se->string_length = tmp;
5180 /* Is this the result of the enclosing procedure? */
5181 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5182 if (this_array_result
5183 && (sym->backend_decl != current_function_decl)
5184 && (sym->backend_decl != parent))
5185 this_array_result = false;
5187 /* Passing address of the array if it is not pointer or assumed-shape. */
5188 if (full_array_var && g77 && !this_array_result)
5190 tmp = gfc_get_symbol_decl (sym);
5192 if (sym->ts.type == BT_CHARACTER)
5193 se->string_length = sym->ts.cl->backend_decl;
5194 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5195 && !sym->attr.allocatable)
5197 /* Some variables are declared directly, others are declared as
5198 pointers and allocated on the heap. */
5199 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5202 se->expr = build_fold_addr_expr (tmp);
5205 if (sym->attr.allocatable)
5207 if (sym->attr.dummy || sym->attr.result)
5209 gfc_conv_expr_descriptor (se, expr, ss);
5210 se->expr = gfc_conv_array_data (se->expr);
5213 se->expr = gfc_conv_array_data (tmp);
5218 if (this_array_result)
5220 /* Result of the enclosing function. */
5221 gfc_conv_expr_descriptor (se, expr, ss);
5222 se->expr = build_fold_addr_expr (se->expr);
5224 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5225 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5226 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5232 /* Every other type of array. */
5233 se->want_pointer = 1;
5234 gfc_conv_expr_descriptor (se, expr, ss);
5238 /* Deallocate the allocatable components of structures that are
5240 if (expr->ts.type == BT_DERIVED
5241 && expr->ts.derived->attr.alloc_comp
5242 && expr->expr_type != EXPR_VARIABLE)
5244 tmp = build_fold_indirect_ref (se->expr);
5245 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5246 gfc_add_expr_to_block (&se->post, tmp);
5252 /* Repack the array. */
5254 if (gfc_option.warn_array_temp)
5257 gfc_warning ("Creating array temporary at %L for argument '%s'",
5258 &expr->where, fsym->name);
5260 gfc_warning ("Creating array temporary at %L", &expr->where);
5263 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5265 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5267 tmp = gfc_conv_expr_present (sym);
5268 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5269 fold_convert (TREE_TYPE (se->expr), ptr),
5270 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5273 ptr = gfc_evaluate_now (ptr, &se->pre);
5277 if (gfc_option.flag_check_array_temporaries)
5281 if (fsym && proc_name)
5282 asprintf (&msg, "An array temporary was created for argument "
5283 "'%s' of procedure '%s'", fsym->name, proc_name);
5285 asprintf (&msg, "An array temporary was created");
5287 tmp = build_fold_indirect_ref (desc);
5288 tmp = gfc_conv_array_data (tmp);
5289 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5290 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5292 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5293 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5294 gfc_conv_expr_present (sym), tmp);
5296 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5301 gfc_start_block (&block);
5303 /* Copy the data back. */
5304 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5306 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5307 gfc_add_expr_to_block (&block, tmp);
5310 /* Free the temporary. */
5311 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5312 gfc_add_expr_to_block (&block, tmp);
5314 stmt = gfc_finish_block (&block);
5316 gfc_init_block (&block);
5317 /* Only if it was repacked. This code needs to be executed before the
5318 loop cleanup code. */
5319 tmp = build_fold_indirect_ref (desc);
5320 tmp = gfc_conv_array_data (tmp);
5321 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5322 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5324 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5325 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5326 gfc_conv_expr_present (sym), tmp);
5328 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5330 gfc_add_expr_to_block (&block, tmp);
5331 gfc_add_block_to_block (&block, &se->post);
5333 gfc_init_block (&se->post);
5334 gfc_add_block_to_block (&se->post, &block);
5339 /* Generate code to deallocate an array, if it is allocated. */
5342 gfc_trans_dealloc_allocated (tree descriptor)
5348 gfc_start_block (&block);
5350 var = gfc_conv_descriptor_data_get (descriptor);
5353 /* Call array_deallocate with an int * present in the second argument.
5354 Although it is ignored here, it's presence ensures that arrays that
5355 are already deallocated are ignored. */
5356 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5357 gfc_add_expr_to_block (&block, tmp);
5359 /* Zero the data pointer. */
5360 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5361 var, build_int_cst (TREE_TYPE (var), 0));
5362 gfc_add_expr_to_block (&block, tmp);
5364 return gfc_finish_block (&block);
5368 /* This helper function calculates the size in words of a full array. */
5371 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5376 idx = gfc_rank_cst[rank - 1];
5377 nelems = gfc_conv_descriptor_ubound (decl, idx);
5378 tmp = gfc_conv_descriptor_lbound (decl, idx);
5379 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5380 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5381 tmp, gfc_index_one_node);
5382 tmp = gfc_evaluate_now (tmp, block);
5384 nelems = gfc_conv_descriptor_stride (decl, idx);
5385 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5386 return gfc_evaluate_now (tmp, block);
5390 /* Allocate dest to the same size as src, and copy src -> dest. */
5393 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5402 /* If the source is null, set the destination to null. */
5403 gfc_init_block (&block);
5404 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5405 null_data = gfc_finish_block (&block);
5407 gfc_init_block (&block);
5409 nelems = get_full_array_size (&block, src, rank);
5410 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5411 fold_convert (gfc_array_index_type,
5412 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5414 /* Allocate memory to the destination. */
5415 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5417 gfc_conv_descriptor_data_set (&block, dest, tmp);
5419 /* We know the temporary and the value will be the same length,
5420 so can use memcpy. */
5421 tmp = built_in_decls[BUILT_IN_MEMCPY];
5422 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5423 gfc_conv_descriptor_data_get (src), size);
5424 gfc_add_expr_to_block (&block, tmp);
5425 tmp = gfc_finish_block (&block);
5427 /* Null the destination if the source is null; otherwise do
5428 the allocate and copy. */
5429 null_cond = gfc_conv_descriptor_data_get (src);
5430 null_cond = convert (pvoid_type_node, null_cond);
5431 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5432 null_cond, null_pointer_node);
5433 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5437 /* Recursively traverse an object of derived type, generating code to
5438 deallocate, nullify or copy allocatable components. This is the work horse
5439 function for the functions named in this enum. */
5441 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5444 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5445 tree dest, int rank, int purpose)
5449 stmtblock_t fnblock;
5450 stmtblock_t loopbody;
5460 tree null_cond = NULL_TREE;
5462 gfc_init_block (&fnblock);
5464 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5465 decl = build_fold_indirect_ref (decl);
5467 /* If this an array of derived types with allocatable components
5468 build a loop and recursively call this function. */
5469 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5470 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5472 tmp = gfc_conv_array_data (decl);
5473 var = build_fold_indirect_ref (tmp);
5475 /* Get the number of elements - 1 and set the counter. */
5476 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5478 /* Use the descriptor for an allocatable array. Since this
5479 is a full array reference, we only need the descriptor
5480 information from dimension = rank. */
5481 tmp = get_full_array_size (&fnblock, decl, rank);
5482 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5483 tmp, gfc_index_one_node);
5485 null_cond = gfc_conv_descriptor_data_get (decl);
5486 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5487 build_int_cst (TREE_TYPE (null_cond), 0));
5491 /* Otherwise use the TYPE_DOMAIN information. */
5492 tmp = array_type_nelts (TREE_TYPE (decl));
5493 tmp = fold_convert (gfc_array_index_type, tmp);
5496 /* Remember that this is, in fact, the no. of elements - 1. */
5497 nelems = gfc_evaluate_now (tmp, &fnblock);
5498 index = gfc_create_var (gfc_array_index_type, "S");
5500 /* Build the body of the loop. */
5501 gfc_init_block (&loopbody);
5503 vref = gfc_build_array_ref (var, index, NULL);
5505 if (purpose == COPY_ALLOC_COMP)
5507 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5508 gfc_add_expr_to_block (&fnblock, tmp);
5510 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5511 dref = gfc_build_array_ref (tmp, index, NULL);
5512 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5515 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5517 gfc_add_expr_to_block (&loopbody, tmp);
5519 /* Build the loop and return. */
5520 gfc_init_loopinfo (&loop);
5522 loop.from[0] = gfc_index_zero_node;
5523 loop.loopvar[0] = index;
5524 loop.to[0] = nelems;
5525 gfc_trans_scalarizing_loops (&loop, &loopbody);
5526 gfc_add_block_to_block (&fnblock, &loop.pre);
5528 tmp = gfc_finish_block (&fnblock);
5529 if (null_cond != NULL_TREE)
5530 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5535 /* Otherwise, act on the components or recursively call self to
5536 act on a chain of components. */
5537 for (c = der_type->components; c; c = c->next)
5539 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5540 && c->ts.derived->attr.alloc_comp;
5541 cdecl = c->backend_decl;
5542 ctype = TREE_TYPE (cdecl);
5546 case DEALLOCATE_ALLOC_COMP:
5547 /* Do not deallocate the components of ultimate pointer
5549 if (cmp_has_alloc_comps && !c->attr.pointer)
5551 comp = fold_build3 (COMPONENT_REF, ctype,
5552 decl, cdecl, NULL_TREE);
5553 rank = c->as ? c->as->rank : 0;
5554 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5556 gfc_add_expr_to_block (&fnblock, tmp);
5559 if (c->attr.allocatable)
5561 comp = fold_build3 (COMPONENT_REF, ctype,
5562 decl, cdecl, NULL_TREE);
5563 tmp = gfc_trans_dealloc_allocated (comp);
5564 gfc_add_expr_to_block (&fnblock, tmp);
5568 case NULLIFY_ALLOC_COMP:
5569 if (c->attr.pointer)
5571 else if (c->attr.allocatable)
5573 comp = fold_build3 (COMPONENT_REF, ctype,
5574 decl, cdecl, NULL_TREE);
5575 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5577 else if (cmp_has_alloc_comps)
5579 comp = fold_build3 (COMPONENT_REF, ctype,
5580 decl, cdecl, NULL_TREE);
5581 rank = c->as ? c->as->rank : 0;
5582 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5584 gfc_add_expr_to_block (&fnblock, tmp);
5588 case COPY_ALLOC_COMP:
5589 if (c->attr.pointer)
5592 /* We need source and destination components. */
5593 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5594 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5595 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5597 if (c->attr.allocatable && !cmp_has_alloc_comps)
5599 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5600 gfc_add_expr_to_block (&fnblock, tmp);
5603 if (cmp_has_alloc_comps)
5605 rank = c->as ? c->as->rank : 0;
5606 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5607 gfc_add_modify (&fnblock, dcmp, tmp);
5608 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5610 gfc_add_expr_to_block (&fnblock, tmp);
5620 return gfc_finish_block (&fnblock);
5623 /* Recursively traverse an object of derived type, generating code to
5624 nullify allocatable components. */
5627 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5629 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5630 NULLIFY_ALLOC_COMP);
5634 /* Recursively traverse an object of derived type, generating code to
5635 deallocate allocatable components. */
5638 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5640 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5641 DEALLOCATE_ALLOC_COMP);
5645 /* Recursively traverse an object of derived type, generating code to
5646 copy its allocatable components. */
5649 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5651 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5655 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5656 Do likewise, recursively if necessary, with the allocatable components of
5660 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5665 stmtblock_t fnblock;
5668 bool sym_has_alloc_comp;
5670 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5671 && sym->ts.derived->attr.alloc_comp;
5673 /* Make sure the frontend gets these right. */
5674 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5675 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5676 "allocatable attribute or derived type without allocatable "
5679 gfc_init_block (&fnblock);
5681 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5682 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5684 if (sym->ts.type == BT_CHARACTER
5685 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5687 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5688 gfc_trans_vla_type_sizes (sym, &fnblock);
5691 /* Dummy and use associated variables don't need anything special. */
5692 if (sym->attr.dummy || sym->attr.use_assoc)
5694 gfc_add_expr_to_block (&fnblock, body);
5696 return gfc_finish_block (&fnblock);
5699 gfc_get_backend_locus (&loc);
5700 gfc_set_backend_locus (&sym->declared_at);
5701 descriptor = sym->backend_decl;
5703 /* Although static, derived types with default initializers and
5704 allocatable components must not be nulled wholesale; instead they
5705 are treated component by component. */
5706 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5708 /* SAVEd variables are not freed on exit. */
5709 gfc_trans_static_array_pointer (sym);
5713 /* Get the descriptor type. */
5714 type = TREE_TYPE (sym->backend_decl);
5716 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5718 if (!sym->attr.save)
5720 rank = sym->as ? sym->as->rank : 0;
5721 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5722 gfc_add_expr_to_block (&fnblock, tmp);
5725 tmp = gfc_init_default_dt (sym, NULL);
5726 gfc_add_expr_to_block (&fnblock, tmp);
5730 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5732 /* If the backend_decl is not a descriptor, we must have a pointer
5734 descriptor = build_fold_indirect_ref (sym->backend_decl);
5735 type = TREE_TYPE (descriptor);
5738 /* NULLIFY the data pointer. */
5739 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5740 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5742 gfc_add_expr_to_block (&fnblock, body);
5744 gfc_set_backend_locus (&loc);
5746 /* Allocatable arrays need to be freed when they go out of scope.
5747 The allocatable components of pointers must not be touched. */
5748 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5749 && !sym->attr.pointer && !sym->attr.save)
5752 rank = sym->as ? sym->as->rank : 0;
5753 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5754 gfc_add_expr_to_block (&fnblock, tmp);
5757 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5759 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5760 gfc_add_expr_to_block (&fnblock, tmp);
5763 return gfc_finish_block (&fnblock);
5766 /************ Expression Walking Functions ******************/
5768 /* Walk a variable reference.
5770 Possible extension - multiple component subscripts.
5771 x(:,:) = foo%a(:)%b(:)
5773 forall (i=..., j=...)
5774 x(i,j) = foo%a(j)%b(i)
5776 This adds a fair amount of complexity because you need to deal with more
5777 than one ref. Maybe handle in a similar manner to vector subscripts.
5778 Maybe not worth the effort. */
5782 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5790 for (ref = expr->ref; ref; ref = ref->next)
5791 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5794 for (; ref; ref = ref->next)
5796 if (ref->type == REF_SUBSTRING)
5798 newss = gfc_get_ss ();
5799 newss->type = GFC_SS_SCALAR;
5800 newss->expr = ref->u.ss.start;
5804 newss = gfc_get_ss ();
5805 newss->type = GFC_SS_SCALAR;
5806 newss->expr = ref->u.ss.end;
5811 /* We're only interested in array sections from now on. */
5812 if (ref->type != REF_ARRAY)
5819 for (n = 0; n < ar->dimen; n++)
5821 newss = gfc_get_ss ();
5822 newss->type = GFC_SS_SCALAR;
5823 newss->expr = ar->start[n];
5830 newss = gfc_get_ss ();
5831 newss->type = GFC_SS_SECTION;
5834 newss->data.info.dimen = ar->as->rank;
5835 newss->data.info.ref = ref;
5837 /* Make sure array is the same as array(:,:), this way
5838 we don't need to special case all the time. */
5839 ar->dimen = ar->as->rank;
5840 for (n = 0; n < ar->dimen; n++)
5842 newss->data.info.dim[n] = n;
5843 ar->dimen_type[n] = DIMEN_RANGE;
5845 gcc_assert (ar->start[n] == NULL);
5846 gcc_assert (ar->end[n] == NULL);
5847 gcc_assert (ar->stride[n] == NULL);
5853 newss = gfc_get_ss ();
5854 newss->type = GFC_SS_SECTION;
5857 newss->data.info.dimen = 0;
5858 newss->data.info.ref = ref;
5862 /* We add SS chains for all the subscripts in the section. */
5863 for (n = 0; n < ar->dimen; n++)
5867 switch (ar->dimen_type[n])
5870 /* Add SS for elemental (scalar) subscripts. */
5871 gcc_assert (ar->start[n]);
5872 indexss = gfc_get_ss ();
5873 indexss->type = GFC_SS_SCALAR;
5874 indexss->expr = ar->start[n];
5875 indexss->next = gfc_ss_terminator;
5876 indexss->loop_chain = gfc_ss_terminator;
5877 newss->data.info.subscript[n] = indexss;
5881 /* We don't add anything for sections, just remember this
5882 dimension for later. */
5883 newss->data.info.dim[newss->data.info.dimen] = n;
5884 newss->data.info.dimen++;
5888 /* Create a GFC_SS_VECTOR index in which we can store
5889 the vector's descriptor. */
5890 indexss = gfc_get_ss ();
5891 indexss->type = GFC_SS_VECTOR;
5892 indexss->expr = ar->start[n];
5893 indexss->next = gfc_ss_terminator;
5894 indexss->loop_chain = gfc_ss_terminator;
5895 newss->data.info.subscript[n] = indexss;
5896 newss->data.info.dim[newss->data.info.dimen] = n;
5897 newss->data.info.dimen++;
5901 /* We should know what sort of section it is by now. */
5905 /* We should have at least one non-elemental dimension. */
5906 gcc_assert (newss->data.info.dimen > 0);
5911 /* We should know what sort of section it is by now. */
5920 /* Walk an expression operator. If only one operand of a binary expression is
5921 scalar, we must also add the scalar term to the SS chain. */
5924 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5930 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5931 if (expr->value.op.op2 == NULL)
5934 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5936 /* All operands are scalar. Pass back and let the caller deal with it. */
5940 /* All operands require scalarization. */
5941 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5944 /* One of the operands needs scalarization, the other is scalar.
5945 Create a gfc_ss for the scalar expression. */
5946 newss = gfc_get_ss ();
5947 newss->type = GFC_SS_SCALAR;
5950 /* First operand is scalar. We build the chain in reverse order, so
5951 add the scalar SS after the second operand. */
5953 while (head && head->next != ss)
5955 /* Check we haven't somehow broken the chain. */
5959 newss->expr = expr->value.op.op1;
5961 else /* head2 == head */
5963 gcc_assert (head2 == head);
5964 /* Second operand is scalar. */
5965 newss->next = head2;
5967 newss->expr = expr->value.op.op2;
5974 /* Reverse a SS chain. */
5977 gfc_reverse_ss (gfc_ss * ss)
5982 gcc_assert (ss != NULL);
5984 head = gfc_ss_terminator;
5985 while (ss != gfc_ss_terminator)
5988 /* Check we didn't somehow break the chain. */
5989 gcc_assert (next != NULL);
5999 /* Walk the arguments of an elemental function. */
6002 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6010 head = gfc_ss_terminator;
6013 for (; arg; arg = arg->next)
6018 newss = gfc_walk_subexpr (head, arg->expr);
6021 /* Scalar argument. */
6022 newss = gfc_get_ss ();
6024 newss->expr = arg->expr;
6034 while (tail->next != gfc_ss_terminator)
6041 /* If all the arguments are scalar we don't need the argument SS. */
6042 gfc_free_ss_chain (head);
6047 /* Add it onto the existing chain. */
6053 /* Walk a function call. Scalar functions are passed back, and taken out of
6054 scalarization loops. For elemental functions we walk their arguments.
6055 The result of functions returning arrays is stored in a temporary outside
6056 the loop, so that the function is only called once. Hence we do not need
6057 to walk their arguments. */
6060 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6063 gfc_intrinsic_sym *isym;
6066 isym = expr->value.function.isym;
6068 /* Handle intrinsic functions separately. */
6070 return gfc_walk_intrinsic_function (ss, expr, isym);
6072 sym = expr->value.function.esym;
6074 sym = expr->symtree->n.sym;
6076 /* A function that returns arrays. */
6077 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6079 newss = gfc_get_ss ();
6080 newss->type = GFC_SS_FUNCTION;
6083 newss->data.info.dimen = expr->rank;
6087 /* Walk the parameters of an elemental function. For now we always pass
6089 if (sym->attr.elemental)
6090 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6093 /* Scalar functions are OK as these are evaluated outside the scalarization
6094 loop. Pass back and let the caller deal with it. */
6099 /* An array temporary is constructed for array constructors. */
6102 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6107 newss = gfc_get_ss ();
6108 newss->type = GFC_SS_CONSTRUCTOR;
6111 newss->data.info.dimen = expr->rank;
6112 for (n = 0; n < expr->rank; n++)
6113 newss->data.info.dim[n] = n;
6119 /* Walk an expression. Add walked expressions to the head of the SS chain.
6120 A wholly scalar expression will not be added. */
6123 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6127 switch (expr->expr_type)
6130 head = gfc_walk_variable_expr (ss, expr);
6134 head = gfc_walk_op_expr (ss, expr);
6138 head = gfc_walk_function_expr (ss, expr);
6143 case EXPR_STRUCTURE:
6144 /* Pass back and let the caller deal with it. */
6148 head = gfc_walk_array_constructor (ss, expr);
6151 case EXPR_SUBSTRING:
6152 /* Pass back and let the caller deal with it. */
6156 internal_error ("bad expression type during walk (%d)",
6163 /* Entry point for expression walking.
6164 A return value equal to the passed chain means this is
6165 a scalar expression. It is up to the caller to take whatever action is
6166 necessary to translate these. */
6169 gfc_walk_expr (gfc_expr * expr)
6173 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6174 return gfc_reverse_ss (res);