1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subecripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "tree-gimple.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
106 gfc_array_dataptr_type (tree desc)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc)
147 type = TREE_TYPE (desc);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
150 field = TYPE_FIELDS (type);
151 gcc_assert (DATA_FIELD == 0);
153 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set_tuples. */
168 gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
169 tree desc, tree value,
174 type = TREE_TYPE (desc);
175 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
177 field = TYPE_FIELDS (type);
178 gcc_assert (DATA_FIELD == 0);
180 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
181 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
185 /* This provides address access to the data field. This should only be
186 used by array allocation, passing this on to the runtime. */
189 gfc_conv_descriptor_data_addr (tree desc)
193 type = TREE_TYPE (desc);
194 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
196 field = TYPE_FIELDS (type);
197 gcc_assert (DATA_FIELD == 0);
199 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
200 return build_fold_addr_expr (t);
204 gfc_conv_descriptor_offset (tree desc)
209 type = TREE_TYPE (desc);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
212 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
213 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
215 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
219 gfc_conv_descriptor_dtype (tree desc)
224 type = TREE_TYPE (desc);
225 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
227 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
228 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
230 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
234 gfc_conv_descriptor_dimension (tree desc, tree dim)
240 type = TREE_TYPE (desc);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
243 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
244 gcc_assert (field != NULL_TREE
245 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
246 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
248 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
249 tmp = gfc_build_array_ref (tmp, dim);
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 = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
269 gfc_conv_descriptor_lbound (tree desc, tree dim)
274 tmp = gfc_conv_descriptor_dimension (desc, dim);
275 field = TYPE_FIELDS (TREE_TYPE (tmp));
276 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
277 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
279 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
284 gfc_conv_descriptor_ubound (tree desc, tree dim)
289 tmp = gfc_conv_descriptor_dimension (desc, dim);
290 field = TYPE_FIELDS (TREE_TYPE (tmp));
291 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
292 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
294 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
299 /* Build a null array descriptor constructor. */
302 gfc_build_null_descriptor (tree type)
307 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
308 gcc_assert (DATA_FIELD == 0);
309 field = TYPE_FIELDS (type);
311 /* Set a NULL data pointer. */
312 tmp = build_constructor_single (type, field, null_pointer_node);
313 TREE_CONSTANT (tmp) = 1;
314 TREE_INVARIANT (tmp) = 1;
315 /* All other fields are ignored. */
321 /* Cleanup those #defines. */
326 #undef DIMENSION_FIELD
327 #undef STRIDE_SUBFIELD
328 #undef LBOUND_SUBFIELD
329 #undef UBOUND_SUBFIELD
332 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
333 flags & 1 = Main loop body.
334 flags & 2 = temp copy loop. */
337 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
339 for (; ss != gfc_ss_terminator; ss = ss->next)
340 ss->useflags = flags;
343 static void gfc_free_ss (gfc_ss *);
346 /* Free a gfc_ss chain. */
349 gfc_free_ss_chain (gfc_ss * ss)
353 while (ss != gfc_ss_terminator)
355 gcc_assert (ss != NULL);
366 gfc_free_ss (gfc_ss * ss)
373 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
375 if (ss->data.info.subscript[n])
376 gfc_free_ss_chain (ss->data.info.subscript[n]);
388 /* Free all the SS associated with a loop. */
391 gfc_cleanup_loop (gfc_loopinfo * loop)
397 while (ss != gfc_ss_terminator)
399 gcc_assert (ss != NULL);
400 next = ss->loop_chain;
407 /* Associate a SS chain with a loop. */
410 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
414 if (head == gfc_ss_terminator)
418 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
420 if (ss->next == gfc_ss_terminator)
421 ss->loop_chain = loop->ss;
423 ss->loop_chain = ss->next;
425 gcc_assert (ss == gfc_ss_terminator);
430 /* Generate an initializer for a static pointer or allocatable array. */
433 gfc_trans_static_array_pointer (gfc_symbol * sym)
437 gcc_assert (TREE_STATIC (sym->backend_decl));
438 /* Just zero the data member. */
439 type = TREE_TYPE (sym->backend_decl);
440 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
444 /* If the bounds of SE's loop have not yet been set, see if they can be
445 determined from array spec AS, which is the array spec of a called
446 function. MAPPING maps the callee's dummy arguments to the values
447 that the caller is passing. Add any initialization and finalization
451 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
452 gfc_se * se, gfc_array_spec * as)
460 if (as && as->type == AS_EXPLICIT)
461 for (dim = 0; dim < se->loop->dimen; dim++)
463 n = se->loop->order[dim];
464 if (se->loop->to[n] == NULL_TREE)
466 /* Evaluate the lower bound. */
467 gfc_init_se (&tmpse, NULL);
468 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
469 gfc_add_block_to_block (&se->pre, &tmpse.pre);
470 gfc_add_block_to_block (&se->post, &tmpse.post);
473 /* ...and the upper bound. */
474 gfc_init_se (&tmpse, NULL);
475 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
476 gfc_add_block_to_block (&se->pre, &tmpse.pre);
477 gfc_add_block_to_block (&se->post, &tmpse.post);
480 /* Set the upper bound of the loop to UPPER - LOWER. */
481 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
482 tmp = gfc_evaluate_now (tmp, &se->pre);
483 se->loop->to[n] = tmp;
489 /* Generate code to allocate an array temporary, or create a variable to
490 hold the data. If size is NULL, zero the descriptor so that the
491 callee will allocate the array. If DEALLOC is true, also generate code to
492 free the array afterwards.
494 Initialization code is added to PRE and finalization code to POST.
495 DYNAMIC is true if the caller may want to extend the array later
496 using realloc. This prevents us from putting the array on the stack. */
499 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
500 gfc_ss_info * info, tree size, tree nelem,
501 bool dynamic, bool dealloc)
507 desc = info->descriptor;
508 info->offset = gfc_index_zero_node;
509 if (size == NULL_TREE || integer_zerop (size))
511 /* A callee allocated array. */
512 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
517 /* Allocate the temporary. */
518 onstack = !dynamic && gfc_can_put_var_on_stack (size);
522 /* Make a temporary variable to hold the data. */
523 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
525 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
527 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
529 tmp = gfc_create_var (tmp, "A");
530 tmp = build_fold_addr_expr (tmp);
531 gfc_conv_descriptor_data_set (pre, desc, tmp);
535 /* Allocate memory to hold the data. */
536 tmp = gfc_call_malloc (pre, NULL, size);
537 tmp = gfc_evaluate_now (tmp, pre);
538 gfc_conv_descriptor_data_set (pre, desc, tmp);
541 info->data = gfc_conv_descriptor_data_get (desc);
543 /* The offset is zero because we create temporaries with a zero
545 tmp = gfc_conv_descriptor_offset (desc);
546 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
548 if (dealloc && !onstack)
550 /* Free the temporary. */
551 tmp = gfc_conv_descriptor_data_get (desc);
552 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
553 gfc_add_expr_to_block (post, tmp);
558 /* Generate code to create and initialize the descriptor for a temporary
559 array. This is used for both temporaries needed by the scalarizer, and
560 functions returning arrays. Adjusts the loop variables to be
561 zero-based, and calculates the loop bounds for callee allocated arrays.
562 Allocate the array unless it's callee allocated (we have a callee
563 allocated array if 'callee_alloc' is true, or if loop->to[n] is
564 NULL_TREE for any n). Also fills in the descriptor, data and offset
565 fields of info if known. Returns the size of the array, or NULL for a
566 callee allocated array.
568 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
572 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
573 gfc_loopinfo * loop, gfc_ss_info * info,
574 tree eltype, bool dynamic, bool dealloc,
587 gcc_assert (info->dimen > 0);
588 /* Set the lower bound to zero. */
589 for (dim = 0; dim < info->dimen; dim++)
591 n = loop->order[dim];
592 if (n < loop->temp_dim)
593 gcc_assert (integer_zerop (loop->from[n]));
596 /* Callee allocated arrays may not have a known bound yet. */
598 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
599 loop->to[n], loop->from[n]);
600 loop->from[n] = gfc_index_zero_node;
603 info->delta[dim] = gfc_index_zero_node;
604 info->start[dim] = gfc_index_zero_node;
605 info->end[dim] = gfc_index_zero_node;
606 info->stride[dim] = gfc_index_one_node;
607 info->dim[dim] = dim;
610 /* Initialize the descriptor. */
612 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
613 desc = gfc_create_var (type, "atmp");
614 GFC_DECL_PACKED_ARRAY (desc) = 1;
616 info->descriptor = desc;
617 size = gfc_index_one_node;
619 /* Fill in the array dtype. */
620 tmp = gfc_conv_descriptor_dtype (desc);
621 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
624 Fill in the bounds and stride. This is a packed array, so:
627 for (n = 0; n < rank; n++)
630 delta = ubound[n] + 1 - lbound[n];
633 size = size * sizeof(element);
638 for (n = 0; n < info->dimen; n++)
640 if (loop->to[n] == NULL_TREE)
642 /* For a callee allocated array express the loop bounds in terms
643 of the descriptor fields. */
644 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
645 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
646 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
652 /* Store the stride and bound components in the descriptor. */
653 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
654 gfc_add_modify_expr (pre, tmp, size);
656 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
657 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
659 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
660 gfc_add_modify_expr (pre, tmp, loop->to[n]);
662 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
663 loop->to[n], gfc_index_one_node);
665 /* Check whether the size for this dimension is negative. */
666 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
667 gfc_index_zero_node);
668 cond = gfc_evaluate_now (cond, pre);
673 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
675 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
676 size = gfc_evaluate_now (size, pre);
679 /* Get the size of the array. */
681 if (size && !callee_alloc)
683 /* If or_expr is true, then the extent in at least one
684 dimension is zero and the size is set to zero. */
685 size = fold_build3 (COND_EXPR, gfc_array_index_type,
686 or_expr, gfc_index_zero_node, size);
689 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
690 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
698 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
701 if (info->dimen > loop->temp_dim)
702 loop->temp_dim = info->dimen;
708 /* Generate code to transpose array EXPR by creating a new descriptor
709 in which the dimension specifications have been reversed. */
712 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
714 tree dest, src, dest_index, src_index;
716 gfc_ss_info *dest_info, *src_info;
717 gfc_ss *dest_ss, *src_ss;
723 src_ss = gfc_walk_expr (expr);
726 src_info = &src_ss->data.info;
727 dest_info = &dest_ss->data.info;
728 gcc_assert (dest_info->dimen == 2);
729 gcc_assert (src_info->dimen == 2);
731 /* Get a descriptor for EXPR. */
732 gfc_init_se (&src_se, NULL);
733 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
734 gfc_add_block_to_block (&se->pre, &src_se.pre);
735 gfc_add_block_to_block (&se->post, &src_se.post);
738 /* Allocate a new descriptor for the return value. */
739 dest = gfc_create_var (TREE_TYPE (src), "atmp");
740 dest_info->descriptor = dest;
743 /* Copy across the dtype field. */
744 gfc_add_modify_expr (&se->pre,
745 gfc_conv_descriptor_dtype (dest),
746 gfc_conv_descriptor_dtype (src));
748 /* Copy the dimension information, renumbering dimension 1 to 0 and
750 for (n = 0; n < 2; n++)
752 dest_info->delta[n] = gfc_index_zero_node;
753 dest_info->start[n] = gfc_index_zero_node;
754 dest_info->end[n] = gfc_index_zero_node;
755 dest_info->stride[n] = gfc_index_one_node;
756 dest_info->dim[n] = n;
758 dest_index = gfc_rank_cst[n];
759 src_index = gfc_rank_cst[1 - n];
761 gfc_add_modify_expr (&se->pre,
762 gfc_conv_descriptor_stride (dest, dest_index),
763 gfc_conv_descriptor_stride (src, src_index));
765 gfc_add_modify_expr (&se->pre,
766 gfc_conv_descriptor_lbound (dest, dest_index),
767 gfc_conv_descriptor_lbound (src, src_index));
769 gfc_add_modify_expr (&se->pre,
770 gfc_conv_descriptor_ubound (dest, dest_index),
771 gfc_conv_descriptor_ubound (src, src_index));
775 gcc_assert (integer_zerop (loop->from[n]));
776 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
777 gfc_conv_descriptor_ubound (dest, dest_index),
778 gfc_conv_descriptor_lbound (dest, dest_index));
782 /* Copy the data pointer. */
783 dest_info->data = gfc_conv_descriptor_data_get (src);
784 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
786 /* Copy the offset. This is not changed by transposition: the top-left
787 element is still at the same offset as before. */
788 dest_info->offset = gfc_conv_descriptor_offset (src);
789 gfc_add_modify_expr (&se->pre,
790 gfc_conv_descriptor_offset (dest),
793 if (dest_info->dimen > loop->temp_dim)
794 loop->temp_dim = dest_info->dimen;
798 /* Return the number of iterations in a loop that starts at START,
799 ends at END, and has step STEP. */
802 gfc_get_iteration_count (tree start, tree end, tree step)
807 type = TREE_TYPE (step);
808 tmp = fold_build2 (MINUS_EXPR, type, end, start);
809 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
810 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
811 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
812 return fold_convert (gfc_array_index_type, tmp);
816 /* Extend the data in array DESC by EXTRA elements. */
819 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
826 if (integer_zerop (extra))
829 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
831 /* Add EXTRA to the upper bound. */
832 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
833 gfc_add_modify_expr (pblock, ubound, tmp);
835 /* Get the value of the current data pointer. */
836 arg0 = gfc_conv_descriptor_data_get (desc);
838 /* Calculate the new array size. */
839 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
840 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
841 arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
843 /* Pick the appropriate realloc function. */
844 if (gfc_index_integer_kind == 4)
845 tmp = gfor_fndecl_internal_realloc;
846 else if (gfc_index_integer_kind == 8)
847 tmp = gfor_fndecl_internal_realloc64;
851 /* Set the new data pointer. */
852 tmp = build_call_expr (tmp, 2, arg0, arg1);
853 gfc_conv_descriptor_data_set (pblock, desc, tmp);
857 /* Return true if the bounds of iterator I can only be determined
861 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
863 return (i->start->expr_type != EXPR_CONSTANT
864 || i->end->expr_type != EXPR_CONSTANT
865 || i->step->expr_type != EXPR_CONSTANT);
869 /* Split the size of constructor element EXPR into the sum of two terms,
870 one of which can be determined at compile time and one of which must
871 be calculated at run time. Set *SIZE to the former and return true
872 if the latter might be nonzero. */
875 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
877 if (expr->expr_type == EXPR_ARRAY)
878 return gfc_get_array_constructor_size (size, expr->value.constructor);
879 else if (expr->rank > 0)
881 /* Calculate everything at run time. */
882 mpz_set_ui (*size, 0);
887 /* A single element. */
888 mpz_set_ui (*size, 1);
894 /* Like gfc_get_array_constructor_element_size, but applied to the whole
895 of array constructor C. */
898 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
905 mpz_set_ui (*size, 0);
910 for (; c; c = c->next)
913 if (i && gfc_iterator_has_dynamic_bounds (i))
917 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
920 /* Multiply the static part of the element size by the
921 number of iterations. */
922 mpz_sub (val, i->end->value.integer, i->start->value.integer);
923 mpz_fdiv_q (val, val, i->step->value.integer);
924 mpz_add_ui (val, val, 1);
925 if (mpz_sgn (val) > 0)
926 mpz_mul (len, len, val);
930 mpz_add (*size, *size, len);
939 /* Make sure offset is a variable. */
942 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
945 /* We should have already created the offset variable. We cannot
946 create it here because we may be in an inner scope. */
947 gcc_assert (*offsetvar != NULL_TREE);
948 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
949 *poffset = *offsetvar;
950 TREE_USED (*offsetvar) = 1;
954 /* Assign an element of an array constructor. */
957 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
958 tree offset, gfc_se * se, gfc_expr * expr)
962 gfc_conv_expr (se, expr);
964 /* Store the value. */
965 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
966 tmp = gfc_build_array_ref (tmp, offset);
967 if (expr->ts.type == BT_CHARACTER)
969 gfc_conv_string_parameter (se);
970 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
972 /* The temporary is an array of pointers. */
973 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
974 gfc_add_modify_expr (&se->pre, tmp, se->expr);
978 /* The temporary is an array of string values. */
979 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
980 /* We know the temporary and the value will be the same length,
981 so can use memcpy. */
982 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
983 tmp, se->expr, se->string_length);
984 gfc_add_expr_to_block (&se->pre, tmp);
989 /* TODO: Should the frontend already have done this conversion? */
990 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
991 gfc_add_modify_expr (&se->pre, tmp, se->expr);
994 gfc_add_block_to_block (pblock, &se->pre);
995 gfc_add_block_to_block (pblock, &se->post);
999 /* Add the contents of an array to the constructor. DYNAMIC is as for
1000 gfc_trans_array_constructor_value. */
1003 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1004 tree type ATTRIBUTE_UNUSED,
1005 tree desc, gfc_expr * expr,
1006 tree * poffset, tree * offsetvar,
1017 /* We need this to be a variable so we can increment it. */
1018 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1020 gfc_init_se (&se, NULL);
1022 /* Walk the array expression. */
1023 ss = gfc_walk_expr (expr);
1024 gcc_assert (ss != gfc_ss_terminator);
1026 /* Initialize the scalarizer. */
1027 gfc_init_loopinfo (&loop);
1028 gfc_add_ss_to_loop (&loop, ss);
1030 /* Initialize the loop. */
1031 gfc_conv_ss_startstride (&loop);
1032 gfc_conv_loop_setup (&loop);
1034 /* Make sure the constructed array has room for the new data. */
1037 /* Set SIZE to the total number of elements in the subarray. */
1038 size = gfc_index_one_node;
1039 for (n = 0; n < loop.dimen; n++)
1041 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1042 gfc_index_one_node);
1043 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1046 /* Grow the constructed array by SIZE elements. */
1047 gfc_grow_array (&loop.pre, desc, size);
1050 /* Make the loop body. */
1051 gfc_mark_ss_chain_used (ss, 1);
1052 gfc_start_scalarized_body (&loop, &body);
1053 gfc_copy_loopinfo_to_se (&se, &loop);
1056 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1057 gcc_assert (se.ss == gfc_ss_terminator);
1059 /* Increment the offset. */
1060 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1061 gfc_add_modify_expr (&body, *poffset, tmp);
1063 /* Finish the loop. */
1064 gfc_trans_scalarizing_loops (&loop, &body);
1065 gfc_add_block_to_block (&loop.pre, &loop.post);
1066 tmp = gfc_finish_block (&loop.pre);
1067 gfc_add_expr_to_block (pblock, tmp);
1069 gfc_cleanup_loop (&loop);
1073 /* Assign the values to the elements of an array constructor. DYNAMIC
1074 is true if descriptor DESC only contains enough data for the static
1075 size calculated by gfc_get_array_constructor_size. When true, memory
1076 for the dynamic parts must be allocated using realloc. */
1079 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1080 tree desc, gfc_constructor * c,
1081 tree * poffset, tree * offsetvar,
1090 for (; c; c = c->next)
1092 /* If this is an iterator or an array, the offset must be a variable. */
1093 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1094 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1096 gfc_start_block (&body);
1098 if (c->expr->expr_type == EXPR_ARRAY)
1100 /* Array constructors can be nested. */
1101 gfc_trans_array_constructor_value (&body, type, desc,
1102 c->expr->value.constructor,
1103 poffset, offsetvar, dynamic);
1105 else if (c->expr->rank > 0)
1107 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1108 poffset, offsetvar, dynamic);
1112 /* This code really upsets the gimplifier so don't bother for now. */
1119 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1126 /* Scalar values. */
1127 gfc_init_se (&se, NULL);
1128 gfc_trans_array_ctor_element (&body, desc, *poffset,
1131 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1132 *poffset, gfc_index_one_node);
1136 /* Collect multiple scalar constants into a constructor. */
1144 /* Count the number of consecutive scalar constants. */
1145 while (p && !(p->iterator
1146 || p->expr->expr_type != EXPR_CONSTANT))
1148 gfc_init_se (&se, NULL);
1149 gfc_conv_constant (&se, p->expr);
1150 if (p->expr->ts.type == BT_CHARACTER
1151 && POINTER_TYPE_P (type))
1153 /* For constant character array constructors we build
1154 an array of pointers. */
1155 se.expr = gfc_build_addr_expr (pchar_type_node,
1159 list = tree_cons (NULL_TREE, se.expr, list);
1164 bound = build_int_cst (NULL_TREE, n - 1);
1165 /* Create an array type to hold them. */
1166 tmptype = build_range_type (gfc_array_index_type,
1167 gfc_index_zero_node, bound);
1168 tmptype = build_array_type (type, tmptype);
1170 init = build_constructor_from_list (tmptype, nreverse (list));
1171 TREE_CONSTANT (init) = 1;
1172 TREE_INVARIANT (init) = 1;
1173 TREE_STATIC (init) = 1;
1174 /* Create a static variable to hold the data. */
1175 tmp = gfc_create_var (tmptype, "data");
1176 TREE_STATIC (tmp) = 1;
1177 TREE_CONSTANT (tmp) = 1;
1178 TREE_INVARIANT (tmp) = 1;
1179 TREE_READONLY (tmp) = 1;
1180 DECL_INITIAL (tmp) = init;
1183 /* Use BUILTIN_MEMCPY to assign the values. */
1184 tmp = gfc_conv_descriptor_data_get (desc);
1185 tmp = build_fold_indirect_ref (tmp);
1186 tmp = gfc_build_array_ref (tmp, *poffset);
1187 tmp = build_fold_addr_expr (tmp);
1188 init = build_fold_addr_expr (init);
1190 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1191 bound = build_int_cst (NULL_TREE, n * size);
1192 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1194 gfc_add_expr_to_block (&body, tmp);
1196 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1197 *poffset, build_int_cst (NULL_TREE, n));
1199 if (!INTEGER_CST_P (*poffset))
1201 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1202 *poffset = *offsetvar;
1206 /* The frontend should already have done any expansions possible
1210 /* Pass the code as is. */
1211 tmp = gfc_finish_block (&body);
1212 gfc_add_expr_to_block (pblock, tmp);
1216 /* Build the implied do-loop. */
1226 loopbody = gfc_finish_block (&body);
1228 gfc_init_se (&se, NULL);
1229 gfc_conv_expr (&se, c->iterator->var);
1230 gfc_add_block_to_block (pblock, &se.pre);
1233 /* Make a temporary, store the current value in that
1234 and return it, once the loop is done. */
1235 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1236 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1238 /* Initialize the loop. */
1239 gfc_init_se (&se, NULL);
1240 gfc_conv_expr_val (&se, c->iterator->start);
1241 gfc_add_block_to_block (pblock, &se.pre);
1242 gfc_add_modify_expr (pblock, loopvar, se.expr);
1244 gfc_init_se (&se, NULL);
1245 gfc_conv_expr_val (&se, c->iterator->end);
1246 gfc_add_block_to_block (pblock, &se.pre);
1247 end = gfc_evaluate_now (se.expr, pblock);
1249 gfc_init_se (&se, NULL);
1250 gfc_conv_expr_val (&se, c->iterator->step);
1251 gfc_add_block_to_block (pblock, &se.pre);
1252 step = gfc_evaluate_now (se.expr, pblock);
1254 /* If this array expands dynamically, and the number of iterations
1255 is not constant, we won't have allocated space for the static
1256 part of C->EXPR's size. Do that now. */
1257 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1259 /* Get the number of iterations. */
1260 tmp = gfc_get_iteration_count (loopvar, end, step);
1262 /* Get the static part of C->EXPR's size. */
1263 gfc_get_array_constructor_element_size (&size, c->expr);
1264 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1266 /* Grow the array by TMP * TMP2 elements. */
1267 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1268 gfc_grow_array (pblock, desc, tmp);
1271 /* Generate the loop body. */
1272 exit_label = gfc_build_label_decl (NULL_TREE);
1273 gfc_start_block (&body);
1275 /* Generate the exit condition. Depending on the sign of
1276 the step variable we have to generate the correct
1278 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1279 build_int_cst (TREE_TYPE (step), 0));
1280 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1281 build2 (GT_EXPR, boolean_type_node,
1283 build2 (LT_EXPR, boolean_type_node,
1285 tmp = build1_v (GOTO_EXPR, exit_label);
1286 TREE_USED (exit_label) = 1;
1287 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1288 gfc_add_expr_to_block (&body, tmp);
1290 /* The main loop body. */
1291 gfc_add_expr_to_block (&body, loopbody);
1293 /* Increase loop variable by step. */
1294 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1295 gfc_add_modify_expr (&body, loopvar, tmp);
1297 /* Finish the loop. */
1298 tmp = gfc_finish_block (&body);
1299 tmp = build1_v (LOOP_EXPR, tmp);
1300 gfc_add_expr_to_block (pblock, tmp);
1302 /* Add the exit label. */
1303 tmp = build1_v (LABEL_EXPR, exit_label);
1304 gfc_add_expr_to_block (pblock, tmp);
1306 /* Restore the original value of the loop counter. */
1307 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1314 /* Figure out the string length of a variable reference expression.
1315 Used by get_array_ctor_strlen. */
1318 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1324 /* Don't bother if we already know the length is a constant. */
1325 if (*len && INTEGER_CST_P (*len))
1328 ts = &expr->symtree->n.sym->ts;
1329 for (ref = expr->ref; ref; ref = ref->next)
1334 /* Array references don't change the string length. */
1338 /* Use the length of the component. */
1339 ts = &ref->u.c.component->ts;
1343 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1344 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1346 mpz_init_set_ui (char_len, 1);
1347 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1348 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1349 *len = gfc_conv_mpz_to_tree (char_len,
1350 gfc_default_character_kind);
1351 *len = convert (gfc_charlen_type_node, *len);
1352 mpz_clear (char_len);
1356 /* TODO: Substrings are tricky because we can't evaluate the
1357 expression more than once. For now we just give up, and hope
1358 we can figure it out elsewhere. */
1363 *len = ts->cl->backend_decl;
1367 /* Figure out the string length of a character array constructor.
1368 Returns TRUE if all elements are character constants. */
1371 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1376 for (; c; c = c->next)
1378 switch (c->expr->expr_type)
1381 if (!(*len && INTEGER_CST_P (*len)))
1382 *len = build_int_cstu (gfc_charlen_type_node,
1383 c->expr->value.character.length);
1387 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1393 get_array_ctor_var_strlen (c->expr, len);
1399 /* Hope that whatever we have possesses a constant character
1401 if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl)
1403 gfc_conv_const_charlen (c->expr->ts.cl);
1404 *len = c->expr->ts.cl->backend_decl;
1406 /* TODO: For now we just ignore anything we don't know how to
1407 handle, and hope we can figure it out a different way. */
1415 /* Check whether the array constructor C consists entirely of constant
1416 elements, and if so returns the number of those elements, otherwise
1417 return zero. Note, an empty or NULL array constructor returns zero. */
1419 unsigned HOST_WIDE_INT
1420 gfc_constant_array_constructor_p (gfc_constructor * c)
1422 unsigned HOST_WIDE_INT nelem = 0;
1427 || c->expr->rank > 0
1428 || c->expr->expr_type != EXPR_CONSTANT)
1437 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1438 and the tree type of it's elements, TYPE, return a static constant
1439 variable that is compile-time initialized. */
1442 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1444 tree tmptype, list, init, tmp;
1445 HOST_WIDE_INT nelem;
1451 /* First traverse the constructor list, converting the constants
1452 to tree to build an initializer. */
1455 c = expr->value.constructor;
1458 gfc_init_se (&se, NULL);
1459 gfc_conv_constant (&se, c->expr);
1460 if (c->expr->ts.type == BT_CHARACTER
1461 && POINTER_TYPE_P (type))
1462 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1463 list = tree_cons (NULL_TREE, se.expr, list);
1468 /* Next determine the tree type for the array. We use the gfortran
1469 front-end's gfc_get_nodesc_array_type in order to create a suitable
1470 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1472 memset (&as, 0, sizeof (gfc_array_spec));
1474 as.rank = expr->rank;
1475 as.type = AS_EXPLICIT;
1478 as.lower[0] = gfc_int_expr (0);
1479 as.upper[0] = gfc_int_expr (nelem - 1);
1482 for (i = 0; i < expr->rank; i++)
1484 int tmp = (int) mpz_get_si (expr->shape[i]);
1485 as.lower[i] = gfc_int_expr (0);
1486 as.upper[i] = gfc_int_expr (tmp - 1);
1489 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1491 init = build_constructor_from_list (tmptype, nreverse (list));
1493 TREE_CONSTANT (init) = 1;
1494 TREE_INVARIANT (init) = 1;
1495 TREE_STATIC (init) = 1;
1497 tmp = gfc_create_var (tmptype, "A");
1498 TREE_STATIC (tmp) = 1;
1499 TREE_CONSTANT (tmp) = 1;
1500 TREE_INVARIANT (tmp) = 1;
1501 TREE_READONLY (tmp) = 1;
1502 DECL_INITIAL (tmp) = init;
1508 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1509 This mostly initializes the scalarizer state info structure with the
1510 appropriate values to directly use the array created by the function
1511 gfc_build_constant_array_constructor. */
1514 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1515 gfc_ss * ss, tree type)
1521 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1523 info = &ss->data.info;
1525 info->descriptor = tmp;
1526 info->data = build_fold_addr_expr (tmp);
1527 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1530 for (i = 0; i < info->dimen; i++)
1532 info->delta[i] = gfc_index_zero_node;
1533 info->start[i] = gfc_index_zero_node;
1534 info->end[i] = gfc_index_zero_node;
1535 info->stride[i] = gfc_index_one_node;
1539 if (info->dimen > loop->temp_dim)
1540 loop->temp_dim = info->dimen;
1543 /* Helper routine of gfc_trans_array_constructor to determine if the
1544 bounds of the loop specified by LOOP are constant and simple enough
1545 to use with gfc_trans_constant_array_constructor. Returns the
1546 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1549 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1551 tree size = gfc_index_one_node;
1555 for (i = 0; i < loop->dimen; i++)
1557 /* If the bounds aren't constant, return NULL_TREE. */
1558 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1560 if (!integer_zerop (loop->from[i]))
1562 /* Only allow non-zero "from" in one-dimensional arrays. */
1563 if (loop->dimen != 1)
1565 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1566 loop->to[i], loop->from[i]);
1570 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1571 tmp, gfc_index_one_node);
1572 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1579 /* Array constructors are handled by constructing a temporary, then using that
1580 within the scalarization loop. This is not optimal, but seems by far the
1584 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1593 ss->data.info.dimen = loop->dimen;
1595 c = ss->expr->value.constructor;
1596 if (ss->expr->ts.type == BT_CHARACTER)
1598 bool const_string = get_array_ctor_strlen (c, &ss->string_length);
1599 if (!ss->string_length)
1600 gfc_todo_error ("complex character array constructors");
1602 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1604 type = build_pointer_type (type);
1607 type = gfc_typenode_for_spec (&ss->expr->ts);
1609 /* See if the constructor determines the loop bounds. */
1611 if (loop->to[0] == NULL_TREE)
1615 /* We should have a 1-dimensional, zero-based loop. */
1616 gcc_assert (loop->dimen == 1);
1617 gcc_assert (integer_zerop (loop->from[0]));
1619 /* Split the constructor size into a static part and a dynamic part.
1620 Allocate the static size up-front and record whether the dynamic
1621 size might be nonzero. */
1623 dynamic = gfc_get_array_constructor_size (&size, c);
1624 mpz_sub_ui (size, size, 1);
1625 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1629 /* Special case constant array constructors. */
1632 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1635 tree size = constant_array_constructor_loop_size (loop);
1636 if (size && compare_tree_int (size, nelem) == 0)
1638 gfc_trans_constant_array_constructor (loop, ss, type);
1644 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1645 type, dynamic, true, false);
1647 desc = ss->data.info.descriptor;
1648 offset = gfc_index_zero_node;
1649 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1650 TREE_USED (offsetvar) = 0;
1651 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1652 &offset, &offsetvar, dynamic);
1654 /* If the array grows dynamically, the upper bound of the loop variable
1655 is determined by the array's final upper bound. */
1657 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1659 if (TREE_USED (offsetvar))
1660 pushdecl (offsetvar);
1662 gcc_assert (INTEGER_CST_P (offset));
1664 /* Disable bound checking for now because it's probably broken. */
1665 if (flag_bounds_check)
1673 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1674 called after evaluating all of INFO's vector dimensions. Go through
1675 each such vector dimension and see if we can now fill in any missing
1679 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1688 for (n = 0; n < loop->dimen; n++)
1691 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1692 && loop->to[n] == NULL)
1694 /* Loop variable N indexes vector dimension DIM, and we don't
1695 yet know the upper bound of loop variable N. Set it to the
1696 difference between the vector's upper and lower bounds. */
1697 gcc_assert (loop->from[n] == gfc_index_zero_node);
1698 gcc_assert (info->subscript[dim]
1699 && info->subscript[dim]->type == GFC_SS_VECTOR);
1701 gfc_init_se (&se, NULL);
1702 desc = info->subscript[dim]->data.info.descriptor;
1703 zero = gfc_rank_cst[0];
1704 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1705 gfc_conv_descriptor_ubound (desc, zero),
1706 gfc_conv_descriptor_lbound (desc, zero));
1707 tmp = gfc_evaluate_now (tmp, &loop->pre);
1714 /* Add the pre and post chains for all the scalar expressions in a SS chain
1715 to loop. This is called after the loop parameters have been calculated,
1716 but before the actual scalarizing loops. */
1719 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1724 /* TODO: This can generate bad code if there are ordering dependencies.
1725 eg. a callee allocated function and an unknown size constructor. */
1726 gcc_assert (ss != NULL);
1728 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1735 /* Scalar expression. Evaluate this now. This includes elemental
1736 dimension indices, but not array section bounds. */
1737 gfc_init_se (&se, NULL);
1738 gfc_conv_expr (&se, ss->expr);
1739 gfc_add_block_to_block (&loop->pre, &se.pre);
1741 if (ss->expr->ts.type != BT_CHARACTER)
1743 /* Move the evaluation of scalar expressions outside the
1744 scalarization loop. */
1746 se.expr = convert(gfc_array_index_type, se.expr);
1747 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1748 gfc_add_block_to_block (&loop->pre, &se.post);
1751 gfc_add_block_to_block (&loop->post, &se.post);
1753 ss->data.scalar.expr = se.expr;
1754 ss->string_length = se.string_length;
1757 case GFC_SS_REFERENCE:
1758 /* Scalar reference. Evaluate this now. */
1759 gfc_init_se (&se, NULL);
1760 gfc_conv_expr_reference (&se, ss->expr);
1761 gfc_add_block_to_block (&loop->pre, &se.pre);
1762 gfc_add_block_to_block (&loop->post, &se.post);
1764 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1765 ss->string_length = se.string_length;
1768 case GFC_SS_SECTION:
1769 /* Add the expressions for scalar and vector subscripts. */
1770 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1771 if (ss->data.info.subscript[n])
1772 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1774 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1778 /* Get the vector's descriptor and store it in SS. */
1779 gfc_init_se (&se, NULL);
1780 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1781 gfc_add_block_to_block (&loop->pre, &se.pre);
1782 gfc_add_block_to_block (&loop->post, &se.post);
1783 ss->data.info.descriptor = se.expr;
1786 case GFC_SS_INTRINSIC:
1787 gfc_add_intrinsic_ss_code (loop, ss);
1790 case GFC_SS_FUNCTION:
1791 /* Array function return value. We call the function and save its
1792 result in a temporary for use inside the loop. */
1793 gfc_init_se (&se, NULL);
1796 gfc_conv_expr (&se, ss->expr);
1797 gfc_add_block_to_block (&loop->pre, &se.pre);
1798 gfc_add_block_to_block (&loop->post, &se.post);
1799 ss->string_length = se.string_length;
1802 case GFC_SS_CONSTRUCTOR:
1803 gfc_trans_array_constructor (loop, ss);
1807 case GFC_SS_COMPONENT:
1808 /* Do nothing. These are handled elsewhere. */
1818 /* Translate expressions for the descriptor and data pointer of a SS. */
1822 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1827 /* Get the descriptor for the array to be scalarized. */
1828 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1829 gfc_init_se (&se, NULL);
1830 se.descriptor_only = 1;
1831 gfc_conv_expr_lhs (&se, ss->expr);
1832 gfc_add_block_to_block (block, &se.pre);
1833 ss->data.info.descriptor = se.expr;
1834 ss->string_length = se.string_length;
1838 /* Also the data pointer. */
1839 tmp = gfc_conv_array_data (se.expr);
1840 /* If this is a variable or address of a variable we use it directly.
1841 Otherwise we must evaluate it now to avoid breaking dependency
1842 analysis by pulling the expressions for elemental array indices
1845 || (TREE_CODE (tmp) == ADDR_EXPR
1846 && DECL_P (TREE_OPERAND (tmp, 0)))))
1847 tmp = gfc_evaluate_now (tmp, block);
1848 ss->data.info.data = tmp;
1850 tmp = gfc_conv_array_offset (se.expr);
1851 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1856 /* Initialize a gfc_loopinfo structure. */
1859 gfc_init_loopinfo (gfc_loopinfo * loop)
1863 memset (loop, 0, sizeof (gfc_loopinfo));
1864 gfc_init_block (&loop->pre);
1865 gfc_init_block (&loop->post);
1867 /* Initially scalarize in order. */
1868 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1871 loop->ss = gfc_ss_terminator;
1875 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1879 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1885 /* Return an expression for the data pointer of an array. */
1888 gfc_conv_array_data (tree descriptor)
1892 type = TREE_TYPE (descriptor);
1893 if (GFC_ARRAY_TYPE_P (type))
1895 if (TREE_CODE (type) == POINTER_TYPE)
1899 /* Descriptorless arrays. */
1900 return build_fold_addr_expr (descriptor);
1904 return gfc_conv_descriptor_data_get (descriptor);
1908 /* Return an expression for the base offset of an array. */
1911 gfc_conv_array_offset (tree descriptor)
1915 type = TREE_TYPE (descriptor);
1916 if (GFC_ARRAY_TYPE_P (type))
1917 return GFC_TYPE_ARRAY_OFFSET (type);
1919 return gfc_conv_descriptor_offset (descriptor);
1923 /* Get an expression for the array stride. */
1926 gfc_conv_array_stride (tree descriptor, int dim)
1931 type = TREE_TYPE (descriptor);
1933 /* For descriptorless arrays use the array size. */
1934 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1935 if (tmp != NULL_TREE)
1938 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1943 /* Like gfc_conv_array_stride, but for the lower bound. */
1946 gfc_conv_array_lbound (tree descriptor, int dim)
1951 type = TREE_TYPE (descriptor);
1953 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1954 if (tmp != NULL_TREE)
1957 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1962 /* Like gfc_conv_array_stride, but for the upper bound. */
1965 gfc_conv_array_ubound (tree descriptor, int dim)
1970 type = TREE_TYPE (descriptor);
1972 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1973 if (tmp != NULL_TREE)
1976 /* This should only ever happen when passing an assumed shape array
1977 as an actual parameter. The value will never be used. */
1978 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1979 return gfc_index_zero_node;
1981 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1986 /* Generate code to perform an array index bound check. */
1989 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
1995 const char * name = NULL;
1997 if (!flag_bounds_check)
2000 index = gfc_evaluate_now (index, &se->pre);
2002 /* We find a name for the error message. */
2004 name = se->ss->expr->symtree->name;
2006 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2007 && se->loop->ss->expr->symtree)
2008 name = se->loop->ss->expr->symtree->name;
2010 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2011 && se->loop->ss->loop_chain->expr
2012 && se->loop->ss->loop_chain->expr->symtree)
2013 name = se->loop->ss->loop_chain->expr->symtree->name;
2015 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2016 && se->loop->ss->loop_chain->expr->symtree)
2017 name = se->loop->ss->loop_chain->expr->symtree->name;
2019 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2021 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2022 && se->loop->ss->expr->value.function.name)
2023 name = se->loop->ss->expr->value.function.name;
2025 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2026 || se->loop->ss->type == GFC_SS_SCALAR)
2027 name = "unnamed constant";
2030 /* Check lower bound. */
2031 tmp = gfc_conv_array_lbound (descriptor, n);
2032 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2034 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2035 gfc_msg_fault, name, n+1);
2037 asprintf (&msg, "%s, lower bound of dimension %d exceeded",
2038 gfc_msg_fault, n+1);
2039 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2042 /* Check upper bound. */
2043 tmp = gfc_conv_array_ubound (descriptor, n);
2044 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2046 asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
2047 gfc_msg_fault, name, n+1);
2049 asprintf (&msg, "%s, upper bound of dimension %d exceeded",
2050 gfc_msg_fault, n+1);
2051 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2058 /* Return the offset for an index. Performs bound checking for elemental
2059 dimensions. Single element references are processed separately. */
2062 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2063 gfc_array_ref * ar, tree stride)
2069 /* Get the index into the array for this dimension. */
2072 gcc_assert (ar->type != AR_ELEMENT);
2073 switch (ar->dimen_type[dim])
2076 gcc_assert (i == -1);
2077 /* Elemental dimension. */
2078 gcc_assert (info->subscript[dim]
2079 && info->subscript[dim]->type == GFC_SS_SCALAR);
2080 /* We've already translated this value outside the loop. */
2081 index = info->subscript[dim]->data.scalar.expr;
2083 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2084 || dim < ar->dimen - 1)
2085 index = gfc_trans_array_bound_check (se, info->descriptor,
2086 index, dim, &ar->where);
2090 gcc_assert (info && se->loop);
2091 gcc_assert (info->subscript[dim]
2092 && info->subscript[dim]->type == GFC_SS_VECTOR);
2093 desc = info->subscript[dim]->data.info.descriptor;
2095 /* Get a zero-based index into the vector. */
2096 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2097 se->loop->loopvar[i], se->loop->from[i]);
2099 /* Multiply the index by the stride. */
2100 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2101 index, gfc_conv_array_stride (desc, 0));
2103 /* Read the vector to get an index into info->descriptor. */
2104 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2105 index = gfc_build_array_ref (data, index);
2106 index = gfc_evaluate_now (index, &se->pre);
2108 /* Do any bounds checking on the final info->descriptor index. */
2109 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2110 || dim < ar->dimen - 1)
2111 index = gfc_trans_array_bound_check (se, info->descriptor,
2112 index, dim, &ar->where);
2116 /* Scalarized dimension. */
2117 gcc_assert (info && se->loop);
2119 /* Multiply the loop variable by the stride and delta. */
2120 index = se->loop->loopvar[i];
2121 if (!integer_onep (info->stride[i]))
2122 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2124 if (!integer_zerop (info->delta[i]))
2125 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2135 /* Temporary array or derived type component. */
2136 gcc_assert (se->loop);
2137 index = se->loop->loopvar[se->loop->order[i]];
2138 if (!integer_zerop (info->delta[i]))
2139 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2140 index, info->delta[i]);
2143 /* Multiply by the stride. */
2144 if (!integer_onep (stride))
2145 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2151 /* Build a scalarized reference to an array. */
2154 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2161 info = &se->ss->data.info;
2163 n = se->loop->order[0];
2167 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2169 /* Add the offset for this dimension to the stored offset for all other
2171 if (!integer_zerop (info->offset))
2172 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2174 tmp = build_fold_indirect_ref (info->data);
2175 se->expr = gfc_build_array_ref (tmp, index);
2179 /* Translate access of temporary array. */
2182 gfc_conv_tmp_array_ref (gfc_se * se)
2184 se->string_length = se->ss->string_length;
2185 gfc_conv_scalarized_array_ref (se, NULL);
2189 /* Build an array reference. se->expr already holds the array descriptor.
2190 This should be either a variable, indirect variable reference or component
2191 reference. For arrays which do not have a descriptor, se->expr will be
2193 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2196 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2205 /* Handle scalarized references separately. */
2206 if (ar->type != AR_ELEMENT)
2208 gfc_conv_scalarized_array_ref (se, ar);
2209 gfc_advance_se_ss_chain (se);
2213 index = gfc_index_zero_node;
2215 /* Calculate the offsets from all the dimensions. */
2216 for (n = 0; n < ar->dimen; n++)
2218 /* Calculate the index for this dimension. */
2219 gfc_init_se (&indexse, se);
2220 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2221 gfc_add_block_to_block (&se->pre, &indexse.pre);
2223 if (flag_bounds_check &&
2224 ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2225 || n < ar->dimen - 1))
2227 /* Check array bounds. */
2231 tmp = gfc_conv_array_lbound (se->expr, n);
2232 cond = fold_build2 (LT_EXPR, boolean_type_node,
2234 asprintf (&msg, "%s for array '%s', "
2235 "lower bound of dimension %d exceeded", gfc_msg_fault,
2237 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2240 tmp = gfc_conv_array_ubound (se->expr, n);
2241 cond = fold_build2 (GT_EXPR, boolean_type_node,
2243 asprintf (&msg, "%s for array '%s', "
2244 "upper bound of dimension %d exceeded", gfc_msg_fault,
2246 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2250 /* Multiply the index by the stride. */
2251 stride = gfc_conv_array_stride (se->expr, n);
2252 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2255 /* And add it to the total. */
2256 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2259 tmp = gfc_conv_array_offset (se->expr);
2260 if (!integer_zerop (tmp))
2261 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2263 /* Access the calculated element. */
2264 tmp = gfc_conv_array_data (se->expr);
2265 tmp = build_fold_indirect_ref (tmp);
2266 se->expr = gfc_build_array_ref (tmp, index);
2270 /* Generate the code to be executed immediately before entering a
2271 scalarization loop. */
2274 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2275 stmtblock_t * pblock)
2284 /* This code will be executed before entering the scalarization loop
2285 for this dimension. */
2286 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2288 if ((ss->useflags & flag) == 0)
2291 if (ss->type != GFC_SS_SECTION
2292 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2293 && ss->type != GFC_SS_COMPONENT)
2296 info = &ss->data.info;
2298 if (dim >= info->dimen)
2301 if (dim == info->dimen - 1)
2303 /* For the outermost loop calculate the offset due to any
2304 elemental dimensions. It will have been initialized with the
2305 base offset of the array. */
2308 for (i = 0; i < info->ref->u.ar.dimen; i++)
2310 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2313 gfc_init_se (&se, NULL);
2315 se.expr = info->descriptor;
2316 stride = gfc_conv_array_stride (info->descriptor, i);
2317 index = gfc_conv_array_index_offset (&se, info, i, -1,
2320 gfc_add_block_to_block (pblock, &se.pre);
2322 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2323 info->offset, index);
2324 info->offset = gfc_evaluate_now (info->offset, pblock);
2328 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2331 stride = gfc_conv_array_stride (info->descriptor, 0);
2333 /* Calculate the stride of the innermost loop. Hopefully this will
2334 allow the backend optimizers to do their stuff more effectively.
2336 info->stride0 = gfc_evaluate_now (stride, pblock);
2340 /* Add the offset for the previous loop dimension. */
2345 ar = &info->ref->u.ar;
2346 i = loop->order[dim + 1];
2354 gfc_init_se (&se, NULL);
2356 se.expr = info->descriptor;
2357 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2358 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2360 gfc_add_block_to_block (pblock, &se.pre);
2361 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2362 info->offset, index);
2363 info->offset = gfc_evaluate_now (info->offset, pblock);
2366 /* Remember this offset for the second loop. */
2367 if (dim == loop->temp_dim - 1)
2368 info->saved_offset = info->offset;
2373 /* Start a scalarized expression. Creates a scope and declares loop
2377 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2383 gcc_assert (!loop->array_parameter);
2385 for (dim = loop->dimen - 1; dim >= 0; dim--)
2387 n = loop->order[dim];
2389 gfc_start_block (&loop->code[n]);
2391 /* Create the loop variable. */
2392 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2394 if (dim < loop->temp_dim)
2398 /* Calculate values that will be constant within this loop. */
2399 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2401 gfc_start_block (pbody);
2405 /* Generates the actual loop code for a scalarization loop. */
2408 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2409 stmtblock_t * pbody)
2417 loopbody = gfc_finish_block (pbody);
2419 /* Initialize the loopvar. */
2420 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2422 exit_label = gfc_build_label_decl (NULL_TREE);
2424 /* Generate the loop body. */
2425 gfc_init_block (&block);
2427 /* The exit condition. */
2428 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2429 tmp = build1_v (GOTO_EXPR, exit_label);
2430 TREE_USED (exit_label) = 1;
2431 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2432 gfc_add_expr_to_block (&block, tmp);
2434 /* The main body. */
2435 gfc_add_expr_to_block (&block, loopbody);
2437 /* Increment the loopvar. */
2438 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2439 loop->loopvar[n], gfc_index_one_node);
2440 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2442 /* Build the loop. */
2443 tmp = gfc_finish_block (&block);
2444 tmp = build1_v (LOOP_EXPR, tmp);
2445 gfc_add_expr_to_block (&loop->code[n], tmp);
2447 /* Add the exit label. */
2448 tmp = build1_v (LABEL_EXPR, exit_label);
2449 gfc_add_expr_to_block (&loop->code[n], tmp);
2453 /* Finishes and generates the loops for a scalarized expression. */
2456 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2461 stmtblock_t *pblock;
2465 /* Generate the loops. */
2466 for (dim = 0; dim < loop->dimen; dim++)
2468 n = loop->order[dim];
2469 gfc_trans_scalarized_loop_end (loop, n, pblock);
2470 loop->loopvar[n] = NULL_TREE;
2471 pblock = &loop->code[n];
2474 tmp = gfc_finish_block (pblock);
2475 gfc_add_expr_to_block (&loop->pre, tmp);
2477 /* Clear all the used flags. */
2478 for (ss = loop->ss; ss; ss = ss->loop_chain)
2483 /* Finish the main body of a scalarized expression, and start the secondary
2487 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2491 stmtblock_t *pblock;
2495 /* We finish as many loops as are used by the temporary. */
2496 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2498 n = loop->order[dim];
2499 gfc_trans_scalarized_loop_end (loop, n, pblock);
2500 loop->loopvar[n] = NULL_TREE;
2501 pblock = &loop->code[n];
2504 /* We don't want to finish the outermost loop entirely. */
2505 n = loop->order[loop->temp_dim - 1];
2506 gfc_trans_scalarized_loop_end (loop, n, pblock);
2508 /* Restore the initial offsets. */
2509 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2511 if ((ss->useflags & 2) == 0)
2514 if (ss->type != GFC_SS_SECTION
2515 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2516 && ss->type != GFC_SS_COMPONENT)
2519 ss->data.info.offset = ss->data.info.saved_offset;
2522 /* Restart all the inner loops we just finished. */
2523 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2525 n = loop->order[dim];
2527 gfc_start_block (&loop->code[n]);
2529 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2531 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2534 /* Start a block for the secondary copying code. */
2535 gfc_start_block (body);
2539 /* Calculate the upper bound of an array section. */
2542 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2551 gcc_assert (ss->type == GFC_SS_SECTION);
2553 info = &ss->data.info;
2556 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2557 /* We'll calculate the upper bound once we have access to the
2558 vector's descriptor. */
2561 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2562 desc = info->descriptor;
2563 end = info->ref->u.ar.end[dim];
2567 /* The upper bound was specified. */
2568 gfc_init_se (&se, NULL);
2569 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2570 gfc_add_block_to_block (pblock, &se.pre);
2575 /* No upper bound was specified, so use the bound of the array. */
2576 bound = gfc_conv_array_ubound (desc, dim);
2583 /* Calculate the lower bound of an array section. */
2586 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2596 gcc_assert (ss->type == GFC_SS_SECTION);
2598 info = &ss->data.info;
2601 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2603 /* We use a zero-based index to access the vector. */
2604 info->start[n] = gfc_index_zero_node;
2605 info->end[n] = gfc_index_zero_node;
2606 info->stride[n] = gfc_index_one_node;
2610 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2611 desc = info->descriptor;
2612 start = info->ref->u.ar.start[dim];
2613 end = info->ref->u.ar.end[dim];
2614 stride = info->ref->u.ar.stride[dim];
2616 /* Calculate the start of the range. For vector subscripts this will
2617 be the range of the vector. */
2620 /* Specified section start. */
2621 gfc_init_se (&se, NULL);
2622 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2623 gfc_add_block_to_block (&loop->pre, &se.pre);
2624 info->start[n] = se.expr;
2628 /* No lower bound specified so use the bound of the array. */
2629 info->start[n] = gfc_conv_array_lbound (desc, dim);
2631 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2633 /* Similarly calculate the end. Although this is not used in the
2634 scalarizer, it is needed when checking bounds and where the end
2635 is an expression with side-effects. */
2638 /* Specified section start. */
2639 gfc_init_se (&se, NULL);
2640 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2641 gfc_add_block_to_block (&loop->pre, &se.pre);
2642 info->end[n] = se.expr;
2646 /* No upper bound specified so use the bound of the array. */
2647 info->end[n] = gfc_conv_array_ubound (desc, dim);
2649 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2651 /* Calculate the stride. */
2653 info->stride[n] = gfc_index_one_node;
2656 gfc_init_se (&se, NULL);
2657 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2658 gfc_add_block_to_block (&loop->pre, &se.pre);
2659 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2664 /* Calculates the range start and stride for a SS chain. Also gets the
2665 descriptor and data pointer. The range of vector subscripts is the size
2666 of the vector. Array bounds are also checked. */
2669 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2677 /* Determine the rank of the loop. */
2679 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2683 case GFC_SS_SECTION:
2684 case GFC_SS_CONSTRUCTOR:
2685 case GFC_SS_FUNCTION:
2686 case GFC_SS_COMPONENT:
2687 loop->dimen = ss->data.info.dimen;
2690 /* As usual, lbound and ubound are exceptions!. */
2691 case GFC_SS_INTRINSIC:
2692 switch (ss->expr->value.function.isym->generic_id)
2694 case GFC_ISYM_LBOUND:
2695 case GFC_ISYM_UBOUND:
2696 loop->dimen = ss->data.info.dimen;
2707 if (loop->dimen == 0)
2708 gfc_todo_error ("Unable to determine rank of expression");
2711 /* Loop over all the SS in the chain. */
2712 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2714 if (ss->expr && ss->expr->shape && !ss->shape)
2715 ss->shape = ss->expr->shape;
2719 case GFC_SS_SECTION:
2720 /* Get the descriptor for the array. */
2721 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2723 for (n = 0; n < ss->data.info.dimen; n++)
2724 gfc_conv_section_startstride (loop, ss, n);
2727 case GFC_SS_INTRINSIC:
2728 switch (ss->expr->value.function.isym->generic_id)
2730 /* Fall through to supply start and stride. */
2731 case GFC_ISYM_LBOUND:
2732 case GFC_ISYM_UBOUND:
2738 case GFC_SS_CONSTRUCTOR:
2739 case GFC_SS_FUNCTION:
2740 for (n = 0; n < ss->data.info.dimen; n++)
2742 ss->data.info.start[n] = gfc_index_zero_node;
2743 ss->data.info.end[n] = gfc_index_zero_node;
2744 ss->data.info.stride[n] = gfc_index_one_node;
2753 /* The rest is just runtime bound checking. */
2754 if (flag_bounds_check)
2757 tree lbound, ubound;
2759 tree size[GFC_MAX_DIMENSIONS];
2760 tree stride_pos, stride_neg, non_zerosized, tmp2;
2765 gfc_start_block (&block);
2767 for (n = 0; n < loop->dimen; n++)
2768 size[n] = NULL_TREE;
2770 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2772 if (ss->type != GFC_SS_SECTION)
2775 /* TODO: range checking for mapped dimensions. */
2776 info = &ss->data.info;
2778 /* This code only checks ranges. Elemental and vector
2779 dimensions are checked later. */
2780 for (n = 0; n < loop->dimen; n++)
2783 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2785 if (n == info->ref->u.ar.dimen - 1
2786 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2787 || info->ref->u.ar.as->cp_was_assumed))
2790 desc = ss->data.info.descriptor;
2792 /* This is the run-time equivalent of resolve.c's
2793 check_dimension(). The logical is more readable there
2794 than it is here, with all the trees. */
2795 lbound = gfc_conv_array_lbound (desc, dim);
2796 ubound = gfc_conv_array_ubound (desc, dim);
2799 /* Zero stride is not allowed. */
2800 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2801 gfc_index_zero_node);
2802 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2803 "of array '%s'", info->dim[n]+1,
2804 ss->expr->symtree->name);
2805 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2808 /* non_zerosized is true when the selected range is not
2810 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2811 info->stride[n], gfc_index_zero_node);
2812 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2814 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2817 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2818 info->stride[n], gfc_index_zero_node);
2819 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2821 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2823 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2824 stride_pos, stride_neg);
2826 /* Check the start of the range against the lower and upper
2827 bounds of the array, if the range is not empty. */
2828 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2830 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2831 non_zerosized, tmp);
2832 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2833 " exceeded", gfc_msg_fault, info->dim[n]+1,
2834 ss->expr->symtree->name);
2835 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2838 tmp = fold_build2 (GT_EXPR, boolean_type_node, info->start[n],
2840 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2841 non_zerosized, tmp);
2842 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2843 " exceeded", gfc_msg_fault, info->dim[n]+1,
2844 ss->expr->symtree->name);
2845 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2848 /* Compute the last element of the range, which is not
2849 necessarily "end" (think 0:5:3, which doesn't contain 5)
2850 and check it against both lower and upper bounds. */
2851 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2853 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2855 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2858 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2859 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2860 non_zerosized, tmp);
2861 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2862 " exceeded", gfc_msg_fault, info->dim[n]+1,
2863 ss->expr->symtree->name);
2864 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2867 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2868 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2869 non_zerosized, tmp);
2870 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2871 " exceeded", gfc_msg_fault, info->dim[n]+1,
2872 ss->expr->symtree->name);
2873 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2876 /* Check the section sizes match. */
2877 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2879 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2881 /* We remember the size of the first section, and check all the
2882 others against this. */
2886 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2887 asprintf (&msg, "%s, size mismatch for dimension %d "
2888 "of array '%s'", gfc_msg_bounds, info->dim[n]+1,
2889 ss->expr->symtree->name);
2890 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2894 size[n] = gfc_evaluate_now (tmp, &block);
2898 tmp = gfc_finish_block (&block);
2899 gfc_add_expr_to_block (&loop->pre, tmp);
2904 /* Return true if the two SS could be aliased, i.e. both point to the same data
2906 /* TODO: resolve aliases based on frontend expressions. */
2909 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2916 lsym = lss->expr->symtree->n.sym;
2917 rsym = rss->expr->symtree->n.sym;
2918 if (gfc_symbols_could_alias (lsym, rsym))
2921 if (rsym->ts.type != BT_DERIVED
2922 && lsym->ts.type != BT_DERIVED)
2925 /* For derived types we must check all the component types. We can ignore
2926 array references as these will have the same base type as the previous
2928 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2930 if (lref->type != REF_COMPONENT)
2933 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2936 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2939 if (rref->type != REF_COMPONENT)
2942 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2947 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2949 if (rref->type != REF_COMPONENT)
2952 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2960 /* Resolve array data dependencies. Creates a temporary if required. */
2961 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2965 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2975 loop->temp_ss = NULL;
2976 aref = dest->data.info.ref;
2979 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2981 if (ss->type != GFC_SS_SECTION)
2984 if (gfc_could_be_alias (dest, ss)
2985 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2991 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2993 lref = dest->expr->ref;
2994 rref = ss->expr->ref;
2996 nDepend = gfc_dep_resolver (lref, rref);
3000 /* TODO : loop shifting. */
3003 /* Mark the dimensions for LOOP SHIFTING */
3004 for (n = 0; n < loop->dimen; n++)
3006 int dim = dest->data.info.dim[n];
3008 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3010 else if (! gfc_is_same_range (&lref->u.ar,
3011 &rref->u.ar, dim, 0))
3015 /* Put all the dimensions with dependencies in the
3018 for (n = 0; n < loop->dimen; n++)
3020 gcc_assert (loop->order[n] == n);
3022 loop->order[dim++] = n;
3025 for (n = 0; n < loop->dimen; n++)
3028 loop->order[dim++] = n;
3031 gcc_assert (dim == loop->dimen);
3040 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3041 if (GFC_ARRAY_TYPE_P (base_type)
3042 || GFC_DESCRIPTOR_TYPE_P (base_type))
3043 base_type = gfc_get_element_type (base_type);
3044 loop->temp_ss = gfc_get_ss ();
3045 loop->temp_ss->type = GFC_SS_TEMP;
3046 loop->temp_ss->data.temp.type = base_type;
3047 loop->temp_ss->string_length = dest->string_length;
3048 loop->temp_ss->data.temp.dimen = loop->dimen;
3049 loop->temp_ss->next = gfc_ss_terminator;
3050 gfc_add_ss_to_loop (loop, loop->temp_ss);
3053 loop->temp_ss = NULL;
3057 /* Initialize the scalarization loop. Creates the loop variables. Determines
3058 the range of the loop variables. Creates a temporary if required.
3059 Calculates how to transform from loop variables to array indices for each
3060 expression. Also generates code for scalar expressions which have been
3061 moved outside the loop. */
3064 gfc_conv_loop_setup (gfc_loopinfo * loop)
3069 gfc_ss_info *specinfo;
3073 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3074 bool dynamic[GFC_MAX_DIMENSIONS];
3080 for (n = 0; n < loop->dimen; n++)
3084 /* We use one SS term, and use that to determine the bounds of the
3085 loop for this dimension. We try to pick the simplest term. */
3086 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3090 /* The frontend has worked out the size for us. */
3095 if (ss->type == GFC_SS_CONSTRUCTOR)
3097 /* An unknown size constructor will always be rank one.
3098 Higher rank constructors will either have known shape,
3099 or still be wrapped in a call to reshape. */
3100 gcc_assert (loop->dimen == 1);
3102 /* Always prefer to use the constructor bounds if the size
3103 can be determined at compile time. Prefer not to otherwise,
3104 since the general case involves realloc, and it's better to
3105 avoid that overhead if possible. */
3106 c = ss->expr->value.constructor;
3107 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3108 if (!dynamic[n] || !loopspec[n])
3113 /* TODO: Pick the best bound if we have a choice between a
3114 function and something else. */
3115 if (ss->type == GFC_SS_FUNCTION)
3121 if (ss->type != GFC_SS_SECTION)
3125 specinfo = &loopspec[n]->data.info;
3128 info = &ss->data.info;
3132 /* Criteria for choosing a loop specifier (most important first):
3133 doesn't need realloc
3139 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3141 else if (integer_onep (info->stride[n])
3142 && !integer_onep (specinfo->stride[n]))
3144 else if (INTEGER_CST_P (info->stride[n])
3145 && !INTEGER_CST_P (specinfo->stride[n]))
3147 else if (INTEGER_CST_P (info->start[n])
3148 && !INTEGER_CST_P (specinfo->start[n]))
3150 /* We don't work out the upper bound.
3151 else if (INTEGER_CST_P (info->finish[n])
3152 && ! INTEGER_CST_P (specinfo->finish[n]))
3153 loopspec[n] = ss; */
3157 gfc_todo_error ("Unable to find scalarization loop specifier");
3159 info = &loopspec[n]->data.info;
3161 /* Set the extents of this range. */
3162 cshape = loopspec[n]->shape;
3163 if (cshape && INTEGER_CST_P (info->start[n])
3164 && INTEGER_CST_P (info->stride[n]))
3166 loop->from[n] = info->start[n];
3167 mpz_set (i, cshape[n]);
3168 mpz_sub_ui (i, i, 1);
3169 /* To = from + (size - 1) * stride. */
3170 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3171 if (!integer_onep (info->stride[n]))
3172 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3173 tmp, info->stride[n]);
3174 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3175 loop->from[n], tmp);
3179 loop->from[n] = info->start[n];
3180 switch (loopspec[n]->type)
3182 case GFC_SS_CONSTRUCTOR:
3183 /* The upper bound is calculated when we expand the
3185 gcc_assert (loop->to[n] == NULL_TREE);
3188 case GFC_SS_SECTION:
3189 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3193 case GFC_SS_FUNCTION:
3194 /* The loop bound will be set when we generate the call. */
3195 gcc_assert (loop->to[n] == NULL_TREE);
3203 /* Transform everything so we have a simple incrementing variable. */
3204 if (integer_onep (info->stride[n]))
3205 info->delta[n] = gfc_index_zero_node;
3208 /* Set the delta for this section. */
3209 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3210 /* Number of iterations is (end - start + step) / step.
3211 with start = 0, this simplifies to
3213 for (i = 0; i<=last; i++){...}; */
3214 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3215 loop->to[n], loop->from[n]);
3216 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3217 tmp, info->stride[n]);
3218 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3219 /* Make the loop variable start at 0. */
3220 loop->from[n] = gfc_index_zero_node;
3224 /* Add all the scalar code that can be taken out of the loops.
3225 This may include calculating the loop bounds, so do it before
3226 allocating the temporary. */
3227 gfc_add_loop_ss_code (loop, loop->ss, false);
3229 /* If we want a temporary then create it. */
3230 if (loop->temp_ss != NULL)
3232 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3233 tmp = loop->temp_ss->data.temp.type;
3234 len = loop->temp_ss->string_length;
3235 n = loop->temp_ss->data.temp.dimen;
3236 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3237 loop->temp_ss->type = GFC_SS_SECTION;
3238 loop->temp_ss->data.info.dimen = n;
3239 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3240 &loop->temp_ss->data.info, tmp, false, true,
3244 for (n = 0; n < loop->temp_dim; n++)
3245 loopspec[loop->order[n]] = NULL;
3249 /* For array parameters we don't have loop variables, so don't calculate the
3251 if (loop->array_parameter)
3254 /* Calculate the translation from loop variables to array indices. */
3255 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3257 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3260 info = &ss->data.info;
3262 for (n = 0; n < info->dimen; n++)
3266 /* If we are specifying the range the delta is already set. */
3267 if (loopspec[n] != ss)
3269 /* Calculate the offset relative to the loop variable.
3270 First multiply by the stride. */
3271 tmp = loop->from[n];
3272 if (!integer_onep (info->stride[n]))
3273 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3274 tmp, info->stride[n]);
3276 /* Then subtract this from our starting value. */
3277 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3278 info->start[n], tmp);
3280 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3287 /* Fills in an array descriptor, and returns the size of the array. The size
3288 will be a simple_val, ie a variable or a constant. Also calculates the
3289 offset of the base. Returns the size of the array.
3293 for (n = 0; n < rank; n++)
3295 a.lbound[n] = specified_lower_bound;
3296 offset = offset + a.lbond[n] * stride;
3298 a.ubound[n] = specified_upper_bound;
3299 a.stride[n] = stride;
3300 size = ubound + size; //size = ubound + 1 - lbound
3301 stride = stride * size;
3308 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3309 gfc_expr ** lower, gfc_expr ** upper,
3310 stmtblock_t * pblock)
3322 stmtblock_t thenblock;
3323 stmtblock_t elseblock;
3328 type = TREE_TYPE (descriptor);
3330 stride = gfc_index_one_node;
3331 offset = gfc_index_zero_node;
3333 /* Set the dtype. */
3334 tmp = gfc_conv_descriptor_dtype (descriptor);
3335 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3337 or_expr = NULL_TREE;
3339 for (n = 0; n < rank; n++)
3341 /* We have 3 possibilities for determining the size of the array:
3342 lower == NULL => lbound = 1, ubound = upper[n]
3343 upper[n] = NULL => lbound = 1, ubound = lower[n]
3344 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3347 /* Set lower bound. */
3348 gfc_init_se (&se, NULL);
3350 se.expr = gfc_index_one_node;
3353 gcc_assert (lower[n]);
3356 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3357 gfc_add_block_to_block (pblock, &se.pre);
3361 se.expr = gfc_index_one_node;
3365 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3366 gfc_add_modify_expr (pblock, tmp, se.expr);
3368 /* Work out the offset for this component. */
3369 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3370 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3372 /* Start the calculation for the size of this dimension. */
3373 size = build2 (MINUS_EXPR, gfc_array_index_type,
3374 gfc_index_one_node, se.expr);
3376 /* Set upper bound. */
3377 gfc_init_se (&se, NULL);
3378 gcc_assert (ubound);
3379 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3380 gfc_add_block_to_block (pblock, &se.pre);
3382 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3383 gfc_add_modify_expr (pblock, tmp, se.expr);
3385 /* Store the stride. */
3386 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3387 gfc_add_modify_expr (pblock, tmp, stride);
3389 /* Calculate the size of this dimension. */
3390 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3392 /* Check whether the size for this dimension is negative. */
3393 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3394 gfc_index_zero_node);
3398 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3400 /* Multiply the stride by the number of elements in this dimension. */
3401 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3402 stride = gfc_evaluate_now (stride, pblock);
3405 /* The stride is the number of elements in the array, so multiply by the
3406 size of an element to get the total size. */
3407 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3408 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
3410 if (poffset != NULL)
3412 offset = gfc_evaluate_now (offset, pblock);
3416 if (integer_zerop (or_expr))
3418 if (integer_onep (or_expr))
3419 return gfc_index_zero_node;
3421 var = gfc_create_var (TREE_TYPE (size), "size");
3422 gfc_start_block (&thenblock);
3423 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3424 thencase = gfc_finish_block (&thenblock);
3426 gfc_start_block (&elseblock);
3427 gfc_add_modify_expr (&elseblock, var, size);
3428 elsecase = gfc_finish_block (&elseblock);
3430 tmp = gfc_evaluate_now (or_expr, pblock);
3431 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3432 gfc_add_expr_to_block (pblock, tmp);
3438 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3439 the work for an ALLOCATE statement. */
3443 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3452 gfc_ref *ref, *prev_ref = NULL;
3453 bool allocatable_array;
3457 /* Find the last reference in the chain. */
3458 while (ref && ref->next != NULL)
3460 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3465 if (ref == NULL || ref->type != REF_ARRAY)
3469 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3471 allocatable_array = prev_ref->u.c.component->allocatable;
3473 /* Figure out the size of the array. */
3474 switch (ref->u.ar.type)
3478 upper = ref->u.ar.start;
3482 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3484 lower = ref->u.ar.as->lower;
3485 upper = ref->u.ar.as->upper;
3489 lower = ref->u.ar.start;
3490 upper = ref->u.ar.end;
3498 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3499 lower, upper, &se->pre);
3501 /* Allocate memory to store the data. */
3502 pointer = gfc_conv_descriptor_data_get (se->expr);
3503 STRIP_NOPS (pointer);
3505 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3507 if (allocatable_array)
3508 allocate = gfor_fndecl_allocate_array;
3510 allocate = gfor_fndecl_allocate;
3512 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3514 if (allocatable_array)
3515 allocate = gfor_fndecl_allocate64_array;
3517 allocate = gfor_fndecl_allocate64;
3522 /* The allocate_array variants take the old pointer as first argument. */
3523 if (allocatable_array)
3524 tmp = build_call_expr (allocate, 3, pointer, size, pstat);
3526 tmp = build_call_expr (allocate, 2, size, pstat);
3527 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3528 gfc_add_expr_to_block (&se->pre, tmp);
3530 tmp = gfc_conv_descriptor_offset (se->expr);
3531 gfc_add_modify_expr (&se->pre, tmp, offset);
3533 if (expr->ts.type == BT_DERIVED
3534 && expr->ts.derived->attr.alloc_comp)
3536 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3537 ref->u.ar.as->rank);
3538 gfc_add_expr_to_block (&se->pre, tmp);
3545 /* Deallocate an array variable. Also used when an allocated variable goes
3550 gfc_array_deallocate (tree descriptor, tree pstat)
3556 gfc_start_block (&block);
3557 /* Get a pointer to the data. */
3558 var = gfc_conv_descriptor_data_get (descriptor);
3561 /* Parameter is the address of the data component. */
3562 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
3563 gfc_add_expr_to_block (&block, tmp);
3565 /* Zero the data pointer. */
3566 tmp = build2 (MODIFY_EXPR, void_type_node,
3567 var, build_int_cst (TREE_TYPE (var), 0));
3568 gfc_add_expr_to_block (&block, tmp);
3570 return gfc_finish_block (&block);
3574 /* Create an array constructor from an initialization expression.
3575 We assume the frontend already did any expansions and conversions. */
3578 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3585 unsigned HOST_WIDE_INT lo;
3587 VEC(constructor_elt,gc) *v = NULL;
3589 switch (expr->expr_type)
3592 case EXPR_STRUCTURE:
3593 /* A single scalar or derived type value. Create an array with all
3594 elements equal to that value. */
3595 gfc_init_se (&se, NULL);
3597 if (expr->expr_type == EXPR_CONSTANT)
3598 gfc_conv_constant (&se, expr);
3600 gfc_conv_structure (&se, expr, 1);
3602 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3603 gcc_assert (tmp && INTEGER_CST_P (tmp));
3604 hi = TREE_INT_CST_HIGH (tmp);
3605 lo = TREE_INT_CST_LOW (tmp);
3609 /* This will probably eat buckets of memory for large arrays. */
3610 while (hi != 0 || lo != 0)
3612 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3620 /* Create a vector of all the elements. */
3621 for (c = expr->value.constructor; c; c = c->next)
3625 /* Problems occur when we get something like
3626 integer :: a(lots) = (/(i, i=1,lots)/) */
3627 /* TODO: Unexpanded array initializers. */
3629 ("Possible frontend bug: array constructor not expanded");
3631 if (mpz_cmp_si (c->n.offset, 0) != 0)
3632 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3636 if (mpz_cmp_si (c->repeat, 0) != 0)
3640 mpz_set (maxval, c->repeat);
3641 mpz_add (maxval, c->n.offset, maxval);
3642 mpz_sub_ui (maxval, maxval, 1);
3643 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3644 if (mpz_cmp_si (c->n.offset, 0) != 0)
3646 mpz_add_ui (maxval, c->n.offset, 1);
3647 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3650 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3652 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3658 gfc_init_se (&se, NULL);
3659 switch (c->expr->expr_type)
3662 gfc_conv_constant (&se, c->expr);
3663 if (range == NULL_TREE)
3664 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3667 if (index != NULL_TREE)
3668 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3669 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3673 case EXPR_STRUCTURE:
3674 gfc_conv_structure (&se, c->expr, 1);
3675 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3685 return gfc_build_null_descriptor (type);
3691 /* Create a constructor from the list of elements. */
3692 tmp = build_constructor (type, v);
3693 TREE_CONSTANT (tmp) = 1;
3694 TREE_INVARIANT (tmp) = 1;
3699 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3700 returns the size (in elements) of the array. */
3703 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3704 stmtblock_t * pblock)
3719 size = gfc_index_one_node;
3720 offset = gfc_index_zero_node;
3721 for (dim = 0; dim < as->rank; dim++)
3723 /* Evaluate non-constant array bound expressions. */
3724 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3725 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3727 gfc_init_se (&se, NULL);
3728 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3729 gfc_add_block_to_block (pblock, &se.pre);
3730 gfc_add_modify_expr (pblock, lbound, se.expr);
3732 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3733 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3735 gfc_init_se (&se, NULL);
3736 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3737 gfc_add_block_to_block (pblock, &se.pre);
3738 gfc_add_modify_expr (pblock, ubound, se.expr);
3740 /* The offset of this dimension. offset = offset - lbound * stride. */
3741 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3742 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3744 /* The size of this dimension, and the stride of the next. */
3745 if (dim + 1 < as->rank)
3746 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3748 stride = GFC_TYPE_ARRAY_SIZE (type);
3750 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3752 /* Calculate stride = size * (ubound + 1 - lbound). */
3753 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3754 gfc_index_one_node, lbound);
3755 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3756 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3758 gfc_add_modify_expr (pblock, stride, tmp);
3760 stride = gfc_evaluate_now (tmp, pblock);
3762 /* Make sure that negative size arrays are translated
3763 to being zero size. */
3764 tmp = build2 (GE_EXPR, boolean_type_node,
3765 stride, gfc_index_zero_node);
3766 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3767 stride, gfc_index_zero_node);
3768 gfc_add_modify_expr (pblock, stride, tmp);
3774 gfc_trans_vla_type_sizes (sym, pblock);
3781 /* Generate code to initialize/allocate an array variable. */
3784 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3793 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3795 /* Do nothing for USEd variables. */
3796 if (sym->attr.use_assoc)
3799 type = TREE_TYPE (decl);
3800 gcc_assert (GFC_ARRAY_TYPE_P (type));
3801 onstack = TREE_CODE (type) != POINTER_TYPE;
3803 gfc_start_block (&block);
3805 /* Evaluate character string length. */
3806 if (sym->ts.type == BT_CHARACTER
3807 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3809 gfc_trans_init_string_length (sym->ts.cl, &block);
3811 gfc_trans_vla_type_sizes (sym, &block);
3813 /* Emit a DECL_EXPR for this variable, which will cause the
3814 gimplifier to allocate storage, and all that good stuff. */
3815 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3816 gfc_add_expr_to_block (&block, tmp);
3821 gfc_add_expr_to_block (&block, fnbody);
3822 return gfc_finish_block (&block);
3825 type = TREE_TYPE (type);
3827 gcc_assert (!sym->attr.use_assoc);
3828 gcc_assert (!TREE_STATIC (decl));
3829 gcc_assert (!sym->module);
3831 if (sym->ts.type == BT_CHARACTER
3832 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3833 gfc_trans_init_string_length (sym->ts.cl, &block);
3835 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3837 /* Don't actually allocate space for Cray Pointees. */
3838 if (sym->attr.cray_pointee)
3840 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3841 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3842 gfc_add_expr_to_block (&block, fnbody);
3843 return gfc_finish_block (&block);
3846 /* The size is the number of elements in the array, so multiply by the
3847 size of an element to get the total size. */
3848 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3849 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3851 /* Allocate memory to hold the data. */
3852 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3853 gfc_add_modify_expr (&block, decl, tmp);
3855 /* Set offset of the array. */
3856 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3857 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3860 /* Automatic arrays should not have initializers. */
3861 gcc_assert (!sym->value);
3863 gfc_add_expr_to_block (&block, fnbody);
3865 /* Free the temporary. */
3866 tmp = gfc_call_free (convert (pvoid_type_node, decl));
3867 gfc_add_expr_to_block (&block, tmp);
3869 return gfc_finish_block (&block);
3873 /* Generate entry and exit code for g77 calling convention arrays. */
3876 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3886 gfc_get_backend_locus (&loc);
3887 gfc_set_backend_locus (&sym->declared_at);
3889 /* Descriptor type. */
3890 parm = sym->backend_decl;
3891 type = TREE_TYPE (parm);
3892 gcc_assert (GFC_ARRAY_TYPE_P (type));
3894 gfc_start_block (&block);
3896 if (sym->ts.type == BT_CHARACTER
3897 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3898 gfc_trans_init_string_length (sym->ts.cl, &block);
3900 /* Evaluate the bounds of the array. */
3901 gfc_trans_array_bounds (type, sym, &offset, &block);
3903 /* Set the offset. */
3904 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3905 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3907 /* Set the pointer itself if we aren't using the parameter directly. */
3908 if (TREE_CODE (parm) != PARM_DECL)
3910 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3911 gfc_add_modify_expr (&block, parm, tmp);
3913 stmt = gfc_finish_block (&block);
3915 gfc_set_backend_locus (&loc);
3917 gfc_start_block (&block);
3919 /* Add the initialization code to the start of the function. */
3921 if (sym->attr.optional || sym->attr.not_always_present)
3923 tmp = gfc_conv_expr_present (sym);
3924 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3927 gfc_add_expr_to_block (&block, stmt);
3928 gfc_add_expr_to_block (&block, body);
3930 return gfc_finish_block (&block);
3934 /* Modify the descriptor of an array parameter so that it has the
3935 correct lower bound. Also move the upper bound accordingly.
3936 If the array is not packed, it will be copied into a temporary.
3937 For each dimension we set the new lower and upper bounds. Then we copy the
3938 stride and calculate the offset for this dimension. We also work out
3939 what the stride of a packed array would be, and see it the two match.
3940 If the array need repacking, we set the stride to the values we just
3941 calculated, recalculate the offset and copy the array data.
3942 Code is also added to copy the data back at the end of the function.
3946 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3953 stmtblock_t cleanup;
3961 tree stride, stride2;
3971 /* Do nothing for pointer and allocatable arrays. */
3972 if (sym->attr.pointer || sym->attr.allocatable)
3975 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3976 return gfc_trans_g77_array (sym, body);
3978 gfc_get_backend_locus (&loc);
3979 gfc_set_backend_locus (&sym->declared_at);
3981 /* Descriptor type. */
3982 type = TREE_TYPE (tmpdesc);
3983 gcc_assert (GFC_ARRAY_TYPE_P (type));
3984 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3985 dumdesc = build_fold_indirect_ref (dumdesc);
3986 gfc_start_block (&block);
3988 if (sym->ts.type == BT_CHARACTER
3989 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3990 gfc_trans_init_string_length (sym->ts.cl, &block);
3992 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3994 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3995 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3997 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3999 /* For non-constant shape arrays we only check if the first dimension
4000 is contiguous. Repacking higher dimensions wouldn't gain us
4001 anything as we still don't know the array stride. */
4002 partial = gfc_create_var (boolean_type_node, "partial");
4003 TREE_USED (partial) = 1;
4004 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4005 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4006 gfc_add_modify_expr (&block, partial, tmp);
4010 partial = NULL_TREE;
4013 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4014 here, however I think it does the right thing. */
4017 /* Set the first stride. */
4018 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4019 stride = gfc_evaluate_now (stride, &block);
4021 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4022 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4023 gfc_index_one_node, stride);
4024 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4025 gfc_add_modify_expr (&block, stride, tmp);
4027 /* Allow the user to disable array repacking. */
4028 stmt_unpacked = NULL_TREE;
4032 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4033 /* A library call to repack the array if necessary. */
4034 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4035 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4037 stride = gfc_index_one_node;
4040 /* This is for the case where the array data is used directly without
4041 calling the repack function. */
4042 if (no_repack || partial != NULL_TREE)
4043 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4045 stmt_packed = NULL_TREE;
4047 /* Assign the data pointer. */
4048 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4050 /* Don't repack unknown shape arrays when the first stride is 1. */
4051 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4052 stmt_packed, stmt_unpacked);
4055 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4056 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4058 offset = gfc_index_zero_node;
4059 size = gfc_index_one_node;
4061 /* Evaluate the bounds of the array. */
4062 for (n = 0; n < sym->as->rank; n++)
4064 if (checkparm || !sym->as->upper[n])
4066 /* Get the bounds of the actual parameter. */
4067 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4068 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4072 dubound = NULL_TREE;
4073 dlbound = NULL_TREE;
4076 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4077 if (!INTEGER_CST_P (lbound))
4079 gfc_init_se (&se, NULL);
4080 gfc_conv_expr_type (&se, sym->as->lower[n],
4081 gfc_array_index_type);
4082 gfc_add_block_to_block (&block, &se.pre);
4083 gfc_add_modify_expr (&block, lbound, se.expr);
4086 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4087 /* Set the desired upper bound. */
4088 if (sym->as->upper[n])
4090 /* We know what we want the upper bound to be. */
4091 if (!INTEGER_CST_P (ubound))
4093 gfc_init_se (&se, NULL);
4094 gfc_conv_expr_type (&se, sym->as->upper[n],
4095 gfc_array_index_type);
4096 gfc_add_block_to_block (&block, &se.pre);
4097 gfc_add_modify_expr (&block, ubound, se.expr);
4100 /* Check the sizes match. */
4103 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4106 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4108 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4110 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4111 asprintf (&msg, "%s for dimension %d of array '%s'",
4112 gfc_msg_bounds, n+1, sym->name);
4113 gfc_trans_runtime_check (tmp, msg, &block, &loc);
4119 /* For assumed shape arrays move the upper bound by the same amount
4120 as the lower bound. */
4121 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4122 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4123 gfc_add_modify_expr (&block, ubound, tmp);
4125 /* The offset of this dimension. offset = offset - lbound * stride. */
4126 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4127 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4129 /* The size of this dimension, and the stride of the next. */
4130 if (n + 1 < sym->as->rank)
4132 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4134 if (no_repack || partial != NULL_TREE)
4137 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4140 /* Figure out the stride if not a known constant. */
4141 if (!INTEGER_CST_P (stride))
4144 stmt_packed = NULL_TREE;
4147 /* Calculate stride = size * (ubound + 1 - lbound). */
4148 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4149 gfc_index_one_node, lbound);
4150 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4152 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4157 /* Assign the stride. */
4158 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4159 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4160 stmt_unpacked, stmt_packed);
4162 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4163 gfc_add_modify_expr (&block, stride, tmp);
4168 stride = GFC_TYPE_ARRAY_SIZE (type);
4170 if (stride && !INTEGER_CST_P (stride))
4172 /* Calculate size = stride * (ubound + 1 - lbound). */
4173 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4174 gfc_index_one_node, lbound);
4175 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4177 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4178 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4179 gfc_add_modify_expr (&block, stride, tmp);
4184 /* Set the offset. */
4185 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4186 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4188 gfc_trans_vla_type_sizes (sym, &block);
4190 stmt = gfc_finish_block (&block);
4192 gfc_start_block (&block);
4194 /* Only do the entry/initialization code if the arg is present. */
4195 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4196 optional_arg = (sym->attr.optional
4197 || (sym->ns->proc_name->attr.entry_master
4198 && sym->attr.dummy));
4201 tmp = gfc_conv_expr_present (sym);
4202 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4204 gfc_add_expr_to_block (&block, stmt);
4206 /* Add the main function body. */
4207 gfc_add_expr_to_block (&block, body);
4212 gfc_start_block (&cleanup);
4214 if (sym->attr.intent != INTENT_IN)
4216 /* Copy the data back. */
4217 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4218 gfc_add_expr_to_block (&cleanup, tmp);
4221 /* Free the temporary. */
4222 tmp = gfc_call_free (tmpdesc);
4223 gfc_add_expr_to_block (&cleanup, tmp);
4225 stmt = gfc_finish_block (&cleanup);
4227 /* Only do the cleanup if the array was repacked. */
4228 tmp = build_fold_indirect_ref (dumdesc);
4229 tmp = gfc_conv_descriptor_data_get (tmp);
4230 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4231 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4235 tmp = gfc_conv_expr_present (sym);
4236 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4238 gfc_add_expr_to_block (&block, stmt);
4240 /* We don't need to free any memory allocated by internal_pack as it will
4241 be freed at the end of the function by pop_context. */
4242 return gfc_finish_block (&block);
4246 /* Convert an array for passing as an actual argument. Expressions and
4247 vector subscripts are evaluated and stored in a temporary, which is then
4248 passed. For whole arrays the descriptor is passed. For array sections
4249 a modified copy of the descriptor is passed, but using the original data.
4251 This function is also used for array pointer assignments, and there
4254 - want_pointer && !se->direct_byref
4255 EXPR is an actual argument. On exit, se->expr contains a
4256 pointer to the array descriptor.
4258 - !want_pointer && !se->direct_byref
4259 EXPR is an actual argument to an intrinsic function or the
4260 left-hand side of a pointer assignment. On exit, se->expr
4261 contains the descriptor for EXPR.
4263 - !want_pointer && se->direct_byref
4264 EXPR is the right-hand side of a pointer assignment and
4265 se->expr is the descriptor for the previously-evaluated
4266 left-hand side. The function creates an assignment from
4267 EXPR to se->expr. */
4270 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4284 gcc_assert (ss != gfc_ss_terminator);
4286 /* Special case things we know we can pass easily. */
4287 switch (expr->expr_type)
4290 /* If we have a linear array section, we can pass it directly.
4291 Otherwise we need to copy it into a temporary. */
4293 /* Find the SS for the array section. */
4295 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4296 secss = secss->next;
4298 gcc_assert (secss != gfc_ss_terminator);
4299 info = &secss->data.info;
4301 /* Get the descriptor for the array. */
4302 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4303 desc = info->descriptor;
4305 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4308 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4310 /* Create a new descriptor if the array doesn't have one. */
4313 else if (info->ref->u.ar.type == AR_FULL)
4315 else if (se->direct_byref)
4318 full = gfc_full_array_ref_p (info->ref);
4322 if (se->direct_byref)
4324 /* Copy the descriptor for pointer assignments. */
4325 gfc_add_modify_expr (&se->pre, se->expr, desc);
4327 else if (se->want_pointer)
4329 /* We pass full arrays directly. This means that pointers and
4330 allocatable arrays should also work. */
4331 se->expr = build_fold_addr_expr (desc);
4338 if (expr->ts.type == BT_CHARACTER)
4339 se->string_length = gfc_get_expr_charlen (expr);
4346 /* A transformational function return value will be a temporary
4347 array descriptor. We still need to go through the scalarizer
4348 to create the descriptor. Elemental functions ar handled as
4349 arbitrary expressions, i.e. copy to a temporary. */
4351 /* Look for the SS for this function. */
4352 while (secss != gfc_ss_terminator
4353 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4354 secss = secss->next;
4356 if (se->direct_byref)
4358 gcc_assert (secss != gfc_ss_terminator);
4360 /* For pointer assignments pass the descriptor directly. */
4362 se->expr = build_fold_addr_expr (se->expr);
4363 gfc_conv_expr (se, expr);
4367 if (secss == gfc_ss_terminator)
4369 /* Elemental function. */
4375 /* Transformational function. */
4376 info = &secss->data.info;
4382 /* Constant array constructors don't need a temporary. */
4383 if (ss->type == GFC_SS_CONSTRUCTOR
4384 && expr->ts.type != BT_CHARACTER
4385 && gfc_constant_array_constructor_p (expr->value.constructor))
4388 info = &ss->data.info;
4400 /* Something complicated. Copy it into a temporary. */
4408 gfc_init_loopinfo (&loop);
4410 /* Associate the SS with the loop. */
4411 gfc_add_ss_to_loop (&loop, ss);
4413 /* Tell the scalarizer not to bother creating loop variables, etc. */
4415 loop.array_parameter = 1;
4417 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4418 gcc_assert (!se->direct_byref);
4420 /* Setup the scalarizing loops and bounds. */
4421 gfc_conv_ss_startstride (&loop);
4425 /* Tell the scalarizer to make a temporary. */
4426 loop.temp_ss = gfc_get_ss ();
4427 loop.temp_ss->type = GFC_SS_TEMP;
4428 loop.temp_ss->next = gfc_ss_terminator;
4429 if (expr->ts.type == BT_CHARACTER)
4431 if (expr->ts.cl == NULL)
4433 /* This had better be a substring reference! */
4434 gfc_ref *char_ref = expr->ref;
4435 for (; char_ref; char_ref = char_ref->next)
4436 if (char_ref->type == REF_SUBSTRING)
4439 expr->ts.cl = gfc_get_charlen ();
4440 expr->ts.cl->next = char_ref->u.ss.length->next;
4441 char_ref->u.ss.length->next = expr->ts.cl;
4443 mpz_init_set_ui (char_len, 1);
4444 mpz_add (char_len, char_len,
4445 char_ref->u.ss.end->value.integer);
4446 mpz_sub (char_len, char_len,
4447 char_ref->u.ss.start->value.integer);
4448 expr->ts.cl->backend_decl
4449 = gfc_conv_mpz_to_tree (char_len,
4450 gfc_default_character_kind);
4451 /* Cast is necessary for *-charlen refs. */
4452 expr->ts.cl->backend_decl
4453 = convert (gfc_charlen_type_node,
4454 expr->ts.cl->backend_decl);
4455 mpz_clear (char_len);
4458 gcc_assert (char_ref != NULL);
4459 loop.temp_ss->data.temp.type
4460 = gfc_typenode_for_spec (&expr->ts);
4461 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4463 else if (expr->ts.cl->length
4464 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4466 expr->ts.cl->backend_decl
4467 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4468 expr->ts.cl->length->ts.kind);
4469 loop.temp_ss->data.temp.type
4470 = gfc_typenode_for_spec (&expr->ts);
4471 loop.temp_ss->string_length
4472 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4476 loop.temp_ss->data.temp.type
4477 = gfc_typenode_for_spec (&expr->ts);
4478 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4480 se->string_length = loop.temp_ss->string_length;
4484 loop.temp_ss->data.temp.type
4485 = gfc_typenode_for_spec (&expr->ts);
4486 loop.temp_ss->string_length = NULL;
4488 loop.temp_ss->data.temp.dimen = loop.dimen;
4489 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4492 gfc_conv_loop_setup (&loop);
4496 /* Copy into a temporary and pass that. We don't need to copy the data
4497 back because expressions and vector subscripts must be INTENT_IN. */
4498 /* TODO: Optimize passing function return values. */
4502 /* Start the copying loops. */
4503 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4504 gfc_mark_ss_chain_used (ss, 1);
4505 gfc_start_scalarized_body (&loop, &block);
4507 /* Copy each data element. */
4508 gfc_init_se (&lse, NULL);
4509 gfc_copy_loopinfo_to_se (&lse, &loop);
4510 gfc_init_se (&rse, NULL);
4511 gfc_copy_loopinfo_to_se (&rse, &loop);
4513 lse.ss = loop.temp_ss;
4516 gfc_conv_scalarized_array_ref (&lse, NULL);
4517 if (expr->ts.type == BT_CHARACTER)
4519 gfc_conv_expr (&rse, expr);
4520 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4521 rse.expr = build_fold_indirect_ref (rse.expr);
4524 gfc_conv_expr_val (&rse, expr);
4526 gfc_add_block_to_block (&block, &rse.pre);
4527 gfc_add_block_to_block (&block, &lse.pre);
4529 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4531 /* Finish the copying loops. */
4532 gfc_trans_scalarizing_loops (&loop, &block);
4534 desc = loop.temp_ss->data.info.descriptor;
4536 gcc_assert (is_gimple_lvalue (desc));
4538 else if (expr->expr_type == EXPR_FUNCTION)
4540 desc = info->descriptor;
4541 se->string_length = ss->string_length;
4545 /* We pass sections without copying to a temporary. Make a new
4546 descriptor and point it at the section we want. The loop variable
4547 limits will be the limits of the section.
4548 A function may decide to repack the array to speed up access, but
4549 we're not bothered about that here. */
4558 /* Set the string_length for a character array. */
4559 if (expr->ts.type == BT_CHARACTER)
4560 se->string_length = gfc_get_expr_charlen (expr);
4562 desc = info->descriptor;
4563 gcc_assert (secss && secss != gfc_ss_terminator);
4564 if (se->direct_byref)
4566 /* For pointer assignments we fill in the destination. */
4568 parmtype = TREE_TYPE (parm);
4572 /* Otherwise make a new one. */
4573 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4574 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4575 loop.from, loop.to, 0);
4576 parm = gfc_create_var (parmtype, "parm");
4579 offset = gfc_index_zero_node;
4582 /* The following can be somewhat confusing. We have two
4583 descriptors, a new one and the original array.
4584 {parm, parmtype, dim} refer to the new one.
4585 {desc, type, n, secss, loop} refer to the original, which maybe
4586 a descriptorless array.
4587 The bounds of the scalarization are the bounds of the section.
4588 We don't have to worry about numeric overflows when calculating
4589 the offsets because all elements are within the array data. */
4591 /* Set the dtype. */
4592 tmp = gfc_conv_descriptor_dtype (parm);
4593 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4595 if (se->direct_byref)
4596 base = gfc_index_zero_node;
4600 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4601 for (n = 0; n < ndim; n++)
4603 stride = gfc_conv_array_stride (desc, n);
4605 /* Work out the offset. */
4607 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4609 gcc_assert (info->subscript[n]
4610 && info->subscript[n]->type == GFC_SS_SCALAR);
4611 start = info->subscript[n]->data.scalar.expr;
4615 /* Check we haven't somehow got out of sync. */
4616 gcc_assert (info->dim[dim] == n);
4618 /* Evaluate and remember the start of the section. */
4619 start = info->start[dim];
4620 stride = gfc_evaluate_now (stride, &loop.pre);
4623 tmp = gfc_conv_array_lbound (desc, n);
4624 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4626 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4627 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4630 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4632 /* For elemental dimensions, we only need the offset. */
4636 /* Vector subscripts need copying and are handled elsewhere. */
4638 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4640 /* Set the new lower bound. */
4641 from = loop.from[dim];
4644 /* If we have an array section or are assigning to a pointer,
4645 make sure that the lower bound is 1. References to the full
4646 array should otherwise keep the original bounds. */
4648 || info->ref->u.ar.type != AR_FULL
4649 || se->direct_byref)
4650 && !integer_onep (from))
4652 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4653 gfc_index_one_node, from);
4654 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4655 from = gfc_index_one_node;
4657 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4658 gfc_add_modify_expr (&loop.pre, tmp, from);
4660 /* Set the new upper bound. */
4661 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4662 gfc_add_modify_expr (&loop.pre, tmp, to);
4664 /* Multiply the stride by the section stride to get the
4666 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4667 stride, info->stride[dim]);
4669 if (se->direct_byref)
4670 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4673 /* Store the new stride. */
4674 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4675 gfc_add_modify_expr (&loop.pre, tmp, stride);
4680 if (se->data_not_needed)
4681 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4684 /* Point the data pointer at the first element in the section. */
4685 tmp = gfc_conv_array_data (desc);
4686 tmp = build_fold_indirect_ref (tmp);
4687 tmp = gfc_build_array_ref (tmp, offset);
4688 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4689 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4692 if (se->direct_byref && !se->data_not_needed)
4694 /* Set the offset. */
4695 tmp = gfc_conv_descriptor_offset (parm);
4696 gfc_add_modify_expr (&loop.pre, tmp, base);
4700 /* Only the callee knows what the correct offset it, so just set
4702 tmp = gfc_conv_descriptor_offset (parm);
4703 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4708 if (!se->direct_byref)
4710 /* Get a pointer to the new descriptor. */
4711 if (se->want_pointer)
4712 se->expr = build_fold_addr_expr (desc);
4717 gfc_add_block_to_block (&se->pre, &loop.pre);
4718 gfc_add_block_to_block (&se->post, &loop.post);
4720 /* Cleanup the scalarizer. */
4721 gfc_cleanup_loop (&loop);
4725 /* Convert an array for passing as an actual parameter. */
4726 /* TODO: Optimize passing g77 arrays. */
4729 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4735 tree parent = DECL_CONTEXT (current_function_decl);
4736 bool full_array_var, this_array_result;
4740 full_array_var = (expr->expr_type == EXPR_VARIABLE
4741 && expr->ref->u.ar.type == AR_FULL);
4742 sym = full_array_var ? expr->symtree->n.sym : NULL;
4744 /* Is this the result of the enclosing procedure? */
4745 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4746 if (this_array_result
4747 && (sym->backend_decl != current_function_decl)
4748 && (sym->backend_decl != parent))
4749 this_array_result = false;
4751 /* Passing address of the array if it is not pointer or assumed-shape. */
4752 if (full_array_var && g77 && !this_array_result)
4754 tmp = gfc_get_symbol_decl (sym);
4756 if (sym->ts.type == BT_CHARACTER)
4757 se->string_length = sym->ts.cl->backend_decl;
4758 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4759 && !sym->attr.allocatable)
4761 /* Some variables are declared directly, others are declared as
4762 pointers and allocated on the heap. */
4763 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4766 se->expr = build_fold_addr_expr (tmp);
4769 if (sym->attr.allocatable)
4771 if (sym->attr.dummy)
4773 gfc_conv_expr_descriptor (se, expr, ss);
4774 se->expr = gfc_conv_array_data (se->expr);
4777 se->expr = gfc_conv_array_data (tmp);
4782 if (this_array_result)
4784 /* Result of the enclosing function. */
4785 gfc_conv_expr_descriptor (se, expr, ss);
4786 se->expr = build_fold_addr_expr (se->expr);
4788 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
4789 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4790 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
4796 /* Every other type of array. */
4797 se->want_pointer = 1;
4798 gfc_conv_expr_descriptor (se, expr, ss);
4802 /* Deallocate the allocatable components of structures that are
4804 if (expr->ts.type == BT_DERIVED
4805 && expr->ts.derived->attr.alloc_comp
4806 && expr->expr_type != EXPR_VARIABLE)
4808 tmp = build_fold_indirect_ref (se->expr);
4809 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4810 gfc_add_expr_to_block (&se->post, tmp);
4816 /* Repack the array. */
4817 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
4818 ptr = gfc_evaluate_now (ptr, &se->pre);
4821 gfc_start_block (&block);
4823 /* Copy the data back. */
4824 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
4825 gfc_add_expr_to_block (&block, tmp);
4827 /* Free the temporary. */
4828 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
4829 gfc_add_expr_to_block (&block, tmp);
4831 stmt = gfc_finish_block (&block);
4833 gfc_init_block (&block);
4834 /* Only if it was repacked. This code needs to be executed before the
4835 loop cleanup code. */
4836 tmp = build_fold_indirect_ref (desc);
4837 tmp = gfc_conv_array_data (tmp);
4838 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4839 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4841 gfc_add_expr_to_block (&block, tmp);
4842 gfc_add_block_to_block (&block, &se->post);
4844 gfc_init_block (&se->post);
4845 gfc_add_block_to_block (&se->post, &block);
4850 /* Generate code to deallocate an array, if it is allocated. */
4853 gfc_trans_dealloc_allocated (tree descriptor)
4860 gfc_start_block (&block);
4862 var = gfc_conv_descriptor_data_get (descriptor);
4864 tmp = gfc_create_var (gfc_array_index_type, NULL);
4865 ptr = build_fold_addr_expr (tmp);
4867 /* Call array_deallocate with an int* present in the second argument.
4868 Although it is ignored here, it's presence ensures that arrays that
4869 are already deallocated are ignored. */
4870 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
4871 gfc_add_expr_to_block (&block, tmp);
4873 /* Zero the data pointer. */
4874 tmp = build2 (MODIFY_EXPR, void_type_node,
4875 var, build_int_cst (TREE_TYPE (var), 0));
4876 gfc_add_expr_to_block (&block, tmp);
4878 return gfc_finish_block (&block);
4882 /* This helper function calculates the size in words of a full array. */
4885 get_full_array_size (stmtblock_t *block, tree decl, int rank)
4890 idx = gfc_rank_cst[rank - 1];
4891 nelems = gfc_conv_descriptor_ubound (decl, idx);
4892 tmp = gfc_conv_descriptor_lbound (decl, idx);
4893 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4894 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4895 tmp, gfc_index_one_node);
4896 tmp = gfc_evaluate_now (tmp, block);
4898 nelems = gfc_conv_descriptor_stride (decl, idx);
4899 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4900 return gfc_evaluate_now (tmp, block);
4904 /* Allocate dest to the same size as src, and copy src -> dest. */
4907 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
4916 /* If the source is null, set the destination to null. */
4917 gfc_init_block (&block);
4918 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4919 null_data = gfc_finish_block (&block);
4921 gfc_init_block (&block);
4923 nelems = get_full_array_size (&block, src, rank);
4924 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4925 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
4927 /* Allocate memory to the destination. */
4928 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
4930 gfc_conv_descriptor_data_set (&block, dest, tmp);
4932 /* We know the temporary and the value will be the same length,
4933 so can use memcpy. */
4934 tmp = built_in_decls[BUILT_IN_MEMCPY];
4935 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
4936 gfc_conv_descriptor_data_get (src), size);
4937 gfc_add_expr_to_block (&block, tmp);
4938 tmp = gfc_finish_block (&block);
4940 /* Null the destination if the source is null; otherwise do
4941 the allocate and copy. */
4942 null_cond = gfc_conv_descriptor_data_get (src);
4943 null_cond = convert (pvoid_type_node, null_cond);
4944 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4946 return build3_v (COND_EXPR, null_cond, tmp, null_data);
4950 /* Recursively traverse an object of derived type, generating code to
4951 deallocate, nullify or copy allocatable components. This is the work horse
4952 function for the functions named in this enum. */
4954 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4957 structure_alloc_comps (gfc_symbol * der_type, tree decl,
4958 tree dest, int rank, int purpose)
4962 stmtblock_t fnblock;
4963 stmtblock_t loopbody;
4973 tree null_cond = NULL_TREE;
4975 gfc_init_block (&fnblock);
4977 if (POINTER_TYPE_P (TREE_TYPE (decl)))
4978 decl = build_fold_indirect_ref (decl);
4980 /* If this an array of derived types with allocatable components
4981 build a loop and recursively call this function. */
4982 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4983 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4985 tmp = gfc_conv_array_data (decl);
4986 var = build_fold_indirect_ref (tmp);
4988 /* Get the number of elements - 1 and set the counter. */
4989 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4991 /* Use the descriptor for an allocatable array. Since this
4992 is a full array reference, we only need the descriptor
4993 information from dimension = rank. */
4994 tmp = get_full_array_size (&fnblock, decl, rank);
4995 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4996 tmp, gfc_index_one_node);
4998 null_cond = gfc_conv_descriptor_data_get (decl);
4999 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5000 build_int_cst (TREE_TYPE (null_cond), 0));
5004 /* Otherwise use the TYPE_DOMAIN information. */
5005 tmp = array_type_nelts (TREE_TYPE (decl));
5006 tmp = fold_convert (gfc_array_index_type, tmp);
5009 /* Remember that this is, in fact, the no. of elements - 1. */
5010 nelems = gfc_evaluate_now (tmp, &fnblock);
5011 index = gfc_create_var (gfc_array_index_type, "S");
5013 /* Build the body of the loop. */
5014 gfc_init_block (&loopbody);
5016 vref = gfc_build_array_ref (var, index);
5018 if (purpose == COPY_ALLOC_COMP)
5020 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5021 gfc_add_expr_to_block (&fnblock, tmp);
5023 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5024 dref = gfc_build_array_ref (tmp, index);
5025 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5028 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5030 gfc_add_expr_to_block (&loopbody, tmp);
5032 /* Build the loop and return. */
5033 gfc_init_loopinfo (&loop);
5035 loop.from[0] = gfc_index_zero_node;
5036 loop.loopvar[0] = index;
5037 loop.to[0] = nelems;
5038 gfc_trans_scalarizing_loops (&loop, &loopbody);
5039 gfc_add_block_to_block (&fnblock, &loop.pre);
5041 tmp = gfc_finish_block (&fnblock);
5042 if (null_cond != NULL_TREE)
5043 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5048 /* Otherwise, act on the components or recursively call self to
5049 act on a chain of components. */
5050 for (c = der_type->components; c; c = c->next)
5052 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5053 && c->ts.derived->attr.alloc_comp;
5054 cdecl = c->backend_decl;
5055 ctype = TREE_TYPE (cdecl);
5059 case DEALLOCATE_ALLOC_COMP:
5060 /* Do not deallocate the components of ultimate pointer
5062 if (cmp_has_alloc_comps && !c->pointer)
5064 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5065 rank = c->as ? c->as->rank : 0;
5066 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5068 gfc_add_expr_to_block (&fnblock, tmp);
5073 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5074 tmp = gfc_trans_dealloc_allocated (comp);
5075 gfc_add_expr_to_block (&fnblock, tmp);
5079 case NULLIFY_ALLOC_COMP:
5082 else if (c->allocatable)
5084 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5085 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5087 else if (cmp_has_alloc_comps)
5089 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5090 rank = c->as ? c->as->rank : 0;
5091 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5093 gfc_add_expr_to_block (&fnblock, tmp);
5097 case COPY_ALLOC_COMP:
5101 /* We need source and destination components. */
5102 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5103 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5104 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5106 if (c->allocatable && !cmp_has_alloc_comps)
5108 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5109 gfc_add_expr_to_block (&fnblock, tmp);
5112 if (cmp_has_alloc_comps)
5114 rank = c->as ? c->as->rank : 0;
5115 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5116 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5117 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5119 gfc_add_expr_to_block (&fnblock, tmp);
5129 return gfc_finish_block (&fnblock);
5132 /* Recursively traverse an object of derived type, generating code to
5133 nullify allocatable components. */
5136 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5138 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5139 NULLIFY_ALLOC_COMP);
5143 /* Recursively traverse an object of derived type, generating code to
5144 deallocate allocatable components. */
5147 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5149 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5150 DEALLOCATE_ALLOC_COMP);
5154 /* Recursively traverse an object of derived type, generating code to
5155 copy its allocatable components. */
5158 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5160 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5164 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5165 Do likewise, recursively if necessary, with the allocatable components of
5169 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5174 stmtblock_t fnblock;
5177 bool sym_has_alloc_comp;
5179 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5180 && sym->ts.derived->attr.alloc_comp;
5182 /* Make sure the frontend gets these right. */
5183 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5184 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5185 "allocatable attribute or derived type without allocatable "
5188 gfc_init_block (&fnblock);
5190 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5191 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5193 if (sym->ts.type == BT_CHARACTER
5194 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5196 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5197 gfc_trans_vla_type_sizes (sym, &fnblock);
5200 /* Dummy and use associated variables don't need anything special. */
5201 if (sym->attr.dummy || sym->attr.use_assoc)
5203 gfc_add_expr_to_block (&fnblock, body);
5205 return gfc_finish_block (&fnblock);
5208 gfc_get_backend_locus (&loc);
5209 gfc_set_backend_locus (&sym->declared_at);
5210 descriptor = sym->backend_decl;
5212 /* Although static, derived types with default initializers and
5213 allocatable components must not be nulled wholesale; instead they
5214 are treated component by component. */
5215 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5217 /* SAVEd variables are not freed on exit. */
5218 gfc_trans_static_array_pointer (sym);
5222 /* Get the descriptor type. */
5223 type = TREE_TYPE (sym->backend_decl);
5225 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5227 if (!sym->attr.save)
5229 rank = sym->as ? sym->as->rank : 0;
5230 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5231 gfc_add_expr_to_block (&fnblock, tmp);
5234 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5236 /* If the backend_decl is not a descriptor, we must have a pointer
5238 descriptor = build_fold_indirect_ref (sym->backend_decl);
5239 type = TREE_TYPE (descriptor);
5242 /* NULLIFY the data pointer. */
5243 if (GFC_DESCRIPTOR_TYPE_P (type))
5244 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5246 gfc_add_expr_to_block (&fnblock, body);
5248 gfc_set_backend_locus (&loc);
5250 /* Allocatable arrays need to be freed when they go out of scope.
5251 The allocatable components of pointers must not be touched. */
5252 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5253 && !sym->attr.pointer && !sym->attr.save)
5256 rank = sym->as ? sym->as->rank : 0;
5257 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5258 gfc_add_expr_to_block (&fnblock, tmp);
5261 if (sym->attr.allocatable)
5263 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5264 gfc_add_expr_to_block (&fnblock, tmp);
5267 return gfc_finish_block (&fnblock);
5270 /************ Expression Walking Functions ******************/
5272 /* Walk a variable reference.
5274 Possible extension - multiple component subscripts.
5275 x(:,:) = foo%a(:)%b(:)
5277 forall (i=..., j=...)
5278 x(i,j) = foo%a(j)%b(i)
5280 This adds a fair amount of complexity because you need to deal with more
5281 than one ref. Maybe handle in a similar manner to vector subscripts.
5282 Maybe not worth the effort. */
5286 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5294 for (ref = expr->ref; ref; ref = ref->next)
5295 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5298 for (; ref; ref = ref->next)
5300 if (ref->type == REF_SUBSTRING)
5302 newss = gfc_get_ss ();
5303 newss->type = GFC_SS_SCALAR;
5304 newss->expr = ref->u.ss.start;
5308 newss = gfc_get_ss ();
5309 newss->type = GFC_SS_SCALAR;
5310 newss->expr = ref->u.ss.end;
5315 /* We're only interested in array sections from now on. */
5316 if (ref->type != REF_ARRAY)
5323 for (n = 0; n < ar->dimen; n++)
5325 newss = gfc_get_ss ();
5326 newss->type = GFC_SS_SCALAR;
5327 newss->expr = ar->start[n];
5334 newss = gfc_get_ss ();
5335 newss->type = GFC_SS_SECTION;
5338 newss->data.info.dimen = ar->as->rank;
5339 newss->data.info.ref = ref;
5341 /* Make sure array is the same as array(:,:), this way
5342 we don't need to special case all the time. */
5343 ar->dimen = ar->as->rank;
5344 for (n = 0; n < ar->dimen; n++)
5346 newss->data.info.dim[n] = n;
5347 ar->dimen_type[n] = DIMEN_RANGE;
5349 gcc_assert (ar->start[n] == NULL);
5350 gcc_assert (ar->end[n] == NULL);
5351 gcc_assert (ar->stride[n] == NULL);
5357 newss = gfc_get_ss ();
5358 newss->type = GFC_SS_SECTION;
5361 newss->data.info.dimen = 0;
5362 newss->data.info.ref = ref;
5366 /* We add SS chains for all the subscripts in the section. */
5367 for (n = 0; n < ar->dimen; n++)
5371 switch (ar->dimen_type[n])
5374 /* Add SS for elemental (scalar) subscripts. */
5375 gcc_assert (ar->start[n]);
5376 indexss = gfc_get_ss ();
5377 indexss->type = GFC_SS_SCALAR;
5378 indexss->expr = ar->start[n];
5379 indexss->next = gfc_ss_terminator;
5380 indexss->loop_chain = gfc_ss_terminator;
5381 newss->data.info.subscript[n] = indexss;
5385 /* We don't add anything for sections, just remember this
5386 dimension for later. */
5387 newss->data.info.dim[newss->data.info.dimen] = n;
5388 newss->data.info.dimen++;
5392 /* Create a GFC_SS_VECTOR index in which we can store
5393 the vector's descriptor. */
5394 indexss = gfc_get_ss ();
5395 indexss->type = GFC_SS_VECTOR;
5396 indexss->expr = ar->start[n];
5397 indexss->next = gfc_ss_terminator;
5398 indexss->loop_chain = gfc_ss_terminator;
5399 newss->data.info.subscript[n] = indexss;
5400 newss->data.info.dim[newss->data.info.dimen] = n;
5401 newss->data.info.dimen++;
5405 /* We should know what sort of section it is by now. */
5409 /* We should have at least one non-elemental dimension. */
5410 gcc_assert (newss->data.info.dimen > 0);
5415 /* We should know what sort of section it is by now. */
5424 /* Walk an expression operator. If only one operand of a binary expression is
5425 scalar, we must also add the scalar term to the SS chain. */
5428 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5434 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5435 if (expr->value.op.op2 == NULL)
5438 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5440 /* All operands are scalar. Pass back and let the caller deal with it. */
5444 /* All operands require scalarization. */
5445 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5448 /* One of the operands needs scalarization, the other is scalar.
5449 Create a gfc_ss for the scalar expression. */
5450 newss = gfc_get_ss ();
5451 newss->type = GFC_SS_SCALAR;
5454 /* First operand is scalar. We build the chain in reverse order, so
5455 add the scarar SS after the second operand. */
5457 while (head && head->next != ss)
5459 /* Check we haven't somehow broken the chain. */
5463 newss->expr = expr->value.op.op1;
5465 else /* head2 == head */
5467 gcc_assert (head2 == head);
5468 /* Second operand is scalar. */
5469 newss->next = head2;
5471 newss->expr = expr->value.op.op2;
5478 /* Reverse a SS chain. */
5481 gfc_reverse_ss (gfc_ss * ss)
5486 gcc_assert (ss != NULL);
5488 head = gfc_ss_terminator;
5489 while (ss != gfc_ss_terminator)
5492 /* Check we didn't somehow break the chain. */
5493 gcc_assert (next != NULL);
5503 /* Walk the arguments of an elemental function. */
5506 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5514 head = gfc_ss_terminator;
5517 for (; arg; arg = arg->next)
5522 newss = gfc_walk_subexpr (head, arg->expr);
5525 /* Scalar argument. */
5526 newss = gfc_get_ss ();
5528 newss->expr = arg->expr;
5538 while (tail->next != gfc_ss_terminator)
5545 /* If all the arguments are scalar we don't need the argument SS. */
5546 gfc_free_ss_chain (head);
5551 /* Add it onto the existing chain. */
5557 /* Walk a function call. Scalar functions are passed back, and taken out of
5558 scalarization loops. For elemental functions we walk their arguments.
5559 The result of functions returning arrays is stored in a temporary outside
5560 the loop, so that the function is only called once. Hence we do not need
5561 to walk their arguments. */
5564 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5567 gfc_intrinsic_sym *isym;
5570 isym = expr->value.function.isym;
5572 /* Handle intrinsic functions separately. */
5574 return gfc_walk_intrinsic_function (ss, expr, isym);
5576 sym = expr->value.function.esym;
5578 sym = expr->symtree->n.sym;
5580 /* A function that returns arrays. */
5581 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5583 newss = gfc_get_ss ();
5584 newss->type = GFC_SS_FUNCTION;
5587 newss->data.info.dimen = expr->rank;
5591 /* Walk the parameters of an elemental function. For now we always pass
5593 if (sym->attr.elemental)
5594 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5597 /* Scalar functions are OK as these are evaluated outside the scalarization
5598 loop. Pass back and let the caller deal with it. */
5603 /* An array temporary is constructed for array constructors. */
5606 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5611 newss = gfc_get_ss ();
5612 newss->type = GFC_SS_CONSTRUCTOR;
5615 newss->data.info.dimen = expr->rank;
5616 for (n = 0; n < expr->rank; n++)
5617 newss->data.info.dim[n] = n;
5623 /* Walk an expression. Add walked expressions to the head of the SS chain.
5624 A wholly scalar expression will not be added. */
5627 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5631 switch (expr->expr_type)
5634 head = gfc_walk_variable_expr (ss, expr);
5638 head = gfc_walk_op_expr (ss, expr);
5642 head = gfc_walk_function_expr (ss, expr);
5647 case EXPR_STRUCTURE:
5648 /* Pass back and let the caller deal with it. */
5652 head = gfc_walk_array_constructor (ss, expr);
5655 case EXPR_SUBSTRING:
5656 /* Pass back and let the caller deal with it. */
5660 internal_error ("bad expression type during walk (%d)",
5667 /* Entry point for expression walking.
5668 A return value equal to the passed chain means this is
5669 a scalar expression. It is up to the caller to take whatever action is
5670 necessary to translate these. */
5673 gfc_walk_expr (gfc_expr * expr)
5677 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5678 return gfc_reverse_ss (res);