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 if (n < loop->temp_dim)
599 gcc_assert (integer_zerop (loop->from[n]));
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 /* If there is at least one null loop->to[n], it is a callee allocated
647 for (n = 0; n < info->dimen; n++)
648 if (loop->to[n] == NULL_TREE)
654 for (n = 0; n < info->dimen; n++)
656 if (size == NULL_TREE)
658 /* For a callee allocated array express the loop bounds in terms
659 of the descriptor fields. */
661 fold_build2 (MINUS_EXPR, gfc_array_index_type,
662 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
663 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
668 /* Store the stride and bound components in the descriptor. */
669 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
670 gfc_add_modify (pre, tmp, size);
672 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
673 gfc_add_modify (pre, tmp, gfc_index_zero_node);
675 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
676 gfc_add_modify (pre, tmp, loop->to[n]);
678 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
679 loop->to[n], gfc_index_one_node);
681 /* Check whether the size for this dimension is negative. */
682 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
683 gfc_index_zero_node);
684 cond = gfc_evaluate_now (cond, pre);
689 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
691 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
692 size = gfc_evaluate_now (size, pre);
695 /* Get the size of the array. */
697 if (size && !callee_alloc)
699 /* If or_expr is true, then the extent in at least one
700 dimension is zero and the size is set to zero. */
701 size = fold_build3 (COND_EXPR, gfc_array_index_type,
702 or_expr, gfc_index_zero_node, size);
705 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
706 fold_convert (gfc_array_index_type,
707 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
715 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
718 if (info->dimen > loop->temp_dim)
719 loop->temp_dim = info->dimen;
725 /* Generate code to transpose array EXPR by creating a new descriptor
726 in which the dimension specifications have been reversed. */
729 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
731 tree dest, src, dest_index, src_index;
733 gfc_ss_info *dest_info, *src_info;
734 gfc_ss *dest_ss, *src_ss;
740 src_ss = gfc_walk_expr (expr);
743 src_info = &src_ss->data.info;
744 dest_info = &dest_ss->data.info;
745 gcc_assert (dest_info->dimen == 2);
746 gcc_assert (src_info->dimen == 2);
748 /* Get a descriptor for EXPR. */
749 gfc_init_se (&src_se, NULL);
750 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
751 gfc_add_block_to_block (&se->pre, &src_se.pre);
752 gfc_add_block_to_block (&se->post, &src_se.post);
755 /* Allocate a new descriptor for the return value. */
756 dest = gfc_create_var (TREE_TYPE (src), "atmp");
757 dest_info->descriptor = dest;
760 /* Copy across the dtype field. */
761 gfc_add_modify (&se->pre,
762 gfc_conv_descriptor_dtype (dest),
763 gfc_conv_descriptor_dtype (src));
765 /* Copy the dimension information, renumbering dimension 1 to 0 and
767 for (n = 0; n < 2; n++)
769 dest_info->delta[n] = gfc_index_zero_node;
770 dest_info->start[n] = gfc_index_zero_node;
771 dest_info->end[n] = gfc_index_zero_node;
772 dest_info->stride[n] = gfc_index_one_node;
773 dest_info->dim[n] = n;
775 dest_index = gfc_rank_cst[n];
776 src_index = gfc_rank_cst[1 - n];
778 gfc_add_modify (&se->pre,
779 gfc_conv_descriptor_stride (dest, dest_index),
780 gfc_conv_descriptor_stride (src, src_index));
782 gfc_add_modify (&se->pre,
783 gfc_conv_descriptor_lbound (dest, dest_index),
784 gfc_conv_descriptor_lbound (src, src_index));
786 gfc_add_modify (&se->pre,
787 gfc_conv_descriptor_ubound (dest, dest_index),
788 gfc_conv_descriptor_ubound (src, src_index));
792 gcc_assert (integer_zerop (loop->from[n]));
794 fold_build2 (MINUS_EXPR, gfc_array_index_type,
795 gfc_conv_descriptor_ubound (dest, dest_index),
796 gfc_conv_descriptor_lbound (dest, dest_index));
800 /* Copy the data pointer. */
801 dest_info->data = gfc_conv_descriptor_data_get (src);
802 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
804 /* Copy the offset. This is not changed by transposition; the top-left
805 element is still at the same offset as before, except where the loop
807 if (!integer_zerop (loop->from[0]))
808 dest_info->offset = gfc_conv_descriptor_offset (src);
810 dest_info->offset = gfc_index_zero_node;
812 gfc_add_modify (&se->pre,
813 gfc_conv_descriptor_offset (dest),
816 if (dest_info->dimen > loop->temp_dim)
817 loop->temp_dim = dest_info->dimen;
821 /* Return the number of iterations in a loop that starts at START,
822 ends at END, and has step STEP. */
825 gfc_get_iteration_count (tree start, tree end, tree step)
830 type = TREE_TYPE (step);
831 tmp = fold_build2 (MINUS_EXPR, type, end, start);
832 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
833 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
834 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
835 return fold_convert (gfc_array_index_type, tmp);
839 /* Extend the data in array DESC by EXTRA elements. */
842 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
849 if (integer_zerop (extra))
852 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
854 /* Add EXTRA to the upper bound. */
855 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
856 gfc_add_modify (pblock, ubound, tmp);
858 /* Get the value of the current data pointer. */
859 arg0 = gfc_conv_descriptor_data_get (desc);
861 /* Calculate the new array size. */
862 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
863 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
864 ubound, gfc_index_one_node);
865 arg1 = fold_build2 (MULT_EXPR, size_type_node,
866 fold_convert (size_type_node, tmp),
867 fold_convert (size_type_node, size));
869 /* Call the realloc() function. */
870 tmp = gfc_call_realloc (pblock, arg0, arg1);
871 gfc_conv_descriptor_data_set (pblock, desc, tmp);
875 /* Return true if the bounds of iterator I can only be determined
879 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
881 return (i->start->expr_type != EXPR_CONSTANT
882 || i->end->expr_type != EXPR_CONSTANT
883 || i->step->expr_type != EXPR_CONSTANT);
887 /* Split the size of constructor element EXPR into the sum of two terms,
888 one of which can be determined at compile time and one of which must
889 be calculated at run time. Set *SIZE to the former and return true
890 if the latter might be nonzero. */
893 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
895 if (expr->expr_type == EXPR_ARRAY)
896 return gfc_get_array_constructor_size (size, expr->value.constructor);
897 else if (expr->rank > 0)
899 /* Calculate everything at run time. */
900 mpz_set_ui (*size, 0);
905 /* A single element. */
906 mpz_set_ui (*size, 1);
912 /* Like gfc_get_array_constructor_element_size, but applied to the whole
913 of array constructor C. */
916 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
923 mpz_set_ui (*size, 0);
928 for (; c; c = c->next)
931 if (i && gfc_iterator_has_dynamic_bounds (i))
935 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
938 /* Multiply the static part of the element size by the
939 number of iterations. */
940 mpz_sub (val, i->end->value.integer, i->start->value.integer);
941 mpz_fdiv_q (val, val, i->step->value.integer);
942 mpz_add_ui (val, val, 1);
943 if (mpz_sgn (val) > 0)
944 mpz_mul (len, len, val);
948 mpz_add (*size, *size, len);
957 /* Make sure offset is a variable. */
960 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
963 /* We should have already created the offset variable. We cannot
964 create it here because we may be in an inner scope. */
965 gcc_assert (*offsetvar != NULL_TREE);
966 gfc_add_modify (pblock, *offsetvar, *poffset);
967 *poffset = *offsetvar;
968 TREE_USED (*offsetvar) = 1;
972 /* Variables needed for bounds-checking. */
973 static bool first_len;
974 static tree first_len_val;
975 static bool typespec_chararray_ctor;
978 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
979 tree offset, gfc_se * se, gfc_expr * expr)
983 gfc_conv_expr (se, expr);
985 /* Store the value. */
986 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
987 tmp = gfc_build_array_ref (tmp, offset, NULL);
989 if (expr->ts.type == BT_CHARACTER)
991 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
994 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
995 esize = fold_convert (gfc_charlen_type_node, esize);
996 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
997 build_int_cst (gfc_charlen_type_node,
998 gfc_character_kinds[i].bit_size / 8));
1000 gfc_conv_string_parameter (se);
1001 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1003 /* The temporary is an array of pointers. */
1004 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1005 gfc_add_modify (&se->pre, tmp, se->expr);
1009 /* The temporary is an array of string values. */
1010 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1011 /* We know the temporary and the value will be the same length,
1012 so can use memcpy. */
1013 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1014 se->string_length, se->expr, expr->ts.kind);
1016 if (flag_bounds_check && !typespec_chararray_ctor)
1020 gfc_add_modify (&se->pre, first_len_val,
1026 /* Verify that all constructor elements are of the same
1028 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1029 first_len_val, se->string_length);
1030 gfc_trans_runtime_check
1031 (true, false, cond, &se->pre, &expr->where,
1032 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1033 fold_convert (long_integer_type_node, first_len_val),
1034 fold_convert (long_integer_type_node, se->string_length));
1040 /* TODO: Should the frontend already have done this conversion? */
1041 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1042 gfc_add_modify (&se->pre, tmp, se->expr);
1045 gfc_add_block_to_block (pblock, &se->pre);
1046 gfc_add_block_to_block (pblock, &se->post);
1050 /* Add the contents of an array to the constructor. DYNAMIC is as for
1051 gfc_trans_array_constructor_value. */
1054 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1055 tree type ATTRIBUTE_UNUSED,
1056 tree desc, gfc_expr * expr,
1057 tree * poffset, tree * offsetvar,
1068 /* We need this to be a variable so we can increment it. */
1069 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1071 gfc_init_se (&se, NULL);
1073 /* Walk the array expression. */
1074 ss = gfc_walk_expr (expr);
1075 gcc_assert (ss != gfc_ss_terminator);
1077 /* Initialize the scalarizer. */
1078 gfc_init_loopinfo (&loop);
1079 gfc_add_ss_to_loop (&loop, ss);
1081 /* Initialize the loop. */
1082 gfc_conv_ss_startstride (&loop);
1083 gfc_conv_loop_setup (&loop, &expr->where);
1085 /* Make sure the constructed array has room for the new data. */
1088 /* Set SIZE to the total number of elements in the subarray. */
1089 size = gfc_index_one_node;
1090 for (n = 0; n < loop.dimen; n++)
1092 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1093 gfc_index_one_node);
1094 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1097 /* Grow the constructed array by SIZE elements. */
1098 gfc_grow_array (&loop.pre, desc, size);
1101 /* Make the loop body. */
1102 gfc_mark_ss_chain_used (ss, 1);
1103 gfc_start_scalarized_body (&loop, &body);
1104 gfc_copy_loopinfo_to_se (&se, &loop);
1107 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1108 gcc_assert (se.ss == gfc_ss_terminator);
1110 /* Increment the offset. */
1111 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1112 *poffset, gfc_index_one_node);
1113 gfc_add_modify (&body, *poffset, tmp);
1115 /* Finish the loop. */
1116 gfc_trans_scalarizing_loops (&loop, &body);
1117 gfc_add_block_to_block (&loop.pre, &loop.post);
1118 tmp = gfc_finish_block (&loop.pre);
1119 gfc_add_expr_to_block (pblock, tmp);
1121 gfc_cleanup_loop (&loop);
1125 /* Assign the values to the elements of an array constructor. DYNAMIC
1126 is true if descriptor DESC only contains enough data for the static
1127 size calculated by gfc_get_array_constructor_size. When true, memory
1128 for the dynamic parts must be allocated using realloc. */
1131 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1132 tree desc, gfc_constructor * c,
1133 tree * poffset, tree * offsetvar,
1142 for (; c; c = c->next)
1144 /* If this is an iterator or an array, the offset must be a variable. */
1145 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1146 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1148 gfc_start_block (&body);
1150 if (c->expr->expr_type == EXPR_ARRAY)
1152 /* Array constructors can be nested. */
1153 gfc_trans_array_constructor_value (&body, type, desc,
1154 c->expr->value.constructor,
1155 poffset, offsetvar, dynamic);
1157 else if (c->expr->rank > 0)
1159 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1160 poffset, offsetvar, dynamic);
1164 /* This code really upsets the gimplifier so don't bother for now. */
1171 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1178 /* Scalar values. */
1179 gfc_init_se (&se, NULL);
1180 gfc_trans_array_ctor_element (&body, desc, *poffset,
1183 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1184 *poffset, gfc_index_one_node);
1188 /* Collect multiple scalar constants into a constructor. */
1196 /* Count the number of consecutive scalar constants. */
1197 while (p && !(p->iterator
1198 || p->expr->expr_type != EXPR_CONSTANT))
1200 gfc_init_se (&se, NULL);
1201 gfc_conv_constant (&se, p->expr);
1203 /* For constant character array constructors we build
1204 an array of pointers. */
1205 if (p->expr->ts.type == BT_CHARACTER
1206 && POINTER_TYPE_P (type))
1207 se.expr = gfc_build_addr_expr
1208 (gfc_get_pchar_type (p->expr->ts.kind),
1211 list = tree_cons (NULL_TREE, se.expr, list);
1216 bound = build_int_cst (NULL_TREE, n - 1);
1217 /* Create an array type to hold them. */
1218 tmptype = build_range_type (gfc_array_index_type,
1219 gfc_index_zero_node, bound);
1220 tmptype = build_array_type (type, tmptype);
1222 init = build_constructor_from_list (tmptype, nreverse (list));
1223 TREE_CONSTANT (init) = 1;
1224 TREE_STATIC (init) = 1;
1225 /* Create a static variable to hold the data. */
1226 tmp = gfc_create_var (tmptype, "data");
1227 TREE_STATIC (tmp) = 1;
1228 TREE_CONSTANT (tmp) = 1;
1229 TREE_READONLY (tmp) = 1;
1230 DECL_INITIAL (tmp) = init;
1233 /* Use BUILTIN_MEMCPY to assign the values. */
1234 tmp = gfc_conv_descriptor_data_get (desc);
1235 tmp = build_fold_indirect_ref (tmp);
1236 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1237 tmp = build_fold_addr_expr (tmp);
1238 init = build_fold_addr_expr (init);
1240 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1241 bound = build_int_cst (NULL_TREE, n * size);
1242 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1244 gfc_add_expr_to_block (&body, tmp);
1246 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1248 build_int_cst (gfc_array_index_type, n));
1250 if (!INTEGER_CST_P (*poffset))
1252 gfc_add_modify (&body, *offsetvar, *poffset);
1253 *poffset = *offsetvar;
1257 /* The frontend should already have done any expansions possible
1261 /* Pass the code as is. */
1262 tmp = gfc_finish_block (&body);
1263 gfc_add_expr_to_block (pblock, tmp);
1267 /* Build the implied do-loop. */
1277 loopbody = gfc_finish_block (&body);
1279 if (c->iterator->var->symtree->n.sym->backend_decl)
1281 gfc_init_se (&se, NULL);
1282 gfc_conv_expr (&se, c->iterator->var);
1283 gfc_add_block_to_block (pblock, &se.pre);
1288 /* If the iterator appears in a specification expression in
1289 an interface mapping, we need to make a temp for the loop
1290 variable because it is not declared locally. */
1291 loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
1292 loopvar = gfc_create_var (loopvar, "loopvar");
1295 /* Make a temporary, store the current value in that
1296 and return it, once the loop is done. */
1297 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1298 gfc_add_modify (pblock, tmp_loopvar, loopvar);
1300 /* Initialize the loop. */
1301 gfc_init_se (&se, NULL);
1302 gfc_conv_expr_val (&se, c->iterator->start);
1303 gfc_add_block_to_block (pblock, &se.pre);
1304 gfc_add_modify (pblock, loopvar, se.expr);
1306 gfc_init_se (&se, NULL);
1307 gfc_conv_expr_val (&se, c->iterator->end);
1308 gfc_add_block_to_block (pblock, &se.pre);
1309 end = gfc_evaluate_now (se.expr, pblock);
1311 gfc_init_se (&se, NULL);
1312 gfc_conv_expr_val (&se, c->iterator->step);
1313 gfc_add_block_to_block (pblock, &se.pre);
1314 step = gfc_evaluate_now (se.expr, pblock);
1316 /* If this array expands dynamically, and the number of iterations
1317 is not constant, we won't have allocated space for the static
1318 part of C->EXPR's size. Do that now. */
1319 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1321 /* Get the number of iterations. */
1322 tmp = gfc_get_iteration_count (loopvar, end, step);
1324 /* Get the static part of C->EXPR's size. */
1325 gfc_get_array_constructor_element_size (&size, c->expr);
1326 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1328 /* Grow the array by TMP * TMP2 elements. */
1329 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1330 gfc_grow_array (pblock, desc, tmp);
1333 /* Generate the loop body. */
1334 exit_label = gfc_build_label_decl (NULL_TREE);
1335 gfc_start_block (&body);
1337 /* Generate the exit condition. Depending on the sign of
1338 the step variable we have to generate the correct
1340 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1341 build_int_cst (TREE_TYPE (step), 0));
1342 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1343 fold_build2 (GT_EXPR, boolean_type_node,
1345 fold_build2 (LT_EXPR, boolean_type_node,
1347 tmp = build1_v (GOTO_EXPR, exit_label);
1348 TREE_USED (exit_label) = 1;
1349 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1350 gfc_add_expr_to_block (&body, tmp);
1352 /* The main loop body. */
1353 gfc_add_expr_to_block (&body, loopbody);
1355 /* Increase loop variable by step. */
1356 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1357 gfc_add_modify (&body, loopvar, tmp);
1359 /* Finish the loop. */
1360 tmp = gfc_finish_block (&body);
1361 tmp = build1_v (LOOP_EXPR, tmp);
1362 gfc_add_expr_to_block (pblock, tmp);
1364 /* Add the exit label. */
1365 tmp = build1_v (LABEL_EXPR, exit_label);
1366 gfc_add_expr_to_block (pblock, tmp);
1368 /* Restore the original value of the loop counter. */
1369 gfc_add_modify (pblock, loopvar, tmp_loopvar);
1376 /* Figure out the string length of a variable reference expression.
1377 Used by get_array_ctor_strlen. */
1380 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1386 /* Don't bother if we already know the length is a constant. */
1387 if (*len && INTEGER_CST_P (*len))
1390 ts = &expr->symtree->n.sym->ts;
1391 for (ref = expr->ref; ref; ref = ref->next)
1396 /* Array references don't change the string length. */
1400 /* Use the length of the component. */
1401 ts = &ref->u.c.component->ts;
1405 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1406 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1408 mpz_init_set_ui (char_len, 1);
1409 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1410 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1411 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1412 *len = convert (gfc_charlen_type_node, *len);
1413 mpz_clear (char_len);
1417 /* TODO: Substrings are tricky because we can't evaluate the
1418 expression more than once. For now we just give up, and hope
1419 we can figure it out elsewhere. */
1424 *len = ts->cl->backend_decl;
1428 /* A catch-all to obtain the string length for anything that is not a
1429 constant, array or variable. */
1431 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1436 /* Don't bother if we already know the length is a constant. */
1437 if (*len && INTEGER_CST_P (*len))
1440 if (!e->ref && e->ts.cl && e->ts.cl->length
1441 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1444 gfc_conv_const_charlen (e->ts.cl);
1445 *len = e->ts.cl->backend_decl;
1449 /* Otherwise, be brutal even if inefficient. */
1450 ss = gfc_walk_expr (e);
1451 gfc_init_se (&se, NULL);
1453 /* No function call, in case of side effects. */
1454 se.no_function_call = 1;
1455 if (ss == gfc_ss_terminator)
1456 gfc_conv_expr (&se, e);
1458 gfc_conv_expr_descriptor (&se, e, ss);
1460 /* Fix the value. */
1461 *len = gfc_evaluate_now (se.string_length, &se.pre);
1463 gfc_add_block_to_block (block, &se.pre);
1464 gfc_add_block_to_block (block, &se.post);
1466 e->ts.cl->backend_decl = *len;
1471 /* Figure out the string length of a character array constructor.
1472 If len is NULL, don't calculate the length; this happens for recursive calls
1473 when a sub-array-constructor is an element but not at the first position,
1474 so when we're not interested in the length.
1475 Returns TRUE if all elements are character constants. */
1478 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1487 *len = build_int_cstu (gfc_charlen_type_node, 0);
1491 /* Loop over all constructor elements to find out is_const, but in len we
1492 want to store the length of the first, not the last, element. We can
1493 of course exit the loop as soon as is_const is found to be false. */
1494 for (; c && is_const; c = c->next)
1496 switch (c->expr->expr_type)
1499 if (len && !(*len && INTEGER_CST_P (*len)))
1500 *len = build_int_cstu (gfc_charlen_type_node,
1501 c->expr->value.character.length);
1505 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1512 get_array_ctor_var_strlen (c->expr, len);
1518 get_array_ctor_all_strlen (block, c->expr, len);
1522 /* After the first iteration, we don't want the length modified. */
1529 /* Check whether the array constructor C consists entirely of constant
1530 elements, and if so returns the number of those elements, otherwise
1531 return zero. Note, an empty or NULL array constructor returns zero. */
1533 unsigned HOST_WIDE_INT
1534 gfc_constant_array_constructor_p (gfc_constructor * c)
1536 unsigned HOST_WIDE_INT nelem = 0;
1541 || c->expr->rank > 0
1542 || c->expr->expr_type != EXPR_CONSTANT)
1551 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1552 and the tree type of it's elements, TYPE, return a static constant
1553 variable that is compile-time initialized. */
1556 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1558 tree tmptype, list, init, tmp;
1559 HOST_WIDE_INT nelem;
1565 /* First traverse the constructor list, converting the constants
1566 to tree to build an initializer. */
1569 c = expr->value.constructor;
1572 gfc_init_se (&se, NULL);
1573 gfc_conv_constant (&se, c->expr);
1574 if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
1575 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1577 list = tree_cons (NULL_TREE, se.expr, list);
1582 /* Next determine the tree type for the array. We use the gfortran
1583 front-end's gfc_get_nodesc_array_type in order to create a suitable
1584 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1586 memset (&as, 0, sizeof (gfc_array_spec));
1588 as.rank = expr->rank;
1589 as.type = AS_EXPLICIT;
1592 as.lower[0] = gfc_int_expr (0);
1593 as.upper[0] = gfc_int_expr (nelem - 1);
1596 for (i = 0; i < expr->rank; i++)
1598 int tmp = (int) mpz_get_si (expr->shape[i]);
1599 as.lower[i] = gfc_int_expr (0);
1600 as.upper[i] = gfc_int_expr (tmp - 1);
1603 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1605 init = build_constructor_from_list (tmptype, nreverse (list));
1607 TREE_CONSTANT (init) = 1;
1608 TREE_STATIC (init) = 1;
1610 tmp = gfc_create_var (tmptype, "A");
1611 TREE_STATIC (tmp) = 1;
1612 TREE_CONSTANT (tmp) = 1;
1613 TREE_READONLY (tmp) = 1;
1614 DECL_INITIAL (tmp) = init;
1620 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1621 This mostly initializes the scalarizer state info structure with the
1622 appropriate values to directly use the array created by the function
1623 gfc_build_constant_array_constructor. */
1626 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1627 gfc_ss * ss, tree type)
1633 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1635 info = &ss->data.info;
1637 info->descriptor = tmp;
1638 info->data = build_fold_addr_expr (tmp);
1639 info->offset = gfc_index_zero_node;
1641 for (i = 0; i < info->dimen; i++)
1643 info->delta[i] = gfc_index_zero_node;
1644 info->start[i] = gfc_index_zero_node;
1645 info->end[i] = gfc_index_zero_node;
1646 info->stride[i] = gfc_index_one_node;
1650 if (info->dimen > loop->temp_dim)
1651 loop->temp_dim = info->dimen;
1654 /* Helper routine of gfc_trans_array_constructor to determine if the
1655 bounds of the loop specified by LOOP are constant and simple enough
1656 to use with gfc_trans_constant_array_constructor. Returns the
1657 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1660 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1662 tree size = gfc_index_one_node;
1666 for (i = 0; i < loop->dimen; i++)
1668 /* If the bounds aren't constant, return NULL_TREE. */
1669 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1671 if (!integer_zerop (loop->from[i]))
1673 /* Only allow nonzero "from" in one-dimensional arrays. */
1674 if (loop->dimen != 1)
1676 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1677 loop->to[i], loop->from[i]);
1681 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1682 tmp, gfc_index_one_node);
1683 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1690 /* Array constructors are handled by constructing a temporary, then using that
1691 within the scalarization loop. This is not optimal, but seems by far the
1695 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1703 bool old_first_len, old_typespec_chararray_ctor;
1704 tree old_first_len_val;
1706 /* Save the old values for nested checking. */
1707 old_first_len = first_len;
1708 old_first_len_val = first_len_val;
1709 old_typespec_chararray_ctor = typespec_chararray_ctor;
1711 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1712 typespec was given for the array constructor. */
1713 typespec_chararray_ctor = (ss->expr->ts.cl
1714 && ss->expr->ts.cl->length_from_typespec);
1716 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
1717 && !typespec_chararray_ctor)
1719 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1723 ss->data.info.dimen = loop->dimen;
1725 c = ss->expr->value.constructor;
1726 if (ss->expr->ts.type == BT_CHARACTER)
1730 /* get_array_ctor_strlen walks the elements of the constructor, if a
1731 typespec was given, we already know the string length and want the one
1733 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1734 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1738 const_string = false;
1739 gfc_init_se (&length_se, NULL);
1740 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1741 gfc_charlen_type_node);
1742 ss->string_length = length_se.expr;
1743 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1744 gfc_add_block_to_block (&loop->post, &length_se.post);
1747 const_string = get_array_ctor_strlen (&loop->pre, c,
1748 &ss->string_length);
1750 /* Complex character array constructors should have been taken care of
1751 and not end up here. */
1752 gcc_assert (ss->string_length);
1754 ss->expr->ts.cl->backend_decl = ss->string_length;
1756 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1758 type = build_pointer_type (type);
1761 type = gfc_typenode_for_spec (&ss->expr->ts);
1763 /* See if the constructor determines the loop bounds. */
1766 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1768 /* We have a multidimensional parameter. */
1770 for (n = 0; n < ss->expr->rank; n++)
1772 loop->from[n] = gfc_index_zero_node;
1773 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1774 gfc_index_integer_kind);
1775 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1776 loop->to[n], gfc_index_one_node);
1780 if (loop->to[0] == NULL_TREE)
1784 /* We should have a 1-dimensional, zero-based loop. */
1785 gcc_assert (loop->dimen == 1);
1786 gcc_assert (integer_zerop (loop->from[0]));
1788 /* Split the constructor size into a static part and a dynamic part.
1789 Allocate the static size up-front and record whether the dynamic
1790 size might be nonzero. */
1792 dynamic = gfc_get_array_constructor_size (&size, c);
1793 mpz_sub_ui (size, size, 1);
1794 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1798 /* Special case constant array constructors. */
1801 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1804 tree size = constant_array_constructor_loop_size (loop);
1805 if (size && compare_tree_int (size, nelem) == 0)
1807 gfc_trans_constant_array_constructor (loop, ss, type);
1813 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1814 type, dynamic, true, false, where);
1816 desc = ss->data.info.descriptor;
1817 offset = gfc_index_zero_node;
1818 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1819 TREE_NO_WARNING (offsetvar) = 1;
1820 TREE_USED (offsetvar) = 0;
1821 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1822 &offset, &offsetvar, dynamic);
1824 /* If the array grows dynamically, the upper bound of the loop variable
1825 is determined by the array's final upper bound. */
1827 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1829 if (TREE_USED (offsetvar))
1830 pushdecl (offsetvar);
1832 gcc_assert (INTEGER_CST_P (offset));
1834 /* Disable bound checking for now because it's probably broken. */
1835 if (flag_bounds_check)
1842 /* Restore old values of globals. */
1843 first_len = old_first_len;
1844 first_len_val = old_first_len_val;
1845 typespec_chararray_ctor = old_typespec_chararray_ctor;
1849 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1850 called after evaluating all of INFO's vector dimensions. Go through
1851 each such vector dimension and see if we can now fill in any missing
1855 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1864 for (n = 0; n < loop->dimen; n++)
1867 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1868 && loop->to[n] == NULL)
1870 /* Loop variable N indexes vector dimension DIM, and we don't
1871 yet know the upper bound of loop variable N. Set it to the
1872 difference between the vector's upper and lower bounds. */
1873 gcc_assert (loop->from[n] == gfc_index_zero_node);
1874 gcc_assert (info->subscript[dim]
1875 && info->subscript[dim]->type == GFC_SS_VECTOR);
1877 gfc_init_se (&se, NULL);
1878 desc = info->subscript[dim]->data.info.descriptor;
1879 zero = gfc_rank_cst[0];
1880 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1881 gfc_conv_descriptor_ubound (desc, zero),
1882 gfc_conv_descriptor_lbound (desc, zero));
1883 tmp = gfc_evaluate_now (tmp, &loop->pre);
1890 /* Add the pre and post chains for all the scalar expressions in a SS chain
1891 to loop. This is called after the loop parameters have been calculated,
1892 but before the actual scalarizing loops. */
1895 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1901 /* TODO: This can generate bad code if there are ordering dependencies,
1902 e.g., a callee allocated function and an unknown size constructor. */
1903 gcc_assert (ss != NULL);
1905 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1912 /* Scalar expression. Evaluate this now. This includes elemental
1913 dimension indices, but not array section bounds. */
1914 gfc_init_se (&se, NULL);
1915 gfc_conv_expr (&se, ss->expr);
1916 gfc_add_block_to_block (&loop->pre, &se.pre);
1918 if (ss->expr->ts.type != BT_CHARACTER)
1920 /* Move the evaluation of scalar expressions outside the
1921 scalarization loop, except for WHERE assignments. */
1923 se.expr = convert(gfc_array_index_type, se.expr);
1925 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1926 gfc_add_block_to_block (&loop->pre, &se.post);
1929 gfc_add_block_to_block (&loop->post, &se.post);
1931 ss->data.scalar.expr = se.expr;
1932 ss->string_length = se.string_length;
1935 case GFC_SS_REFERENCE:
1936 /* Scalar reference. Evaluate this now. */
1937 gfc_init_se (&se, NULL);
1938 gfc_conv_expr_reference (&se, ss->expr);
1939 gfc_add_block_to_block (&loop->pre, &se.pre);
1940 gfc_add_block_to_block (&loop->post, &se.post);
1942 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1943 ss->string_length = se.string_length;
1946 case GFC_SS_SECTION:
1947 /* Add the expressions for scalar and vector subscripts. */
1948 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1949 if (ss->data.info.subscript[n])
1950 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
1953 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1957 /* Get the vector's descriptor and store it in SS. */
1958 gfc_init_se (&se, NULL);
1959 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1960 gfc_add_block_to_block (&loop->pre, &se.pre);
1961 gfc_add_block_to_block (&loop->post, &se.post);
1962 ss->data.info.descriptor = se.expr;
1965 case GFC_SS_INTRINSIC:
1966 gfc_add_intrinsic_ss_code (loop, ss);
1969 case GFC_SS_FUNCTION:
1970 /* Array function return value. We call the function and save its
1971 result in a temporary for use inside the loop. */
1972 gfc_init_se (&se, NULL);
1975 gfc_conv_expr (&se, ss->expr);
1976 gfc_add_block_to_block (&loop->pre, &se.pre);
1977 gfc_add_block_to_block (&loop->post, &se.post);
1978 ss->string_length = se.string_length;
1981 case GFC_SS_CONSTRUCTOR:
1982 if (ss->expr->ts.type == BT_CHARACTER
1983 && ss->string_length == NULL
1985 && ss->expr->ts.cl->length)
1987 gfc_init_se (&se, NULL);
1988 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
1989 gfc_charlen_type_node);
1990 ss->string_length = se.expr;
1991 gfc_add_block_to_block (&loop->pre, &se.pre);
1992 gfc_add_block_to_block (&loop->post, &se.post);
1994 gfc_trans_array_constructor (loop, ss, where);
1998 case GFC_SS_COMPONENT:
1999 /* Do nothing. These are handled elsewhere. */
2009 /* Translate expressions for the descriptor and data pointer of a SS. */
2013 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2018 /* Get the descriptor for the array to be scalarized. */
2019 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2020 gfc_init_se (&se, NULL);
2021 se.descriptor_only = 1;
2022 gfc_conv_expr_lhs (&se, ss->expr);
2023 gfc_add_block_to_block (block, &se.pre);
2024 ss->data.info.descriptor = se.expr;
2025 ss->string_length = se.string_length;
2029 /* Also the data pointer. */
2030 tmp = gfc_conv_array_data (se.expr);
2031 /* If this is a variable or address of a variable we use it directly.
2032 Otherwise we must evaluate it now to avoid breaking dependency
2033 analysis by pulling the expressions for elemental array indices
2036 || (TREE_CODE (tmp) == ADDR_EXPR
2037 && DECL_P (TREE_OPERAND (tmp, 0)))))
2038 tmp = gfc_evaluate_now (tmp, block);
2039 ss->data.info.data = tmp;
2041 tmp = gfc_conv_array_offset (se.expr);
2042 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2047 /* Initialize a gfc_loopinfo structure. */
2050 gfc_init_loopinfo (gfc_loopinfo * loop)
2054 memset (loop, 0, sizeof (gfc_loopinfo));
2055 gfc_init_block (&loop->pre);
2056 gfc_init_block (&loop->post);
2058 /* Initially scalarize in order. */
2059 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2062 loop->ss = gfc_ss_terminator;
2066 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2070 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2076 /* Return an expression for the data pointer of an array. */
2079 gfc_conv_array_data (tree descriptor)
2083 type = TREE_TYPE (descriptor);
2084 if (GFC_ARRAY_TYPE_P (type))
2086 if (TREE_CODE (type) == POINTER_TYPE)
2090 /* Descriptorless arrays. */
2091 return build_fold_addr_expr (descriptor);
2095 return gfc_conv_descriptor_data_get (descriptor);
2099 /* Return an expression for the base offset of an array. */
2102 gfc_conv_array_offset (tree descriptor)
2106 type = TREE_TYPE (descriptor);
2107 if (GFC_ARRAY_TYPE_P (type))
2108 return GFC_TYPE_ARRAY_OFFSET (type);
2110 return gfc_conv_descriptor_offset (descriptor);
2114 /* Get an expression for the array stride. */
2117 gfc_conv_array_stride (tree descriptor, int dim)
2122 type = TREE_TYPE (descriptor);
2124 /* For descriptorless arrays use the array size. */
2125 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2126 if (tmp != NULL_TREE)
2129 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2134 /* Like gfc_conv_array_stride, but for the lower bound. */
2137 gfc_conv_array_lbound (tree descriptor, int dim)
2142 type = TREE_TYPE (descriptor);
2144 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2145 if (tmp != NULL_TREE)
2148 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2153 /* Like gfc_conv_array_stride, but for the upper bound. */
2156 gfc_conv_array_ubound (tree descriptor, int dim)
2161 type = TREE_TYPE (descriptor);
2163 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2164 if (tmp != NULL_TREE)
2167 /* This should only ever happen when passing an assumed shape array
2168 as an actual parameter. The value will never be used. */
2169 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2170 return gfc_index_zero_node;
2172 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2177 /* Generate code to perform an array index bound check. */
2180 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2181 locus * where, bool check_upper)
2186 const char * name = NULL;
2188 if (!flag_bounds_check)
2191 index = gfc_evaluate_now (index, &se->pre);
2193 /* We find a name for the error message. */
2195 name = se->ss->expr->symtree->name;
2197 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2198 && se->loop->ss->expr->symtree)
2199 name = se->loop->ss->expr->symtree->name;
2201 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2202 && se->loop->ss->loop_chain->expr
2203 && se->loop->ss->loop_chain->expr->symtree)
2204 name = se->loop->ss->loop_chain->expr->symtree->name;
2206 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2207 && se->loop->ss->loop_chain->expr->symtree)
2208 name = se->loop->ss->loop_chain->expr->symtree->name;
2210 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2212 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2213 && se->loop->ss->expr->value.function.name)
2214 name = se->loop->ss->expr->value.function.name;
2216 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2217 || se->loop->ss->type == GFC_SS_SCALAR)
2218 name = "unnamed constant";
2221 /* Check lower bound. */
2222 tmp = gfc_conv_array_lbound (descriptor, n);
2223 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2225 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2226 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2228 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2229 gfc_msg_fault, n+1);
2230 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2231 fold_convert (long_integer_type_node, index),
2232 fold_convert (long_integer_type_node, tmp));
2235 /* Check upper bound. */
2238 tmp = gfc_conv_array_ubound (descriptor, n);
2239 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2241 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2242 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2244 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2245 gfc_msg_fault, n+1);
2246 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2247 fold_convert (long_integer_type_node, index),
2248 fold_convert (long_integer_type_node, tmp));
2256 /* Return the offset for an index. Performs bound checking for elemental
2257 dimensions. Single element references are processed separately. */
2260 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2261 gfc_array_ref * ar, tree stride)
2267 /* Get the index into the array for this dimension. */
2270 gcc_assert (ar->type != AR_ELEMENT);
2271 switch (ar->dimen_type[dim])
2274 /* Elemental dimension. */
2275 gcc_assert (info->subscript[dim]
2276 && info->subscript[dim]->type == GFC_SS_SCALAR);
2277 /* We've already translated this value outside the loop. */
2278 index = info->subscript[dim]->data.scalar.expr;
2280 index = gfc_trans_array_bound_check (se, info->descriptor,
2281 index, dim, &ar->where,
2282 (ar->as->type != AS_ASSUMED_SIZE
2283 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2287 gcc_assert (info && se->loop);
2288 gcc_assert (info->subscript[dim]
2289 && info->subscript[dim]->type == GFC_SS_VECTOR);
2290 desc = info->subscript[dim]->data.info.descriptor;
2292 /* Get a zero-based index into the vector. */
2293 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2294 se->loop->loopvar[i], se->loop->from[i]);
2296 /* Multiply the index by the stride. */
2297 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2298 index, gfc_conv_array_stride (desc, 0));
2300 /* Read the vector to get an index into info->descriptor. */
2301 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2302 index = gfc_build_array_ref (data, index, NULL);
2303 index = gfc_evaluate_now (index, &se->pre);
2305 /* Do any bounds checking on the final info->descriptor index. */
2306 index = gfc_trans_array_bound_check (se, info->descriptor,
2307 index, dim, &ar->where,
2308 (ar->as->type != AS_ASSUMED_SIZE
2309 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2313 /* Scalarized dimension. */
2314 gcc_assert (info && se->loop);
2316 /* Multiply the loop variable by the stride and delta. */
2317 index = se->loop->loopvar[i];
2318 if (!integer_onep (info->stride[i]))
2319 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2321 if (!integer_zerop (info->delta[i]))
2322 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2332 /* Temporary array or derived type component. */
2333 gcc_assert (se->loop);
2334 index = se->loop->loopvar[se->loop->order[i]];
2335 if (!integer_zerop (info->delta[i]))
2336 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2337 index, info->delta[i]);
2340 /* Multiply by the stride. */
2341 if (!integer_onep (stride))
2342 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2348 /* Build a scalarized reference to an array. */
2351 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2354 tree decl = NULL_TREE;
2359 info = &se->ss->data.info;
2361 n = se->loop->order[0];
2365 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2367 /* Add the offset for this dimension to the stored offset for all other
2369 if (!integer_zerop (info->offset))
2370 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2372 if (se->ss->expr && is_subref_array (se->ss->expr))
2373 decl = se->ss->expr->symtree->n.sym->backend_decl;
2375 tmp = build_fold_indirect_ref (info->data);
2376 se->expr = gfc_build_array_ref (tmp, index, decl);
2380 /* Translate access of temporary array. */
2383 gfc_conv_tmp_array_ref (gfc_se * se)
2385 se->string_length = se->ss->string_length;
2386 gfc_conv_scalarized_array_ref (se, NULL);
2390 /* Build an array reference. se->expr already holds the array descriptor.
2391 This should be either a variable, indirect variable reference or component
2392 reference. For arrays which do not have a descriptor, se->expr will be
2394 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2397 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2406 /* Handle scalarized references separately. */
2407 if (ar->type != AR_ELEMENT)
2409 gfc_conv_scalarized_array_ref (se, ar);
2410 gfc_advance_se_ss_chain (se);
2414 index = gfc_index_zero_node;
2416 /* Calculate the offsets from all the dimensions. */
2417 for (n = 0; n < ar->dimen; n++)
2419 /* Calculate the index for this dimension. */
2420 gfc_init_se (&indexse, se);
2421 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2422 gfc_add_block_to_block (&se->pre, &indexse.pre);
2424 if (flag_bounds_check)
2426 /* Check array bounds. */
2430 /* Evaluate the indexse.expr only once. */
2431 indexse.expr = save_expr (indexse.expr);
2434 tmp = gfc_conv_array_lbound (se->expr, n);
2435 cond = fold_build2 (LT_EXPR, boolean_type_node,
2437 asprintf (&msg, "%s for array '%s', "
2438 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2439 gfc_msg_fault, sym->name, n+1);
2440 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2441 fold_convert (long_integer_type_node,
2443 fold_convert (long_integer_type_node, tmp));
2446 /* Upper bound, but not for the last dimension of assumed-size
2448 if (n < ar->dimen - 1
2449 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2451 tmp = gfc_conv_array_ubound (se->expr, n);
2452 cond = fold_build2 (GT_EXPR, boolean_type_node,
2454 asprintf (&msg, "%s for array '%s', "
2455 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2456 gfc_msg_fault, sym->name, n+1);
2457 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2458 fold_convert (long_integer_type_node,
2460 fold_convert (long_integer_type_node, tmp));
2465 /* Multiply the index by the stride. */
2466 stride = gfc_conv_array_stride (se->expr, n);
2467 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2470 /* And add it to the total. */
2471 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2474 tmp = gfc_conv_array_offset (se->expr);
2475 if (!integer_zerop (tmp))
2476 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2478 /* Access the calculated element. */
2479 tmp = gfc_conv_array_data (se->expr);
2480 tmp = build_fold_indirect_ref (tmp);
2481 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2485 /* Generate the code to be executed immediately before entering a
2486 scalarization loop. */
2489 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2490 stmtblock_t * pblock)
2499 /* This code will be executed before entering the scalarization loop
2500 for this dimension. */
2501 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2503 if ((ss->useflags & flag) == 0)
2506 if (ss->type != GFC_SS_SECTION
2507 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2508 && ss->type != GFC_SS_COMPONENT)
2511 info = &ss->data.info;
2513 if (dim >= info->dimen)
2516 if (dim == info->dimen - 1)
2518 /* For the outermost loop calculate the offset due to any
2519 elemental dimensions. It will have been initialized with the
2520 base offset of the array. */
2523 for (i = 0; i < info->ref->u.ar.dimen; i++)
2525 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2528 gfc_init_se (&se, NULL);
2530 se.expr = info->descriptor;
2531 stride = gfc_conv_array_stride (info->descriptor, i);
2532 index = gfc_conv_array_index_offset (&se, info, i, -1,
2535 gfc_add_block_to_block (pblock, &se.pre);
2537 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2538 info->offset, index);
2539 info->offset = gfc_evaluate_now (info->offset, pblock);
2543 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2546 stride = gfc_conv_array_stride (info->descriptor, 0);
2548 /* Calculate the stride of the innermost loop. Hopefully this will
2549 allow the backend optimizers to do their stuff more effectively.
2551 info->stride0 = gfc_evaluate_now (stride, pblock);
2555 /* Add the offset for the previous loop dimension. */
2560 ar = &info->ref->u.ar;
2561 i = loop->order[dim + 1];
2569 gfc_init_se (&se, NULL);
2571 se.expr = info->descriptor;
2572 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2573 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2575 gfc_add_block_to_block (pblock, &se.pre);
2576 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2577 info->offset, index);
2578 info->offset = gfc_evaluate_now (info->offset, pblock);
2581 /* Remember this offset for the second loop. */
2582 if (dim == loop->temp_dim - 1)
2583 info->saved_offset = info->offset;
2588 /* Start a scalarized expression. Creates a scope and declares loop
2592 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2598 gcc_assert (!loop->array_parameter);
2600 for (dim = loop->dimen - 1; dim >= 0; dim--)
2602 n = loop->order[dim];
2604 gfc_start_block (&loop->code[n]);
2606 /* Create the loop variable. */
2607 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2609 if (dim < loop->temp_dim)
2613 /* Calculate values that will be constant within this loop. */
2614 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2616 gfc_start_block (pbody);
2620 /* Generates the actual loop code for a scalarization loop. */
2623 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2624 stmtblock_t * pbody)
2632 loopbody = gfc_finish_block (pbody);
2634 /* Initialize the loopvar. */
2635 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2637 exit_label = gfc_build_label_decl (NULL_TREE);
2639 /* Generate the loop body. */
2640 gfc_init_block (&block);
2642 /* The exit condition. */
2643 cond = fold_build2 (GT_EXPR, boolean_type_node,
2644 loop->loopvar[n], loop->to[n]);
2645 tmp = build1_v (GOTO_EXPR, exit_label);
2646 TREE_USED (exit_label) = 1;
2647 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2648 gfc_add_expr_to_block (&block, tmp);
2650 /* The main body. */
2651 gfc_add_expr_to_block (&block, loopbody);
2653 /* Increment the loopvar. */
2654 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2655 loop->loopvar[n], gfc_index_one_node);
2656 gfc_add_modify (&block, loop->loopvar[n], tmp);
2658 /* Build the loop. */
2659 tmp = gfc_finish_block (&block);
2660 tmp = build1_v (LOOP_EXPR, tmp);
2661 gfc_add_expr_to_block (&loop->code[n], tmp);
2663 /* Add the exit label. */
2664 tmp = build1_v (LABEL_EXPR, exit_label);
2665 gfc_add_expr_to_block (&loop->code[n], tmp);
2669 /* Finishes and generates the loops for a scalarized expression. */
2672 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2677 stmtblock_t *pblock;
2681 /* Generate the loops. */
2682 for (dim = 0; dim < loop->dimen; dim++)
2684 n = loop->order[dim];
2685 gfc_trans_scalarized_loop_end (loop, n, pblock);
2686 loop->loopvar[n] = NULL_TREE;
2687 pblock = &loop->code[n];
2690 tmp = gfc_finish_block (pblock);
2691 gfc_add_expr_to_block (&loop->pre, tmp);
2693 /* Clear all the used flags. */
2694 for (ss = loop->ss; ss; ss = ss->loop_chain)
2699 /* Finish the main body of a scalarized expression, and start the secondary
2703 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2707 stmtblock_t *pblock;
2711 /* We finish as many loops as are used by the temporary. */
2712 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2714 n = loop->order[dim];
2715 gfc_trans_scalarized_loop_end (loop, n, pblock);
2716 loop->loopvar[n] = NULL_TREE;
2717 pblock = &loop->code[n];
2720 /* We don't want to finish the outermost loop entirely. */
2721 n = loop->order[loop->temp_dim - 1];
2722 gfc_trans_scalarized_loop_end (loop, n, pblock);
2724 /* Restore the initial offsets. */
2725 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2727 if ((ss->useflags & 2) == 0)
2730 if (ss->type != GFC_SS_SECTION
2731 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2732 && ss->type != GFC_SS_COMPONENT)
2735 ss->data.info.offset = ss->data.info.saved_offset;
2738 /* Restart all the inner loops we just finished. */
2739 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2741 n = loop->order[dim];
2743 gfc_start_block (&loop->code[n]);
2745 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2747 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2750 /* Start a block for the secondary copying code. */
2751 gfc_start_block (body);
2755 /* Calculate the upper bound of an array section. */
2758 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2767 gcc_assert (ss->type == GFC_SS_SECTION);
2769 info = &ss->data.info;
2772 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2773 /* We'll calculate the upper bound once we have access to the
2774 vector's descriptor. */
2777 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2778 desc = info->descriptor;
2779 end = info->ref->u.ar.end[dim];
2783 /* The upper bound was specified. */
2784 gfc_init_se (&se, NULL);
2785 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2786 gfc_add_block_to_block (pblock, &se.pre);
2791 /* No upper bound was specified, so use the bound of the array. */
2792 bound = gfc_conv_array_ubound (desc, dim);
2799 /* Calculate the lower bound of an array section. */
2802 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2812 gcc_assert (ss->type == GFC_SS_SECTION);
2814 info = &ss->data.info;
2817 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2819 /* We use a zero-based index to access the vector. */
2820 info->start[n] = gfc_index_zero_node;
2821 info->end[n] = gfc_index_zero_node;
2822 info->stride[n] = gfc_index_one_node;
2826 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2827 desc = info->descriptor;
2828 start = info->ref->u.ar.start[dim];
2829 end = info->ref->u.ar.end[dim];
2830 stride = info->ref->u.ar.stride[dim];
2832 /* Calculate the start of the range. For vector subscripts this will
2833 be the range of the vector. */
2836 /* Specified section start. */
2837 gfc_init_se (&se, NULL);
2838 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2839 gfc_add_block_to_block (&loop->pre, &se.pre);
2840 info->start[n] = se.expr;
2844 /* No lower bound specified so use the bound of the array. */
2845 info->start[n] = gfc_conv_array_lbound (desc, dim);
2847 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2849 /* Similarly calculate the end. Although this is not used in the
2850 scalarizer, it is needed when checking bounds and where the end
2851 is an expression with side-effects. */
2854 /* Specified section start. */
2855 gfc_init_se (&se, NULL);
2856 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2857 gfc_add_block_to_block (&loop->pre, &se.pre);
2858 info->end[n] = se.expr;
2862 /* No upper bound specified so use the bound of the array. */
2863 info->end[n] = gfc_conv_array_ubound (desc, dim);
2865 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2867 /* Calculate the stride. */
2869 info->stride[n] = gfc_index_one_node;
2872 gfc_init_se (&se, NULL);
2873 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2874 gfc_add_block_to_block (&loop->pre, &se.pre);
2875 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2880 /* Calculates the range start and stride for a SS chain. Also gets the
2881 descriptor and data pointer. The range of vector subscripts is the size
2882 of the vector. Array bounds are also checked. */
2885 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2893 /* Determine the rank of the loop. */
2895 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2899 case GFC_SS_SECTION:
2900 case GFC_SS_CONSTRUCTOR:
2901 case GFC_SS_FUNCTION:
2902 case GFC_SS_COMPONENT:
2903 loop->dimen = ss->data.info.dimen;
2906 /* As usual, lbound and ubound are exceptions!. */
2907 case GFC_SS_INTRINSIC:
2908 switch (ss->expr->value.function.isym->id)
2910 case GFC_ISYM_LBOUND:
2911 case GFC_ISYM_UBOUND:
2912 loop->dimen = ss->data.info.dimen;
2923 /* We should have determined the rank of the expression by now. If
2924 not, that's bad news. */
2925 gcc_assert (loop->dimen != 0);
2927 /* Loop over all the SS in the chain. */
2928 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2930 if (ss->expr && ss->expr->shape && !ss->shape)
2931 ss->shape = ss->expr->shape;
2935 case GFC_SS_SECTION:
2936 /* Get the descriptor for the array. */
2937 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2939 for (n = 0; n < ss->data.info.dimen; n++)
2940 gfc_conv_section_startstride (loop, ss, n);
2943 case GFC_SS_INTRINSIC:
2944 switch (ss->expr->value.function.isym->id)
2946 /* Fall through to supply start and stride. */
2947 case GFC_ISYM_LBOUND:
2948 case GFC_ISYM_UBOUND:
2954 case GFC_SS_CONSTRUCTOR:
2955 case GFC_SS_FUNCTION:
2956 for (n = 0; n < ss->data.info.dimen; n++)
2958 ss->data.info.start[n] = gfc_index_zero_node;
2959 ss->data.info.end[n] = gfc_index_zero_node;
2960 ss->data.info.stride[n] = gfc_index_one_node;
2969 /* The rest is just runtime bound checking. */
2970 if (flag_bounds_check)
2973 tree lbound, ubound;
2975 tree size[GFC_MAX_DIMENSIONS];
2976 tree stride_pos, stride_neg, non_zerosized, tmp2;
2981 gfc_start_block (&block);
2983 for (n = 0; n < loop->dimen; n++)
2984 size[n] = NULL_TREE;
2986 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2990 if (ss->type != GFC_SS_SECTION)
2993 gfc_start_block (&inner);
2995 /* TODO: range checking for mapped dimensions. */
2996 info = &ss->data.info;
2998 /* This code only checks ranges. Elemental and vector
2999 dimensions are checked later. */
3000 for (n = 0; n < loop->dimen; n++)
3005 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3008 if (dim == info->ref->u.ar.dimen - 1
3009 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3010 || info->ref->u.ar.as->cp_was_assumed))
3011 check_upper = false;
3015 /* Zero stride is not allowed. */
3016 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3017 gfc_index_zero_node);
3018 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3019 "of array '%s'", info->dim[n]+1,
3020 ss->expr->symtree->name);
3021 gfc_trans_runtime_check (true, false, tmp, &inner,
3022 &ss->expr->where, msg);
3025 desc = ss->data.info.descriptor;
3027 /* This is the run-time equivalent of resolve.c's
3028 check_dimension(). The logical is more readable there
3029 than it is here, with all the trees. */
3030 lbound = gfc_conv_array_lbound (desc, dim);
3033 ubound = gfc_conv_array_ubound (desc, dim);
3037 /* non_zerosized is true when the selected range is not
3039 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3040 info->stride[n], gfc_index_zero_node);
3041 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3043 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3046 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3047 info->stride[n], gfc_index_zero_node);
3048 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3050 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3052 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3053 stride_pos, stride_neg);
3055 /* Check the start of the range against the lower and upper
3056 bounds of the array, if the range is not empty. */
3057 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3059 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3060 non_zerosized, tmp);
3061 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3062 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3063 info->dim[n]+1, ss->expr->symtree->name);
3064 gfc_trans_runtime_check (true, false, tmp, &inner,
3065 &ss->expr->where, msg,
3066 fold_convert (long_integer_type_node,
3068 fold_convert (long_integer_type_node,
3074 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3075 info->start[n], ubound);
3076 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3077 non_zerosized, tmp);
3078 asprintf (&msg, "%s, upper bound of dimension %d of array "
3079 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3080 info->dim[n]+1, ss->expr->symtree->name);
3081 gfc_trans_runtime_check (true, false, tmp, &inner,
3082 &ss->expr->where, msg,
3083 fold_convert (long_integer_type_node, info->start[n]),
3084 fold_convert (long_integer_type_node, ubound));
3088 /* Compute the last element of the range, which is not
3089 necessarily "end" (think 0:5:3, which doesn't contain 5)
3090 and check it against both lower and upper bounds. */
3091 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3093 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3095 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3098 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3099 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3100 non_zerosized, tmp);
3101 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3102 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3103 info->dim[n]+1, ss->expr->symtree->name);
3104 gfc_trans_runtime_check (true, false, tmp, &inner,
3105 &ss->expr->where, msg,
3106 fold_convert (long_integer_type_node,
3108 fold_convert (long_integer_type_node,
3114 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3115 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3116 non_zerosized, tmp);
3117 asprintf (&msg, "%s, upper bound of dimension %d of array "
3118 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3119 info->dim[n]+1, ss->expr->symtree->name);
3120 gfc_trans_runtime_check (true, false, tmp, &inner,
3121 &ss->expr->where, msg,
3122 fold_convert (long_integer_type_node, tmp2),
3123 fold_convert (long_integer_type_node, ubound));
3127 /* Check the section sizes match. */
3128 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3130 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3132 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3133 build_int_cst (gfc_array_index_type, 0));
3134 /* We remember the size of the first section, and check all the
3135 others against this. */
3140 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3141 asprintf (&msg, "%s, size mismatch for dimension %d "
3142 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3143 info->dim[n]+1, ss->expr->symtree->name);
3144 gfc_trans_runtime_check (true, false, tmp3, &inner,
3145 &ss->expr->where, msg,
3146 fold_convert (long_integer_type_node, tmp),
3147 fold_convert (long_integer_type_node, size[n]));
3151 size[n] = gfc_evaluate_now (tmp, &inner);
3154 tmp = gfc_finish_block (&inner);
3156 /* For optional arguments, only check bounds if the argument is
3158 if (ss->expr->symtree->n.sym->attr.optional
3159 || ss->expr->symtree->n.sym->attr.not_always_present)
3160 tmp = build3_v (COND_EXPR,
3161 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3162 tmp, build_empty_stmt ());
3164 gfc_add_expr_to_block (&block, tmp);
3168 tmp = gfc_finish_block (&block);
3169 gfc_add_expr_to_block (&loop->pre, tmp);
3174 /* Return true if the two SS could be aliased, i.e. both point to the same data
3176 /* TODO: resolve aliases based on frontend expressions. */
3179 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3186 lsym = lss->expr->symtree->n.sym;
3187 rsym = rss->expr->symtree->n.sym;
3188 if (gfc_symbols_could_alias (lsym, rsym))
3191 if (rsym->ts.type != BT_DERIVED
3192 && lsym->ts.type != BT_DERIVED)
3195 /* For derived types we must check all the component types. We can ignore
3196 array references as these will have the same base type as the previous
3198 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3200 if (lref->type != REF_COMPONENT)
3203 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3206 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3209 if (rref->type != REF_COMPONENT)
3212 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3217 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3219 if (rref->type != REF_COMPONENT)
3222 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3230 /* Resolve array data dependencies. Creates a temporary if required. */
3231 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3235 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3245 loop->temp_ss = NULL;
3246 aref = dest->data.info.ref;
3249 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3251 if (ss->type != GFC_SS_SECTION)
3254 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3256 if (gfc_could_be_alias (dest, ss)
3257 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3265 lref = dest->expr->ref;
3266 rref = ss->expr->ref;
3268 nDepend = gfc_dep_resolver (lref, rref);
3272 /* TODO : loop shifting. */
3275 /* Mark the dimensions for LOOP SHIFTING */
3276 for (n = 0; n < loop->dimen; n++)
3278 int dim = dest->data.info.dim[n];
3280 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3282 else if (! gfc_is_same_range (&lref->u.ar,
3283 &rref->u.ar, dim, 0))
3287 /* Put all the dimensions with dependencies in the
3290 for (n = 0; n < loop->dimen; n++)
3292 gcc_assert (loop->order[n] == n);
3294 loop->order[dim++] = n;
3297 for (n = 0; n < loop->dimen; n++)
3300 loop->order[dim++] = n;
3303 gcc_assert (dim == loop->dimen);
3312 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3313 if (GFC_ARRAY_TYPE_P (base_type)
3314 || GFC_DESCRIPTOR_TYPE_P (base_type))
3315 base_type = gfc_get_element_type (base_type);
3316 loop->temp_ss = gfc_get_ss ();
3317 loop->temp_ss->type = GFC_SS_TEMP;
3318 loop->temp_ss->data.temp.type = base_type;
3319 loop->temp_ss->string_length = dest->string_length;
3320 loop->temp_ss->data.temp.dimen = loop->dimen;
3321 loop->temp_ss->next = gfc_ss_terminator;
3322 gfc_add_ss_to_loop (loop, loop->temp_ss);
3325 loop->temp_ss = NULL;
3329 /* Initialize the scalarization loop. Creates the loop variables. Determines
3330 the range of the loop variables. Creates a temporary if required.
3331 Calculates how to transform from loop variables to array indices for each
3332 expression. Also generates code for scalar expressions which have been
3333 moved outside the loop. */
3336 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3341 gfc_ss_info *specinfo;
3345 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3346 bool dynamic[GFC_MAX_DIMENSIONS];
3352 for (n = 0; n < loop->dimen; n++)
3356 /* We use one SS term, and use that to determine the bounds of the
3357 loop for this dimension. We try to pick the simplest term. */
3358 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3362 /* The frontend has worked out the size for us. */
3363 if (!loopspec[n] || !loopspec[n]->shape
3364 || !integer_zerop (loopspec[n]->data.info.start[n]))
3365 /* Prefer zero-based descriptors if possible. */
3370 if (ss->type == GFC_SS_CONSTRUCTOR)
3372 /* An unknown size constructor will always be rank one.
3373 Higher rank constructors will either have known shape,
3374 or still be wrapped in a call to reshape. */
3375 gcc_assert (loop->dimen == 1);
3377 /* Always prefer to use the constructor bounds if the size
3378 can be determined at compile time. Prefer not to otherwise,
3379 since the general case involves realloc, and it's better to
3380 avoid that overhead if possible. */
3381 c = ss->expr->value.constructor;
3382 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3383 if (!dynamic[n] || !loopspec[n])
3388 /* TODO: Pick the best bound if we have a choice between a
3389 function and something else. */
3390 if (ss->type == GFC_SS_FUNCTION)
3396 if (ss->type != GFC_SS_SECTION)
3400 specinfo = &loopspec[n]->data.info;
3403 info = &ss->data.info;
3407 /* Criteria for choosing a loop specifier (most important first):
3408 doesn't need realloc
3414 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3416 else if (integer_onep (info->stride[n])
3417 && !integer_onep (specinfo->stride[n]))
3419 else if (INTEGER_CST_P (info->stride[n])
3420 && !INTEGER_CST_P (specinfo->stride[n]))
3422 else if (INTEGER_CST_P (info->start[n])
3423 && !INTEGER_CST_P (specinfo->start[n]))
3425 /* We don't work out the upper bound.
3426 else if (INTEGER_CST_P (info->finish[n])
3427 && ! INTEGER_CST_P (specinfo->finish[n]))
3428 loopspec[n] = ss; */
3431 /* We should have found the scalarization loop specifier. If not,
3433 gcc_assert (loopspec[n]);
3435 info = &loopspec[n]->data.info;
3437 /* Set the extents of this range. */
3438 cshape = loopspec[n]->shape;
3439 if (cshape && INTEGER_CST_P (info->start[n])
3440 && INTEGER_CST_P (info->stride[n]))
3442 loop->from[n] = info->start[n];
3443 mpz_set (i, cshape[n]);
3444 mpz_sub_ui (i, i, 1);
3445 /* To = from + (size - 1) * stride. */
3446 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3447 if (!integer_onep (info->stride[n]))
3448 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3449 tmp, info->stride[n]);
3450 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3451 loop->from[n], tmp);
3455 loop->from[n] = info->start[n];
3456 switch (loopspec[n]->type)
3458 case GFC_SS_CONSTRUCTOR:
3459 /* The upper bound is calculated when we expand the
3461 gcc_assert (loop->to[n] == NULL_TREE);
3464 case GFC_SS_SECTION:
3465 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3469 case GFC_SS_FUNCTION:
3470 /* The loop bound will be set when we generate the call. */
3471 gcc_assert (loop->to[n] == NULL_TREE);
3479 /* Transform everything so we have a simple incrementing variable. */
3480 if (integer_onep (info->stride[n]))
3481 info->delta[n] = gfc_index_zero_node;
3484 /* Set the delta for this section. */
3485 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3486 /* Number of iterations is (end - start + step) / step.
3487 with start = 0, this simplifies to
3489 for (i = 0; i<=last; i++){...}; */
3490 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3491 loop->to[n], loop->from[n]);
3492 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3493 tmp, info->stride[n]);
3494 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3495 build_int_cst (gfc_array_index_type, -1));
3496 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3497 /* Make the loop variable start at 0. */
3498 loop->from[n] = gfc_index_zero_node;
3502 /* Add all the scalar code that can be taken out of the loops.
3503 This may include calculating the loop bounds, so do it before
3504 allocating the temporary. */
3505 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3507 /* If we want a temporary then create it. */
3508 if (loop->temp_ss != NULL)
3510 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3512 /* Make absolutely sure that this is a complete type. */
3513 if (loop->temp_ss->string_length)
3514 loop->temp_ss->data.temp.type
3515 = gfc_get_character_type_len_for_eltype
3516 (TREE_TYPE (loop->temp_ss->data.temp.type),
3517 loop->temp_ss->string_length);
3519 tmp = loop->temp_ss->data.temp.type;
3520 len = loop->temp_ss->string_length;
3521 n = loop->temp_ss->data.temp.dimen;
3522 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3523 loop->temp_ss->type = GFC_SS_SECTION;
3524 loop->temp_ss->data.info.dimen = n;
3525 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3526 &loop->temp_ss->data.info, tmp, false, true,
3530 for (n = 0; n < loop->temp_dim; n++)
3531 loopspec[loop->order[n]] = NULL;
3535 /* For array parameters we don't have loop variables, so don't calculate the
3537 if (loop->array_parameter)
3540 /* Calculate the translation from loop variables to array indices. */
3541 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3543 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3544 && ss->type != GFC_SS_CONSTRUCTOR)
3548 info = &ss->data.info;
3550 for (n = 0; n < info->dimen; n++)
3554 /* If we are specifying the range the delta is already set. */
3555 if (loopspec[n] != ss)
3557 /* Calculate the offset relative to the loop variable.
3558 First multiply by the stride. */
3559 tmp = loop->from[n];
3560 if (!integer_onep (info->stride[n]))
3561 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3562 tmp, info->stride[n]);
3564 /* Then subtract this from our starting value. */
3565 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3566 info->start[n], tmp);
3568 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3575 /* Fills in an array descriptor, and returns the size of the array. The size
3576 will be a simple_val, ie a variable or a constant. Also calculates the
3577 offset of the base. Returns the size of the array.
3581 for (n = 0; n < rank; n++)
3583 a.lbound[n] = specified_lower_bound;
3584 offset = offset + a.lbond[n] * stride;
3586 a.ubound[n] = specified_upper_bound;
3587 a.stride[n] = stride;
3588 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3589 stride = stride * size;
3596 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3597 gfc_expr ** lower, gfc_expr ** upper,
3598 stmtblock_t * pblock)
3610 stmtblock_t thenblock;
3611 stmtblock_t elseblock;
3616 type = TREE_TYPE (descriptor);
3618 stride = gfc_index_one_node;
3619 offset = gfc_index_zero_node;
3621 /* Set the dtype. */
3622 tmp = gfc_conv_descriptor_dtype (descriptor);
3623 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3625 or_expr = NULL_TREE;
3627 for (n = 0; n < rank; n++)
3629 /* We have 3 possibilities for determining the size of the array:
3630 lower == NULL => lbound = 1, ubound = upper[n]
3631 upper[n] = NULL => lbound = 1, ubound = lower[n]
3632 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3635 /* Set lower bound. */
3636 gfc_init_se (&se, NULL);
3638 se.expr = gfc_index_one_node;
3641 gcc_assert (lower[n]);
3644 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3645 gfc_add_block_to_block (pblock, &se.pre);
3649 se.expr = gfc_index_one_node;
3653 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3654 gfc_add_modify (pblock, tmp, se.expr);
3656 /* Work out the offset for this component. */
3657 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3658 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3660 /* Start the calculation for the size of this dimension. */
3661 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3662 gfc_index_one_node, se.expr);
3664 /* Set upper bound. */
3665 gfc_init_se (&se, NULL);
3666 gcc_assert (ubound);
3667 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3668 gfc_add_block_to_block (pblock, &se.pre);
3670 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3671 gfc_add_modify (pblock, tmp, se.expr);
3673 /* Store the stride. */
3674 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3675 gfc_add_modify (pblock, tmp, stride);
3677 /* Calculate the size of this dimension. */
3678 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3680 /* Check whether the size for this dimension is negative. */
3681 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3682 gfc_index_zero_node);
3686 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3688 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3689 gfc_index_zero_node, size);
3691 /* Multiply the stride by the number of elements in this dimension. */
3692 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3693 stride = gfc_evaluate_now (stride, pblock);
3696 /* The stride is the number of elements in the array, so multiply by the
3697 size of an element to get the total size. */
3698 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3699 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3700 fold_convert (gfc_array_index_type, tmp));
3702 if (poffset != NULL)
3704 offset = gfc_evaluate_now (offset, pblock);
3708 if (integer_zerop (or_expr))
3710 if (integer_onep (or_expr))
3711 return gfc_index_zero_node;
3713 var = gfc_create_var (TREE_TYPE (size), "size");
3714 gfc_start_block (&thenblock);
3715 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3716 thencase = gfc_finish_block (&thenblock);
3718 gfc_start_block (&elseblock);
3719 gfc_add_modify (&elseblock, var, size);
3720 elsecase = gfc_finish_block (&elseblock);
3722 tmp = gfc_evaluate_now (or_expr, pblock);
3723 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3724 gfc_add_expr_to_block (pblock, tmp);
3730 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3731 the work for an ALLOCATE statement. */
3735 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3743 gfc_ref *ref, *prev_ref = NULL;
3744 bool allocatable_array;
3748 /* Find the last reference in the chain. */
3749 while (ref && ref->next != NULL)
3751 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3756 if (ref == NULL || ref->type != REF_ARRAY)
3760 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3762 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3764 /* Figure out the size of the array. */
3765 switch (ref->u.ar.type)
3769 upper = ref->u.ar.start;
3773 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3775 lower = ref->u.ar.as->lower;
3776 upper = ref->u.ar.as->upper;
3780 lower = ref->u.ar.start;
3781 upper = ref->u.ar.end;
3789 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3790 lower, upper, &se->pre);
3792 /* Allocate memory to store the data. */
3793 pointer = gfc_conv_descriptor_data_get (se->expr);
3794 STRIP_NOPS (pointer);
3796 /* The allocate_array variants take the old pointer as first argument. */
3797 if (allocatable_array)
3798 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3800 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3801 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3802 gfc_add_expr_to_block (&se->pre, tmp);
3804 tmp = gfc_conv_descriptor_offset (se->expr);
3805 gfc_add_modify (&se->pre, tmp, offset);
3807 if (expr->ts.type == BT_DERIVED
3808 && expr->ts.derived->attr.alloc_comp)
3810 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3811 ref->u.ar.as->rank);
3812 gfc_add_expr_to_block (&se->pre, tmp);
3819 /* Deallocate an array variable. Also used when an allocated variable goes
3824 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3830 gfc_start_block (&block);
3831 /* Get a pointer to the data. */
3832 var = gfc_conv_descriptor_data_get (descriptor);
3835 /* Parameter is the address of the data component. */
3836 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3837 gfc_add_expr_to_block (&block, tmp);
3839 /* Zero the data pointer. */
3840 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3841 var, build_int_cst (TREE_TYPE (var), 0));
3842 gfc_add_expr_to_block (&block, tmp);
3844 return gfc_finish_block (&block);
3848 /* Create an array constructor from an initialization expression.
3849 We assume the frontend already did any expansions and conversions. */
3852 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3859 unsigned HOST_WIDE_INT lo;
3861 VEC(constructor_elt,gc) *v = NULL;
3863 switch (expr->expr_type)
3866 case EXPR_STRUCTURE:
3867 /* A single scalar or derived type value. Create an array with all
3868 elements equal to that value. */
3869 gfc_init_se (&se, NULL);
3871 if (expr->expr_type == EXPR_CONSTANT)
3872 gfc_conv_constant (&se, expr);
3874 gfc_conv_structure (&se, expr, 1);
3876 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3877 gcc_assert (tmp && INTEGER_CST_P (tmp));
3878 hi = TREE_INT_CST_HIGH (tmp);
3879 lo = TREE_INT_CST_LOW (tmp);
3883 /* This will probably eat buckets of memory for large arrays. */
3884 while (hi != 0 || lo != 0)
3886 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3894 /* Create a vector of all the elements. */
3895 for (c = expr->value.constructor; c; c = c->next)
3899 /* Problems occur when we get something like
3900 integer :: a(lots) = (/(i, i=1,lots)/) */
3901 /* TODO: Unexpanded array initializers. */
3903 ("Possible frontend bug: array constructor not expanded");
3905 if (mpz_cmp_si (c->n.offset, 0) != 0)
3906 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3910 if (mpz_cmp_si (c->repeat, 0) != 0)
3914 mpz_set (maxval, c->repeat);
3915 mpz_add (maxval, c->n.offset, maxval);
3916 mpz_sub_ui (maxval, maxval, 1);
3917 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3918 if (mpz_cmp_si (c->n.offset, 0) != 0)
3920 mpz_add_ui (maxval, c->n.offset, 1);
3921 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3924 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3926 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3932 gfc_init_se (&se, NULL);
3933 switch (c->expr->expr_type)
3936 gfc_conv_constant (&se, c->expr);
3937 if (range == NULL_TREE)
3938 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3941 if (index != NULL_TREE)
3942 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3943 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3947 case EXPR_STRUCTURE:
3948 gfc_conv_structure (&se, c->expr, 1);
3949 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3959 return gfc_build_null_descriptor (type);
3965 /* Create a constructor from the list of elements. */
3966 tmp = build_constructor (type, v);
3967 TREE_CONSTANT (tmp) = 1;
3972 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3973 returns the size (in elements) of the array. */
3976 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3977 stmtblock_t * pblock)
3992 size = gfc_index_one_node;
3993 offset = gfc_index_zero_node;
3994 for (dim = 0; dim < as->rank; dim++)
3996 /* Evaluate non-constant array bound expressions. */
3997 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3998 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4000 gfc_init_se (&se, NULL);
4001 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4002 gfc_add_block_to_block (pblock, &se.pre);
4003 gfc_add_modify (pblock, lbound, se.expr);
4005 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4006 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4008 gfc_init_se (&se, NULL);
4009 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4010 gfc_add_block_to_block (pblock, &se.pre);
4011 gfc_add_modify (pblock, ubound, se.expr);
4013 /* The offset of this dimension. offset = offset - lbound * stride. */
4014 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4015 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4017 /* The size of this dimension, and the stride of the next. */
4018 if (dim + 1 < as->rank)
4019 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4021 stride = GFC_TYPE_ARRAY_SIZE (type);
4023 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4025 /* Calculate stride = size * (ubound + 1 - lbound). */
4026 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4027 gfc_index_one_node, lbound);
4028 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4029 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4031 gfc_add_modify (pblock, stride, tmp);
4033 stride = gfc_evaluate_now (tmp, pblock);
4035 /* Make sure that negative size arrays are translated
4036 to being zero size. */
4037 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4038 stride, gfc_index_zero_node);
4039 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4040 stride, gfc_index_zero_node);
4041 gfc_add_modify (pblock, stride, tmp);
4047 gfc_trans_vla_type_sizes (sym, pblock);
4054 /* Generate code to initialize/allocate an array variable. */
4057 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4066 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4068 /* Do nothing for USEd variables. */
4069 if (sym->attr.use_assoc)
4072 type = TREE_TYPE (decl);
4073 gcc_assert (GFC_ARRAY_TYPE_P (type));
4074 onstack = TREE_CODE (type) != POINTER_TYPE;
4076 gfc_start_block (&block);
4078 /* Evaluate character string length. */
4079 if (sym->ts.type == BT_CHARACTER
4080 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4082 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4084 gfc_trans_vla_type_sizes (sym, &block);
4086 /* Emit a DECL_EXPR for this variable, which will cause the
4087 gimplifier to allocate storage, and all that good stuff. */
4088 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4089 gfc_add_expr_to_block (&block, tmp);
4094 gfc_add_expr_to_block (&block, fnbody);
4095 return gfc_finish_block (&block);
4098 type = TREE_TYPE (type);
4100 gcc_assert (!sym->attr.use_assoc);
4101 gcc_assert (!TREE_STATIC (decl));
4102 gcc_assert (!sym->module);
4104 if (sym->ts.type == BT_CHARACTER
4105 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4106 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4108 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4110 /* Don't actually allocate space for Cray Pointees. */
4111 if (sym->attr.cray_pointee)
4113 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4114 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4115 gfc_add_expr_to_block (&block, fnbody);
4116 return gfc_finish_block (&block);
4119 /* The size is the number of elements in the array, so multiply by the
4120 size of an element to get the total size. */
4121 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4122 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4123 fold_convert (gfc_array_index_type, tmp));
4125 /* Allocate memory to hold the data. */
4126 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4127 gfc_add_modify (&block, decl, tmp);
4129 /* Set offset of the array. */
4130 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4131 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4134 /* Automatic arrays should not have initializers. */
4135 gcc_assert (!sym->value);
4137 gfc_add_expr_to_block (&block, fnbody);
4139 /* Free the temporary. */
4140 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4141 gfc_add_expr_to_block (&block, tmp);
4143 return gfc_finish_block (&block);
4147 /* Generate entry and exit code for g77 calling convention arrays. */
4150 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4160 gfc_get_backend_locus (&loc);
4161 gfc_set_backend_locus (&sym->declared_at);
4163 /* Descriptor type. */
4164 parm = sym->backend_decl;
4165 type = TREE_TYPE (parm);
4166 gcc_assert (GFC_ARRAY_TYPE_P (type));
4168 gfc_start_block (&block);
4170 if (sym->ts.type == BT_CHARACTER
4171 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4172 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4174 /* Evaluate the bounds of the array. */
4175 gfc_trans_array_bounds (type, sym, &offset, &block);
4177 /* Set the offset. */
4178 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4179 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4181 /* Set the pointer itself if we aren't using the parameter directly. */
4182 if (TREE_CODE (parm) != PARM_DECL)
4184 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4185 gfc_add_modify (&block, parm, tmp);
4187 stmt = gfc_finish_block (&block);
4189 gfc_set_backend_locus (&loc);
4191 gfc_start_block (&block);
4193 /* Add the initialization code to the start of the function. */
4195 if (sym->attr.optional || sym->attr.not_always_present)
4197 tmp = gfc_conv_expr_present (sym);
4198 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4201 gfc_add_expr_to_block (&block, stmt);
4202 gfc_add_expr_to_block (&block, body);
4204 return gfc_finish_block (&block);
4208 /* Modify the descriptor of an array parameter so that it has the
4209 correct lower bound. Also move the upper bound accordingly.
4210 If the array is not packed, it will be copied into a temporary.
4211 For each dimension we set the new lower and upper bounds. Then we copy the
4212 stride and calculate the offset for this dimension. We also work out
4213 what the stride of a packed array would be, and see it the two match.
4214 If the array need repacking, we set the stride to the values we just
4215 calculated, recalculate the offset and copy the array data.
4216 Code is also added to copy the data back at the end of the function.
4220 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4227 stmtblock_t cleanup;
4235 tree stride, stride2;
4245 /* Do nothing for pointer and allocatable arrays. */
4246 if (sym->attr.pointer || sym->attr.allocatable)
4249 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4250 return gfc_trans_g77_array (sym, body);
4252 gfc_get_backend_locus (&loc);
4253 gfc_set_backend_locus (&sym->declared_at);
4255 /* Descriptor type. */
4256 type = TREE_TYPE (tmpdesc);
4257 gcc_assert (GFC_ARRAY_TYPE_P (type));
4258 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4259 dumdesc = build_fold_indirect_ref (dumdesc);
4260 gfc_start_block (&block);
4262 if (sym->ts.type == BT_CHARACTER
4263 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4264 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4266 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4268 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4269 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4271 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4273 /* For non-constant shape arrays we only check if the first dimension
4274 is contiguous. Repacking higher dimensions wouldn't gain us
4275 anything as we still don't know the array stride. */
4276 partial = gfc_create_var (boolean_type_node, "partial");
4277 TREE_USED (partial) = 1;
4278 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4279 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4280 gfc_add_modify (&block, partial, tmp);
4284 partial = NULL_TREE;
4287 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4288 here, however I think it does the right thing. */
4291 /* Set the first stride. */
4292 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4293 stride = gfc_evaluate_now (stride, &block);
4295 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4296 stride, gfc_index_zero_node);
4297 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4298 gfc_index_one_node, stride);
4299 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4300 gfc_add_modify (&block, stride, tmp);
4302 /* Allow the user to disable array repacking. */
4303 stmt_unpacked = NULL_TREE;
4307 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4308 /* A library call to repack the array if necessary. */
4309 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4310 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4312 stride = gfc_index_one_node;
4314 if (gfc_option.warn_array_temp)
4315 gfc_warning ("Creating array temporary at %L", &loc);
4318 /* This is for the case where the array data is used directly without
4319 calling the repack function. */
4320 if (no_repack || partial != NULL_TREE)
4321 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4323 stmt_packed = NULL_TREE;
4325 /* Assign the data pointer. */
4326 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4328 /* Don't repack unknown shape arrays when the first stride is 1. */
4329 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4330 partial, stmt_packed, stmt_unpacked);
4333 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4334 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4336 offset = gfc_index_zero_node;
4337 size = gfc_index_one_node;
4339 /* Evaluate the bounds of the array. */
4340 for (n = 0; n < sym->as->rank; n++)
4342 if (checkparm || !sym->as->upper[n])
4344 /* Get the bounds of the actual parameter. */
4345 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4346 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4350 dubound = NULL_TREE;
4351 dlbound = NULL_TREE;
4354 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4355 if (!INTEGER_CST_P (lbound))
4357 gfc_init_se (&se, NULL);
4358 gfc_conv_expr_type (&se, sym->as->lower[n],
4359 gfc_array_index_type);
4360 gfc_add_block_to_block (&block, &se.pre);
4361 gfc_add_modify (&block, lbound, se.expr);
4364 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4365 /* Set the desired upper bound. */
4366 if (sym->as->upper[n])
4368 /* We know what we want the upper bound to be. */
4369 if (!INTEGER_CST_P (ubound))
4371 gfc_init_se (&se, NULL);
4372 gfc_conv_expr_type (&se, sym->as->upper[n],
4373 gfc_array_index_type);
4374 gfc_add_block_to_block (&block, &se.pre);
4375 gfc_add_modify (&block, ubound, se.expr);
4378 /* Check the sizes match. */
4381 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4384 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4386 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4388 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4389 asprintf (&msg, "%s for dimension %d of array '%s'",
4390 gfc_msg_bounds, n+1, sym->name);
4391 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4397 /* For assumed shape arrays move the upper bound by the same amount
4398 as the lower bound. */
4399 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4401 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4402 gfc_add_modify (&block, ubound, tmp);
4404 /* The offset of this dimension. offset = offset - lbound * stride. */
4405 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4406 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4408 /* The size of this dimension, and the stride of the next. */
4409 if (n + 1 < sym->as->rank)
4411 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4413 if (no_repack || partial != NULL_TREE)
4416 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4419 /* Figure out the stride if not a known constant. */
4420 if (!INTEGER_CST_P (stride))
4423 stmt_packed = NULL_TREE;
4426 /* Calculate stride = size * (ubound + 1 - lbound). */
4427 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4428 gfc_index_one_node, lbound);
4429 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4431 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4436 /* Assign the stride. */
4437 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4438 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4439 stmt_unpacked, stmt_packed);
4441 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4442 gfc_add_modify (&block, stride, tmp);
4447 stride = GFC_TYPE_ARRAY_SIZE (type);
4449 if (stride && !INTEGER_CST_P (stride))
4451 /* Calculate size = stride * (ubound + 1 - lbound). */
4452 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4453 gfc_index_one_node, lbound);
4454 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4456 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4457 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4458 gfc_add_modify (&block, stride, tmp);
4463 /* Set the offset. */
4464 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4465 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4467 gfc_trans_vla_type_sizes (sym, &block);
4469 stmt = gfc_finish_block (&block);
4471 gfc_start_block (&block);
4473 /* Only do the entry/initialization code if the arg is present. */
4474 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4475 optional_arg = (sym->attr.optional
4476 || (sym->ns->proc_name->attr.entry_master
4477 && sym->attr.dummy));
4480 tmp = gfc_conv_expr_present (sym);
4481 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4483 gfc_add_expr_to_block (&block, stmt);
4485 /* Add the main function body. */
4486 gfc_add_expr_to_block (&block, body);
4491 gfc_start_block (&cleanup);
4493 if (sym->attr.intent != INTENT_IN)
4495 /* Copy the data back. */
4496 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4497 gfc_add_expr_to_block (&cleanup, tmp);
4500 /* Free the temporary. */
4501 tmp = gfc_call_free (tmpdesc);
4502 gfc_add_expr_to_block (&cleanup, tmp);
4504 stmt = gfc_finish_block (&cleanup);
4506 /* Only do the cleanup if the array was repacked. */
4507 tmp = build_fold_indirect_ref (dumdesc);
4508 tmp = gfc_conv_descriptor_data_get (tmp);
4509 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4510 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4514 tmp = gfc_conv_expr_present (sym);
4515 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4517 gfc_add_expr_to_block (&block, stmt);
4519 /* We don't need to free any memory allocated by internal_pack as it will
4520 be freed at the end of the function by pop_context. */
4521 return gfc_finish_block (&block);
4525 /* Calculate the overall offset, including subreferences. */
4527 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4528 bool subref, gfc_expr *expr)
4538 /* If offset is NULL and this is not a subreferenced array, there is
4540 if (offset == NULL_TREE)
4543 offset = gfc_index_zero_node;
4548 tmp = gfc_conv_array_data (desc);
4549 tmp = build_fold_indirect_ref (tmp);
4550 tmp = gfc_build_array_ref (tmp, offset, NULL);
4552 /* Offset the data pointer for pointer assignments from arrays with
4553 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4556 /* Go past the array reference. */
4557 for (ref = expr->ref; ref; ref = ref->next)
4558 if (ref->type == REF_ARRAY &&
4559 ref->u.ar.type != AR_ELEMENT)
4565 /* Calculate the offset for each subsequent subreference. */
4566 for (; ref; ref = ref->next)
4571 field = ref->u.c.component->backend_decl;
4572 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4573 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4574 tmp, field, NULL_TREE);
4578 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4579 gfc_init_se (&start, NULL);
4580 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4581 gfc_add_block_to_block (block, &start.pre);
4582 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4586 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4587 && ref->u.ar.type == AR_ELEMENT);
4589 /* TODO - Add bounds checking. */
4590 stride = gfc_index_one_node;
4591 index = gfc_index_zero_node;
4592 for (n = 0; n < ref->u.ar.dimen; n++)
4597 /* Update the index. */
4598 gfc_init_se (&start, NULL);
4599 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4600 itmp = gfc_evaluate_now (start.expr, block);
4601 gfc_init_se (&start, NULL);
4602 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4603 jtmp = gfc_evaluate_now (start.expr, block);
4604 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4605 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4606 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4607 index = gfc_evaluate_now (index, block);
4609 /* Update the stride. */
4610 gfc_init_se (&start, NULL);
4611 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4612 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4613 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4614 gfc_index_one_node, itmp);
4615 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4616 stride = gfc_evaluate_now (stride, block);
4619 /* Apply the index to obtain the array element. */
4620 tmp = gfc_build_array_ref (tmp, index, NULL);
4630 /* Set the target data pointer. */
4631 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4632 gfc_conv_descriptor_data_set (block, parm, offset);
4636 /* gfc_conv_expr_descriptor needs the character length of elemental
4637 functions before the function is called so that the size of the
4638 temporary can be obtained. The only way to do this is to convert
4639 the expression, mapping onto the actual arguments. */
4641 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4643 gfc_interface_mapping mapping;
4644 gfc_formal_arglist *formal;
4645 gfc_actual_arglist *arg;
4648 formal = expr->symtree->n.sym->formal;
4649 arg = expr->value.function.actual;
4650 gfc_init_interface_mapping (&mapping);
4652 /* Set se = NULL in the calls to the interface mapping, to suppress any
4654 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4659 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4662 gfc_init_se (&tse, NULL);
4664 /* Build the expression for the character length and convert it. */
4665 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4667 gfc_add_block_to_block (&se->pre, &tse.pre);
4668 gfc_add_block_to_block (&se->post, &tse.post);
4669 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4670 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4671 build_int_cst (gfc_charlen_type_node, 0));
4672 expr->ts.cl->backend_decl = tse.expr;
4673 gfc_free_interface_mapping (&mapping);
4677 /* Convert an array for passing as an actual argument. Expressions and
4678 vector subscripts are evaluated and stored in a temporary, which is then
4679 passed. For whole arrays the descriptor is passed. For array sections
4680 a modified copy of the descriptor is passed, but using the original data.
4682 This function is also used for array pointer assignments, and there
4685 - se->want_pointer && !se->direct_byref
4686 EXPR is an actual argument. On exit, se->expr contains a
4687 pointer to the array descriptor.
4689 - !se->want_pointer && !se->direct_byref
4690 EXPR is an actual argument to an intrinsic function or the
4691 left-hand side of a pointer assignment. On exit, se->expr
4692 contains the descriptor for EXPR.
4694 - !se->want_pointer && se->direct_byref
4695 EXPR is the right-hand side of a pointer assignment and
4696 se->expr is the descriptor for the previously-evaluated
4697 left-hand side. The function creates an assignment from
4698 EXPR to se->expr. */
4701 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4714 bool subref_array_target = false;
4716 gcc_assert (ss != gfc_ss_terminator);
4718 /* Special case things we know we can pass easily. */
4719 switch (expr->expr_type)
4722 /* If we have a linear array section, we can pass it directly.
4723 Otherwise we need to copy it into a temporary. */
4725 /* Find the SS for the array section. */
4727 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4728 secss = secss->next;
4730 gcc_assert (secss != gfc_ss_terminator);
4731 info = &secss->data.info;
4733 /* Get the descriptor for the array. */
4734 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4735 desc = info->descriptor;
4737 subref_array_target = se->direct_byref && is_subref_array (expr);
4738 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4739 && !subref_array_target;
4743 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4745 /* Create a new descriptor if the array doesn't have one. */
4748 else if (info->ref->u.ar.type == AR_FULL)
4750 else if (se->direct_byref)
4753 full = gfc_full_array_ref_p (info->ref);
4757 if (se->direct_byref)
4759 /* Copy the descriptor for pointer assignments. */
4760 gfc_add_modify (&se->pre, se->expr, desc);
4762 /* Add any offsets from subreferences. */
4763 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4764 subref_array_target, expr);
4766 else if (se->want_pointer)
4768 /* We pass full arrays directly. This means that pointers and
4769 allocatable arrays should also work. */
4770 se->expr = build_fold_addr_expr (desc);
4777 if (expr->ts.type == BT_CHARACTER)
4778 se->string_length = gfc_get_expr_charlen (expr);
4785 /* A transformational function return value will be a temporary
4786 array descriptor. We still need to go through the scalarizer
4787 to create the descriptor. Elemental functions ar handled as
4788 arbitrary expressions, i.e. copy to a temporary. */
4790 /* Look for the SS for this function. */
4791 while (secss != gfc_ss_terminator
4792 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4793 secss = secss->next;
4795 if (se->direct_byref)
4797 gcc_assert (secss != gfc_ss_terminator);
4799 /* For pointer assignments pass the descriptor directly. */
4801 se->expr = build_fold_addr_expr (se->expr);
4802 gfc_conv_expr (se, expr);
4806 if (secss == gfc_ss_terminator)
4808 /* Elemental function. */
4810 if (expr->ts.type == BT_CHARACTER
4811 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4812 get_elemental_fcn_charlen (expr, se);
4818 /* Transformational function. */
4819 info = &secss->data.info;
4825 /* Constant array constructors don't need a temporary. */
4826 if (ss->type == GFC_SS_CONSTRUCTOR
4827 && expr->ts.type != BT_CHARACTER
4828 && gfc_constant_array_constructor_p (expr->value.constructor))
4831 info = &ss->data.info;
4843 /* Something complicated. Copy it into a temporary. */
4850 gfc_init_loopinfo (&loop);
4852 /* Associate the SS with the loop. */
4853 gfc_add_ss_to_loop (&loop, ss);
4855 /* Tell the scalarizer not to bother creating loop variables, etc. */
4857 loop.array_parameter = 1;
4859 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4860 gcc_assert (!se->direct_byref);
4862 /* Setup the scalarizing loops and bounds. */
4863 gfc_conv_ss_startstride (&loop);
4867 /* Tell the scalarizer to make a temporary. */
4868 loop.temp_ss = gfc_get_ss ();
4869 loop.temp_ss->type = GFC_SS_TEMP;
4870 loop.temp_ss->next = gfc_ss_terminator;
4872 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4873 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4875 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4877 if (expr->ts.type == BT_CHARACTER)
4878 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4880 loop.temp_ss->string_length = NULL;
4882 se->string_length = loop.temp_ss->string_length;
4883 loop.temp_ss->data.temp.dimen = loop.dimen;
4884 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4887 gfc_conv_loop_setup (&loop, & expr->where);
4891 /* Copy into a temporary and pass that. We don't need to copy the data
4892 back because expressions and vector subscripts must be INTENT_IN. */
4893 /* TODO: Optimize passing function return values. */
4897 /* Start the copying loops. */
4898 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4899 gfc_mark_ss_chain_used (ss, 1);
4900 gfc_start_scalarized_body (&loop, &block);
4902 /* Copy each data element. */
4903 gfc_init_se (&lse, NULL);
4904 gfc_copy_loopinfo_to_se (&lse, &loop);
4905 gfc_init_se (&rse, NULL);
4906 gfc_copy_loopinfo_to_se (&rse, &loop);
4908 lse.ss = loop.temp_ss;
4911 gfc_conv_scalarized_array_ref (&lse, NULL);
4912 if (expr->ts.type == BT_CHARACTER)
4914 gfc_conv_expr (&rse, expr);
4915 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4916 rse.expr = build_fold_indirect_ref (rse.expr);
4919 gfc_conv_expr_val (&rse, expr);
4921 gfc_add_block_to_block (&block, &rse.pre);
4922 gfc_add_block_to_block (&block, &lse.pre);
4924 lse.string_length = rse.string_length;
4925 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4926 expr->expr_type == EXPR_VARIABLE);
4927 gfc_add_expr_to_block (&block, tmp);
4929 /* Finish the copying loops. */
4930 gfc_trans_scalarizing_loops (&loop, &block);
4932 desc = loop.temp_ss->data.info.descriptor;
4934 gcc_assert (is_gimple_lvalue (desc));
4936 else if (expr->expr_type == EXPR_FUNCTION)
4938 desc = info->descriptor;
4939 se->string_length = ss->string_length;
4943 /* We pass sections without copying to a temporary. Make a new
4944 descriptor and point it at the section we want. The loop variable
4945 limits will be the limits of the section.
4946 A function may decide to repack the array to speed up access, but
4947 we're not bothered about that here. */
4956 /* Set the string_length for a character array. */
4957 if (expr->ts.type == BT_CHARACTER)
4958 se->string_length = gfc_get_expr_charlen (expr);
4960 desc = info->descriptor;
4961 gcc_assert (secss && secss != gfc_ss_terminator);
4962 if (se->direct_byref)
4964 /* For pointer assignments we fill in the destination. */
4966 parmtype = TREE_TYPE (parm);
4970 /* Otherwise make a new one. */
4971 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4972 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4973 loop.from, loop.to, 0,
4975 parm = gfc_create_var (parmtype, "parm");
4978 offset = gfc_index_zero_node;
4981 /* The following can be somewhat confusing. We have two
4982 descriptors, a new one and the original array.
4983 {parm, parmtype, dim} refer to the new one.
4984 {desc, type, n, secss, loop} refer to the original, which maybe
4985 a descriptorless array.
4986 The bounds of the scalarization are the bounds of the section.
4987 We don't have to worry about numeric overflows when calculating
4988 the offsets because all elements are within the array data. */
4990 /* Set the dtype. */
4991 tmp = gfc_conv_descriptor_dtype (parm);
4992 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
4994 /* Set offset for assignments to pointer only to zero if it is not
4996 if (se->direct_byref
4997 && info->ref && info->ref->u.ar.type != AR_FULL)
4998 base = gfc_index_zero_node;
4999 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5000 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5004 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5005 for (n = 0; n < ndim; n++)
5007 stride = gfc_conv_array_stride (desc, n);
5009 /* Work out the offset. */
5011 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5013 gcc_assert (info->subscript[n]
5014 && info->subscript[n]->type == GFC_SS_SCALAR);
5015 start = info->subscript[n]->data.scalar.expr;
5019 /* Check we haven't somehow got out of sync. */
5020 gcc_assert (info->dim[dim] == n);
5022 /* Evaluate and remember the start of the section. */
5023 start = info->start[dim];
5024 stride = gfc_evaluate_now (stride, &loop.pre);
5027 tmp = gfc_conv_array_lbound (desc, n);
5028 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5030 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5031 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5034 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5036 /* For elemental dimensions, we only need the offset. */
5040 /* Vector subscripts need copying and are handled elsewhere. */
5042 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5044 /* Set the new lower bound. */
5045 from = loop.from[dim];
5048 /* If we have an array section or are assigning make sure that
5049 the lower bound is 1. References to the full
5050 array should otherwise keep the original bounds. */
5052 || info->ref->u.ar.type != AR_FULL)
5053 && !integer_onep (from))
5055 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5056 gfc_index_one_node, from);
5057 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5058 from = gfc_index_one_node;
5060 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5061 gfc_add_modify (&loop.pre, tmp, from);
5063 /* Set the new upper bound. */
5064 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5065 gfc_add_modify (&loop.pre, tmp, to);
5067 /* Multiply the stride by the section stride to get the
5069 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5070 stride, info->stride[dim]);
5072 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5074 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5077 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5079 tmp = gfc_conv_array_lbound (desc, n);
5080 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5081 tmp, loop.from[dim]);
5082 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5083 tmp, gfc_conv_array_stride (desc, n));
5084 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5088 /* Store the new stride. */
5089 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5090 gfc_add_modify (&loop.pre, tmp, stride);
5095 if (se->data_not_needed)
5096 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5098 /* Point the data pointer at the first element in the section. */
5099 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5100 subref_array_target, expr);
5102 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5103 && !se->data_not_needed)
5105 /* Set the offset. */
5106 tmp = gfc_conv_descriptor_offset (parm);
5107 gfc_add_modify (&loop.pre, tmp, base);
5111 /* Only the callee knows what the correct offset it, so just set
5113 tmp = gfc_conv_descriptor_offset (parm);
5114 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5119 if (!se->direct_byref)
5121 /* Get a pointer to the new descriptor. */
5122 if (se->want_pointer)
5123 se->expr = build_fold_addr_expr (desc);
5128 gfc_add_block_to_block (&se->pre, &loop.pre);
5129 gfc_add_block_to_block (&se->post, &loop.post);
5131 /* Cleanup the scalarizer. */
5132 gfc_cleanup_loop (&loop);
5136 /* Convert an array for passing as an actual parameter. */
5137 /* TODO: Optimize passing g77 arrays. */
5140 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5141 const gfc_symbol *fsym, const char *proc_name)
5145 tree tmp = NULL_TREE;
5147 tree parent = DECL_CONTEXT (current_function_decl);
5148 bool full_array_var, this_array_result;
5152 full_array_var = (expr->expr_type == EXPR_VARIABLE
5153 && expr->ref->u.ar.type == AR_FULL);
5154 sym = full_array_var ? expr->symtree->n.sym : NULL;
5156 /* The symbol should have an array specification. */
5157 gcc_assert (!sym || sym->as);
5159 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5161 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5162 expr->ts.cl->backend_decl = tmp;
5163 se->string_length = tmp;
5166 /* Is this the result of the enclosing procedure? */
5167 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5168 if (this_array_result
5169 && (sym->backend_decl != current_function_decl)
5170 && (sym->backend_decl != parent))
5171 this_array_result = false;
5173 /* Passing address of the array if it is not pointer or assumed-shape. */
5174 if (full_array_var && g77 && !this_array_result)
5176 tmp = gfc_get_symbol_decl (sym);
5178 if (sym->ts.type == BT_CHARACTER)
5179 se->string_length = sym->ts.cl->backend_decl;
5180 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5181 && !sym->attr.allocatable)
5183 /* Some variables are declared directly, others are declared as
5184 pointers and allocated on the heap. */
5185 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5188 se->expr = build_fold_addr_expr (tmp);
5191 if (sym->attr.allocatable)
5193 if (sym->attr.dummy || sym->attr.result)
5195 gfc_conv_expr_descriptor (se, expr, ss);
5196 se->expr = gfc_conv_array_data (se->expr);
5199 se->expr = gfc_conv_array_data (tmp);
5204 if (this_array_result)
5206 /* Result of the enclosing function. */
5207 gfc_conv_expr_descriptor (se, expr, ss);
5208 se->expr = build_fold_addr_expr (se->expr);
5210 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5211 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5212 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5218 /* Every other type of array. */
5219 se->want_pointer = 1;
5220 gfc_conv_expr_descriptor (se, expr, ss);
5224 /* Deallocate the allocatable components of structures that are
5226 if (expr->ts.type == BT_DERIVED
5227 && expr->ts.derived->attr.alloc_comp
5228 && expr->expr_type != EXPR_VARIABLE)
5230 tmp = build_fold_indirect_ref (se->expr);
5231 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5232 gfc_add_expr_to_block (&se->post, tmp);
5238 /* Repack the array. */
5240 if (gfc_option.warn_array_temp)
5243 gfc_warning ("Creating array temporary at %L for argument '%s'",
5244 &expr->where, fsym->name);
5246 gfc_warning ("Creating array temporary at %L", &expr->where);
5249 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5251 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5253 tmp = gfc_conv_expr_present (sym);
5254 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5255 fold_convert (TREE_TYPE (se->expr), ptr),
5256 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5259 ptr = gfc_evaluate_now (ptr, &se->pre);
5263 if (gfc_option.flag_check_array_temporaries)
5267 if (fsym && proc_name)
5268 asprintf (&msg, "An array temporary was created for argument "
5269 "'%s' of procedure '%s'", fsym->name, proc_name);
5271 asprintf (&msg, "An array temporary was created");
5273 tmp = build_fold_indirect_ref (desc);
5274 tmp = gfc_conv_array_data (tmp);
5275 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5276 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5278 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5279 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5280 gfc_conv_expr_present (sym), tmp);
5282 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5287 gfc_start_block (&block);
5289 /* Copy the data back. */
5290 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5292 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5293 gfc_add_expr_to_block (&block, tmp);
5296 /* Free the temporary. */
5297 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5298 gfc_add_expr_to_block (&block, tmp);
5300 stmt = gfc_finish_block (&block);
5302 gfc_init_block (&block);
5303 /* Only if it was repacked. This code needs to be executed before the
5304 loop cleanup code. */
5305 tmp = build_fold_indirect_ref (desc);
5306 tmp = gfc_conv_array_data (tmp);
5307 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5308 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5310 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5311 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5312 gfc_conv_expr_present (sym), tmp);
5314 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5316 gfc_add_expr_to_block (&block, tmp);
5317 gfc_add_block_to_block (&block, &se->post);
5319 gfc_init_block (&se->post);
5320 gfc_add_block_to_block (&se->post, &block);
5325 /* Generate code to deallocate an array, if it is allocated. */
5328 gfc_trans_dealloc_allocated (tree descriptor)
5334 gfc_start_block (&block);
5336 var = gfc_conv_descriptor_data_get (descriptor);
5339 /* Call array_deallocate with an int * present in the second argument.
5340 Although it is ignored here, it's presence ensures that arrays that
5341 are already deallocated are ignored. */
5342 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5343 gfc_add_expr_to_block (&block, tmp);
5345 /* Zero the data pointer. */
5346 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5347 var, build_int_cst (TREE_TYPE (var), 0));
5348 gfc_add_expr_to_block (&block, tmp);
5350 return gfc_finish_block (&block);
5354 /* This helper function calculates the size in words of a full array. */
5357 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5362 idx = gfc_rank_cst[rank - 1];
5363 nelems = gfc_conv_descriptor_ubound (decl, idx);
5364 tmp = gfc_conv_descriptor_lbound (decl, idx);
5365 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5366 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5367 tmp, gfc_index_one_node);
5368 tmp = gfc_evaluate_now (tmp, block);
5370 nelems = gfc_conv_descriptor_stride (decl, idx);
5371 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5372 return gfc_evaluate_now (tmp, block);
5376 /* Allocate dest to the same size as src, and copy src -> dest. */
5379 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5388 /* If the source is null, set the destination to null. */
5389 gfc_init_block (&block);
5390 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5391 null_data = gfc_finish_block (&block);
5393 gfc_init_block (&block);
5395 nelems = get_full_array_size (&block, src, rank);
5396 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5397 fold_convert (gfc_array_index_type,
5398 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5400 /* Allocate memory to the destination. */
5401 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5403 gfc_conv_descriptor_data_set (&block, dest, tmp);
5405 /* We know the temporary and the value will be the same length,
5406 so can use memcpy. */
5407 tmp = built_in_decls[BUILT_IN_MEMCPY];
5408 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5409 gfc_conv_descriptor_data_get (src), size);
5410 gfc_add_expr_to_block (&block, tmp);
5411 tmp = gfc_finish_block (&block);
5413 /* Null the destination if the source is null; otherwise do
5414 the allocate and copy. */
5415 null_cond = gfc_conv_descriptor_data_get (src);
5416 null_cond = convert (pvoid_type_node, null_cond);
5417 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5418 null_cond, null_pointer_node);
5419 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5423 /* Recursively traverse an object of derived type, generating code to
5424 deallocate, nullify or copy allocatable components. This is the work horse
5425 function for the functions named in this enum. */
5427 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5430 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5431 tree dest, int rank, int purpose)
5435 stmtblock_t fnblock;
5436 stmtblock_t loopbody;
5446 tree null_cond = NULL_TREE;
5448 gfc_init_block (&fnblock);
5450 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5451 decl = build_fold_indirect_ref (decl);
5453 /* If this an array of derived types with allocatable components
5454 build a loop and recursively call this function. */
5455 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5456 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5458 tmp = gfc_conv_array_data (decl);
5459 var = build_fold_indirect_ref (tmp);
5461 /* Get the number of elements - 1 and set the counter. */
5462 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5464 /* Use the descriptor for an allocatable array. Since this
5465 is a full array reference, we only need the descriptor
5466 information from dimension = rank. */
5467 tmp = get_full_array_size (&fnblock, decl, rank);
5468 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5469 tmp, gfc_index_one_node);
5471 null_cond = gfc_conv_descriptor_data_get (decl);
5472 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5473 build_int_cst (TREE_TYPE (null_cond), 0));
5477 /* Otherwise use the TYPE_DOMAIN information. */
5478 tmp = array_type_nelts (TREE_TYPE (decl));
5479 tmp = fold_convert (gfc_array_index_type, tmp);
5482 /* Remember that this is, in fact, the no. of elements - 1. */
5483 nelems = gfc_evaluate_now (tmp, &fnblock);
5484 index = gfc_create_var (gfc_array_index_type, "S");
5486 /* Build the body of the loop. */
5487 gfc_init_block (&loopbody);
5489 vref = gfc_build_array_ref (var, index, NULL);
5491 if (purpose == COPY_ALLOC_COMP)
5493 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5494 gfc_add_expr_to_block (&fnblock, tmp);
5496 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5497 dref = gfc_build_array_ref (tmp, index, NULL);
5498 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5501 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5503 gfc_add_expr_to_block (&loopbody, tmp);
5505 /* Build the loop and return. */
5506 gfc_init_loopinfo (&loop);
5508 loop.from[0] = gfc_index_zero_node;
5509 loop.loopvar[0] = index;
5510 loop.to[0] = nelems;
5511 gfc_trans_scalarizing_loops (&loop, &loopbody);
5512 gfc_add_block_to_block (&fnblock, &loop.pre);
5514 tmp = gfc_finish_block (&fnblock);
5515 if (null_cond != NULL_TREE)
5516 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5521 /* Otherwise, act on the components or recursively call self to
5522 act on a chain of components. */
5523 for (c = der_type->components; c; c = c->next)
5525 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5526 && c->ts.derived->attr.alloc_comp;
5527 cdecl = c->backend_decl;
5528 ctype = TREE_TYPE (cdecl);
5532 case DEALLOCATE_ALLOC_COMP:
5533 /* Do not deallocate the components of ultimate pointer
5535 if (cmp_has_alloc_comps && !c->attr.pointer)
5537 comp = fold_build3 (COMPONENT_REF, ctype,
5538 decl, cdecl, NULL_TREE);
5539 rank = c->as ? c->as->rank : 0;
5540 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5542 gfc_add_expr_to_block (&fnblock, tmp);
5545 if (c->attr.allocatable)
5547 comp = fold_build3 (COMPONENT_REF, ctype,
5548 decl, cdecl, NULL_TREE);
5549 tmp = gfc_trans_dealloc_allocated (comp);
5550 gfc_add_expr_to_block (&fnblock, tmp);
5554 case NULLIFY_ALLOC_COMP:
5555 if (c->attr.pointer)
5557 else if (c->attr.allocatable)
5559 comp = fold_build3 (COMPONENT_REF, ctype,
5560 decl, cdecl, NULL_TREE);
5561 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5563 else if (cmp_has_alloc_comps)
5565 comp = fold_build3 (COMPONENT_REF, ctype,
5566 decl, cdecl, NULL_TREE);
5567 rank = c->as ? c->as->rank : 0;
5568 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5570 gfc_add_expr_to_block (&fnblock, tmp);
5574 case COPY_ALLOC_COMP:
5575 if (c->attr.pointer)
5578 /* We need source and destination components. */
5579 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5580 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5581 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5583 if (c->attr.allocatable && !cmp_has_alloc_comps)
5585 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5586 gfc_add_expr_to_block (&fnblock, tmp);
5589 if (cmp_has_alloc_comps)
5591 rank = c->as ? c->as->rank : 0;
5592 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5593 gfc_add_modify (&fnblock, dcmp, tmp);
5594 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5596 gfc_add_expr_to_block (&fnblock, tmp);
5606 return gfc_finish_block (&fnblock);
5609 /* Recursively traverse an object of derived type, generating code to
5610 nullify allocatable components. */
5613 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5615 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5616 NULLIFY_ALLOC_COMP);
5620 /* Recursively traverse an object of derived type, generating code to
5621 deallocate allocatable components. */
5624 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5626 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5627 DEALLOCATE_ALLOC_COMP);
5631 /* Recursively traverse an object of derived type, generating code to
5632 copy its allocatable components. */
5635 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5637 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5641 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5642 Do likewise, recursively if necessary, with the allocatable components of
5646 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5651 stmtblock_t fnblock;
5654 bool sym_has_alloc_comp;
5656 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5657 && sym->ts.derived->attr.alloc_comp;
5659 /* Make sure the frontend gets these right. */
5660 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5661 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5662 "allocatable attribute or derived type without allocatable "
5665 gfc_init_block (&fnblock);
5667 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5668 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5670 if (sym->ts.type == BT_CHARACTER
5671 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5673 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5674 gfc_trans_vla_type_sizes (sym, &fnblock);
5677 /* Dummy and use associated variables don't need anything special. */
5678 if (sym->attr.dummy || sym->attr.use_assoc)
5680 gfc_add_expr_to_block (&fnblock, body);
5682 return gfc_finish_block (&fnblock);
5685 gfc_get_backend_locus (&loc);
5686 gfc_set_backend_locus (&sym->declared_at);
5687 descriptor = sym->backend_decl;
5689 /* Although static, derived types with default initializers and
5690 allocatable components must not be nulled wholesale; instead they
5691 are treated component by component. */
5692 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5694 /* SAVEd variables are not freed on exit. */
5695 gfc_trans_static_array_pointer (sym);
5699 /* Get the descriptor type. */
5700 type = TREE_TYPE (sym->backend_decl);
5702 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5704 if (!sym->attr.save)
5706 rank = sym->as ? sym->as->rank : 0;
5707 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5708 gfc_add_expr_to_block (&fnblock, tmp);
5711 tmp = gfc_init_default_dt (sym, NULL);
5712 gfc_add_expr_to_block (&fnblock, tmp);
5716 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5718 /* If the backend_decl is not a descriptor, we must have a pointer
5720 descriptor = build_fold_indirect_ref (sym->backend_decl);
5721 type = TREE_TYPE (descriptor);
5724 /* NULLIFY the data pointer. */
5725 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5726 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5728 gfc_add_expr_to_block (&fnblock, body);
5730 gfc_set_backend_locus (&loc);
5732 /* Allocatable arrays need to be freed when they go out of scope.
5733 The allocatable components of pointers must not be touched. */
5734 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5735 && !sym->attr.pointer && !sym->attr.save)
5738 rank = sym->as ? sym->as->rank : 0;
5739 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5740 gfc_add_expr_to_block (&fnblock, tmp);
5743 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5745 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5746 gfc_add_expr_to_block (&fnblock, tmp);
5749 return gfc_finish_block (&fnblock);
5752 /************ Expression Walking Functions ******************/
5754 /* Walk a variable reference.
5756 Possible extension - multiple component subscripts.
5757 x(:,:) = foo%a(:)%b(:)
5759 forall (i=..., j=...)
5760 x(i,j) = foo%a(j)%b(i)
5762 This adds a fair amount of complexity because you need to deal with more
5763 than one ref. Maybe handle in a similar manner to vector subscripts.
5764 Maybe not worth the effort. */
5768 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5776 for (ref = expr->ref; ref; ref = ref->next)
5777 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5780 for (; ref; ref = ref->next)
5782 if (ref->type == REF_SUBSTRING)
5784 newss = gfc_get_ss ();
5785 newss->type = GFC_SS_SCALAR;
5786 newss->expr = ref->u.ss.start;
5790 newss = gfc_get_ss ();
5791 newss->type = GFC_SS_SCALAR;
5792 newss->expr = ref->u.ss.end;
5797 /* We're only interested in array sections from now on. */
5798 if (ref->type != REF_ARRAY)
5805 for (n = 0; n < ar->dimen; n++)
5807 newss = gfc_get_ss ();
5808 newss->type = GFC_SS_SCALAR;
5809 newss->expr = ar->start[n];
5816 newss = gfc_get_ss ();
5817 newss->type = GFC_SS_SECTION;
5820 newss->data.info.dimen = ar->as->rank;
5821 newss->data.info.ref = ref;
5823 /* Make sure array is the same as array(:,:), this way
5824 we don't need to special case all the time. */
5825 ar->dimen = ar->as->rank;
5826 for (n = 0; n < ar->dimen; n++)
5828 newss->data.info.dim[n] = n;
5829 ar->dimen_type[n] = DIMEN_RANGE;
5831 gcc_assert (ar->start[n] == NULL);
5832 gcc_assert (ar->end[n] == NULL);
5833 gcc_assert (ar->stride[n] == NULL);
5839 newss = gfc_get_ss ();
5840 newss->type = GFC_SS_SECTION;
5843 newss->data.info.dimen = 0;
5844 newss->data.info.ref = ref;
5848 /* We add SS chains for all the subscripts in the section. */
5849 for (n = 0; n < ar->dimen; n++)
5853 switch (ar->dimen_type[n])
5856 /* Add SS for elemental (scalar) subscripts. */
5857 gcc_assert (ar->start[n]);
5858 indexss = gfc_get_ss ();
5859 indexss->type = GFC_SS_SCALAR;
5860 indexss->expr = ar->start[n];
5861 indexss->next = gfc_ss_terminator;
5862 indexss->loop_chain = gfc_ss_terminator;
5863 newss->data.info.subscript[n] = indexss;
5867 /* We don't add anything for sections, just remember this
5868 dimension for later. */
5869 newss->data.info.dim[newss->data.info.dimen] = n;
5870 newss->data.info.dimen++;
5874 /* Create a GFC_SS_VECTOR index in which we can store
5875 the vector's descriptor. */
5876 indexss = gfc_get_ss ();
5877 indexss->type = GFC_SS_VECTOR;
5878 indexss->expr = ar->start[n];
5879 indexss->next = gfc_ss_terminator;
5880 indexss->loop_chain = gfc_ss_terminator;
5881 newss->data.info.subscript[n] = indexss;
5882 newss->data.info.dim[newss->data.info.dimen] = n;
5883 newss->data.info.dimen++;
5887 /* We should know what sort of section it is by now. */
5891 /* We should have at least one non-elemental dimension. */
5892 gcc_assert (newss->data.info.dimen > 0);
5897 /* We should know what sort of section it is by now. */
5906 /* Walk an expression operator. If only one operand of a binary expression is
5907 scalar, we must also add the scalar term to the SS chain. */
5910 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5916 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5917 if (expr->value.op.op2 == NULL)
5920 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5922 /* All operands are scalar. Pass back and let the caller deal with it. */
5926 /* All operands require scalarization. */
5927 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5930 /* One of the operands needs scalarization, the other is scalar.
5931 Create a gfc_ss for the scalar expression. */
5932 newss = gfc_get_ss ();
5933 newss->type = GFC_SS_SCALAR;
5936 /* First operand is scalar. We build the chain in reverse order, so
5937 add the scalar SS after the second operand. */
5939 while (head && head->next != ss)
5941 /* Check we haven't somehow broken the chain. */
5945 newss->expr = expr->value.op.op1;
5947 else /* head2 == head */
5949 gcc_assert (head2 == head);
5950 /* Second operand is scalar. */
5951 newss->next = head2;
5953 newss->expr = expr->value.op.op2;
5960 /* Reverse a SS chain. */
5963 gfc_reverse_ss (gfc_ss * ss)
5968 gcc_assert (ss != NULL);
5970 head = gfc_ss_terminator;
5971 while (ss != gfc_ss_terminator)
5974 /* Check we didn't somehow break the chain. */
5975 gcc_assert (next != NULL);
5985 /* Walk the arguments of an elemental function. */
5988 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5996 head = gfc_ss_terminator;
5999 for (; arg; arg = arg->next)
6004 newss = gfc_walk_subexpr (head, arg->expr);
6007 /* Scalar argument. */
6008 newss = gfc_get_ss ();
6010 newss->expr = arg->expr;
6020 while (tail->next != gfc_ss_terminator)
6027 /* If all the arguments are scalar we don't need the argument SS. */
6028 gfc_free_ss_chain (head);
6033 /* Add it onto the existing chain. */
6039 /* Walk a function call. Scalar functions are passed back, and taken out of
6040 scalarization loops. For elemental functions we walk their arguments.
6041 The result of functions returning arrays is stored in a temporary outside
6042 the loop, so that the function is only called once. Hence we do not need
6043 to walk their arguments. */
6046 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6049 gfc_intrinsic_sym *isym;
6052 isym = expr->value.function.isym;
6054 /* Handle intrinsic functions separately. */
6056 return gfc_walk_intrinsic_function (ss, expr, isym);
6058 sym = expr->value.function.esym;
6060 sym = expr->symtree->n.sym;
6062 /* A function that returns arrays. */
6063 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6065 newss = gfc_get_ss ();
6066 newss->type = GFC_SS_FUNCTION;
6069 newss->data.info.dimen = expr->rank;
6073 /* Walk the parameters of an elemental function. For now we always pass
6075 if (sym->attr.elemental)
6076 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6079 /* Scalar functions are OK as these are evaluated outside the scalarization
6080 loop. Pass back and let the caller deal with it. */
6085 /* An array temporary is constructed for array constructors. */
6088 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6093 newss = gfc_get_ss ();
6094 newss->type = GFC_SS_CONSTRUCTOR;
6097 newss->data.info.dimen = expr->rank;
6098 for (n = 0; n < expr->rank; n++)
6099 newss->data.info.dim[n] = n;
6105 /* Walk an expression. Add walked expressions to the head of the SS chain.
6106 A wholly scalar expression will not be added. */
6109 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6113 switch (expr->expr_type)
6116 head = gfc_walk_variable_expr (ss, expr);
6120 head = gfc_walk_op_expr (ss, expr);
6124 head = gfc_walk_function_expr (ss, expr);
6129 case EXPR_STRUCTURE:
6130 /* Pass back and let the caller deal with it. */
6134 head = gfc_walk_array_constructor (ss, expr);
6137 case EXPR_SUBSTRING:
6138 /* Pass back and let the caller deal with it. */
6142 internal_error ("bad expression type during walk (%d)",
6149 /* Entry point for expression walking.
6150 A return value equal to the passed chain means this is
6151 a scalar expression. It is up to the caller to take whatever action is
6152 necessary to translate these. */
6155 gfc_walk_expr (gfc_expr * expr)
6159 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6160 return gfc_reverse_ss (res);