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 fold_convert (gfc_array_index_type,
691 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
699 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
702 if (info->dimen > loop->temp_dim)
703 loop->temp_dim = info->dimen;
709 /* Generate code to transpose array EXPR by creating a new descriptor
710 in which the dimension specifications have been reversed. */
713 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
715 tree dest, src, dest_index, src_index;
717 gfc_ss_info *dest_info, *src_info;
718 gfc_ss *dest_ss, *src_ss;
724 src_ss = gfc_walk_expr (expr);
727 src_info = &src_ss->data.info;
728 dest_info = &dest_ss->data.info;
729 gcc_assert (dest_info->dimen == 2);
730 gcc_assert (src_info->dimen == 2);
732 /* Get a descriptor for EXPR. */
733 gfc_init_se (&src_se, NULL);
734 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
735 gfc_add_block_to_block (&se->pre, &src_se.pre);
736 gfc_add_block_to_block (&se->post, &src_se.post);
739 /* Allocate a new descriptor for the return value. */
740 dest = gfc_create_var (TREE_TYPE (src), "atmp");
741 dest_info->descriptor = dest;
744 /* Copy across the dtype field. */
745 gfc_add_modify_expr (&se->pre,
746 gfc_conv_descriptor_dtype (dest),
747 gfc_conv_descriptor_dtype (src));
749 /* Copy the dimension information, renumbering dimension 1 to 0 and
751 for (n = 0; n < 2; n++)
753 dest_info->delta[n] = gfc_index_zero_node;
754 dest_info->start[n] = gfc_index_zero_node;
755 dest_info->end[n] = gfc_index_zero_node;
756 dest_info->stride[n] = gfc_index_one_node;
757 dest_info->dim[n] = n;
759 dest_index = gfc_rank_cst[n];
760 src_index = gfc_rank_cst[1 - n];
762 gfc_add_modify_expr (&se->pre,
763 gfc_conv_descriptor_stride (dest, dest_index),
764 gfc_conv_descriptor_stride (src, src_index));
766 gfc_add_modify_expr (&se->pre,
767 gfc_conv_descriptor_lbound (dest, dest_index),
768 gfc_conv_descriptor_lbound (src, src_index));
770 gfc_add_modify_expr (&se->pre,
771 gfc_conv_descriptor_ubound (dest, dest_index),
772 gfc_conv_descriptor_ubound (src, src_index));
776 gcc_assert (integer_zerop (loop->from[n]));
777 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
778 gfc_conv_descriptor_ubound (dest, dest_index),
779 gfc_conv_descriptor_lbound (dest, dest_index));
783 /* Copy the data pointer. */
784 dest_info->data = gfc_conv_descriptor_data_get (src);
785 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
787 /* Copy the offset. This is not changed by transposition: the top-left
788 element is still at the same offset as before. */
789 dest_info->offset = gfc_conv_descriptor_offset (src);
790 gfc_add_modify_expr (&se->pre,
791 gfc_conv_descriptor_offset (dest),
794 if (dest_info->dimen > loop->temp_dim)
795 loop->temp_dim = dest_info->dimen;
799 /* Return the number of iterations in a loop that starts at START,
800 ends at END, and has step STEP. */
803 gfc_get_iteration_count (tree start, tree end, tree step)
808 type = TREE_TYPE (step);
809 tmp = fold_build2 (MINUS_EXPR, type, end, start);
810 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
811 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
812 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
813 return fold_convert (gfc_array_index_type, tmp);
817 /* Extend the data in array DESC by EXTRA elements. */
820 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
827 if (integer_zerop (extra))
830 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
832 /* Add EXTRA to the upper bound. */
833 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
834 gfc_add_modify_expr (pblock, ubound, tmp);
836 /* Get the value of the current data pointer. */
837 arg0 = gfc_conv_descriptor_data_get (desc);
839 /* Calculate the new array size. */
840 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
841 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
842 arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
843 fold_convert (gfc_array_index_type, size));
845 /* Pick the appropriate realloc function. */
846 if (gfc_index_integer_kind == 4)
847 tmp = gfor_fndecl_internal_realloc;
848 else if (gfc_index_integer_kind == 8)
849 tmp = gfor_fndecl_internal_realloc64;
853 /* Set the new data pointer. */
854 tmp = build_call_expr (tmp, 2, arg0, arg1);
855 gfc_conv_descriptor_data_set (pblock, desc, tmp);
859 /* Return true if the bounds of iterator I can only be determined
863 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
865 return (i->start->expr_type != EXPR_CONSTANT
866 || i->end->expr_type != EXPR_CONSTANT
867 || i->step->expr_type != EXPR_CONSTANT);
871 /* Split the size of constructor element EXPR into the sum of two terms,
872 one of which can be determined at compile time and one of which must
873 be calculated at run time. Set *SIZE to the former and return true
874 if the latter might be nonzero. */
877 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
879 if (expr->expr_type == EXPR_ARRAY)
880 return gfc_get_array_constructor_size (size, expr->value.constructor);
881 else if (expr->rank > 0)
883 /* Calculate everything at run time. */
884 mpz_set_ui (*size, 0);
889 /* A single element. */
890 mpz_set_ui (*size, 1);
896 /* Like gfc_get_array_constructor_element_size, but applied to the whole
897 of array constructor C. */
900 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
907 mpz_set_ui (*size, 0);
912 for (; c; c = c->next)
915 if (i && gfc_iterator_has_dynamic_bounds (i))
919 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
922 /* Multiply the static part of the element size by the
923 number of iterations. */
924 mpz_sub (val, i->end->value.integer, i->start->value.integer);
925 mpz_fdiv_q (val, val, i->step->value.integer);
926 mpz_add_ui (val, val, 1);
927 if (mpz_sgn (val) > 0)
928 mpz_mul (len, len, val);
932 mpz_add (*size, *size, len);
941 /* Make sure offset is a variable. */
944 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
947 /* We should have already created the offset variable. We cannot
948 create it here because we may be in an inner scope. */
949 gcc_assert (*offsetvar != NULL_TREE);
950 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
951 *poffset = *offsetvar;
952 TREE_USED (*offsetvar) = 1;
956 /* Assign an element of an array constructor. */
959 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
960 tree offset, gfc_se * se, gfc_expr * expr)
964 gfc_conv_expr (se, expr);
966 /* Store the value. */
967 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
968 tmp = gfc_build_array_ref (tmp, offset);
969 if (expr->ts.type == BT_CHARACTER)
971 gfc_conv_string_parameter (se);
972 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
974 /* The temporary is an array of pointers. */
975 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
976 gfc_add_modify_expr (&se->pre, tmp, se->expr);
980 /* The temporary is an array of string values. */
981 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
982 /* We know the temporary and the value will be the same length,
983 so can use memcpy. */
984 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
985 tmp, se->expr, se->string_length);
986 gfc_add_expr_to_block (&se->pre, tmp);
991 /* TODO: Should the frontend already have done this conversion? */
992 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
993 gfc_add_modify_expr (&se->pre, tmp, se->expr);
996 gfc_add_block_to_block (pblock, &se->pre);
997 gfc_add_block_to_block (pblock, &se->post);
1001 /* Add the contents of an array to the constructor. DYNAMIC is as for
1002 gfc_trans_array_constructor_value. */
1005 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1006 tree type ATTRIBUTE_UNUSED,
1007 tree desc, gfc_expr * expr,
1008 tree * poffset, tree * offsetvar,
1019 /* We need this to be a variable so we can increment it. */
1020 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1022 gfc_init_se (&se, NULL);
1024 /* Walk the array expression. */
1025 ss = gfc_walk_expr (expr);
1026 gcc_assert (ss != gfc_ss_terminator);
1028 /* Initialize the scalarizer. */
1029 gfc_init_loopinfo (&loop);
1030 gfc_add_ss_to_loop (&loop, ss);
1032 /* Initialize the loop. */
1033 gfc_conv_ss_startstride (&loop);
1034 gfc_conv_loop_setup (&loop);
1036 /* Make sure the constructed array has room for the new data. */
1039 /* Set SIZE to the total number of elements in the subarray. */
1040 size = gfc_index_one_node;
1041 for (n = 0; n < loop.dimen; n++)
1043 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1044 gfc_index_one_node);
1045 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1048 /* Grow the constructed array by SIZE elements. */
1049 gfc_grow_array (&loop.pre, desc, size);
1052 /* Make the loop body. */
1053 gfc_mark_ss_chain_used (ss, 1);
1054 gfc_start_scalarized_body (&loop, &body);
1055 gfc_copy_loopinfo_to_se (&se, &loop);
1058 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1059 gcc_assert (se.ss == gfc_ss_terminator);
1061 /* Increment the offset. */
1062 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1063 gfc_add_modify_expr (&body, *poffset, tmp);
1065 /* Finish the loop. */
1066 gfc_trans_scalarizing_loops (&loop, &body);
1067 gfc_add_block_to_block (&loop.pre, &loop.post);
1068 tmp = gfc_finish_block (&loop.pre);
1069 gfc_add_expr_to_block (pblock, tmp);
1071 gfc_cleanup_loop (&loop);
1075 /* Assign the values to the elements of an array constructor. DYNAMIC
1076 is true if descriptor DESC only contains enough data for the static
1077 size calculated by gfc_get_array_constructor_size. When true, memory
1078 for the dynamic parts must be allocated using realloc. */
1081 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1082 tree desc, gfc_constructor * c,
1083 tree * poffset, tree * offsetvar,
1092 for (; c; c = c->next)
1094 /* If this is an iterator or an array, the offset must be a variable. */
1095 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1096 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1098 gfc_start_block (&body);
1100 if (c->expr->expr_type == EXPR_ARRAY)
1102 /* Array constructors can be nested. */
1103 gfc_trans_array_constructor_value (&body, type, desc,
1104 c->expr->value.constructor,
1105 poffset, offsetvar, dynamic);
1107 else if (c->expr->rank > 0)
1109 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1110 poffset, offsetvar, dynamic);
1114 /* This code really upsets the gimplifier so don't bother for now. */
1121 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1128 /* Scalar values. */
1129 gfc_init_se (&se, NULL);
1130 gfc_trans_array_ctor_element (&body, desc, *poffset,
1133 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1134 *poffset, gfc_index_one_node);
1138 /* Collect multiple scalar constants into a constructor. */
1146 /* Count the number of consecutive scalar constants. */
1147 while (p && !(p->iterator
1148 || p->expr->expr_type != EXPR_CONSTANT))
1150 gfc_init_se (&se, NULL);
1151 gfc_conv_constant (&se, p->expr);
1152 if (p->expr->ts.type == BT_CHARACTER
1153 && POINTER_TYPE_P (type))
1155 /* For constant character array constructors we build
1156 an array of pointers. */
1157 se.expr = gfc_build_addr_expr (pchar_type_node,
1161 list = tree_cons (NULL_TREE, se.expr, list);
1166 bound = build_int_cst (NULL_TREE, n - 1);
1167 /* Create an array type to hold them. */
1168 tmptype = build_range_type (gfc_array_index_type,
1169 gfc_index_zero_node, bound);
1170 tmptype = build_array_type (type, tmptype);
1172 init = build_constructor_from_list (tmptype, nreverse (list));
1173 TREE_CONSTANT (init) = 1;
1174 TREE_INVARIANT (init) = 1;
1175 TREE_STATIC (init) = 1;
1176 /* Create a static variable to hold the data. */
1177 tmp = gfc_create_var (tmptype, "data");
1178 TREE_STATIC (tmp) = 1;
1179 TREE_CONSTANT (tmp) = 1;
1180 TREE_INVARIANT (tmp) = 1;
1181 TREE_READONLY (tmp) = 1;
1182 DECL_INITIAL (tmp) = init;
1185 /* Use BUILTIN_MEMCPY to assign the values. */
1186 tmp = gfc_conv_descriptor_data_get (desc);
1187 tmp = build_fold_indirect_ref (tmp);
1188 tmp = gfc_build_array_ref (tmp, *poffset);
1189 tmp = build_fold_addr_expr (tmp);
1190 init = build_fold_addr_expr (init);
1192 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1193 bound = build_int_cst (NULL_TREE, n * size);
1194 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1196 gfc_add_expr_to_block (&body, tmp);
1198 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1200 build_int_cst (gfc_array_index_type, n));
1202 if (!INTEGER_CST_P (*poffset))
1204 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1205 *poffset = *offsetvar;
1209 /* The frontend should already have done any expansions possible
1213 /* Pass the code as is. */
1214 tmp = gfc_finish_block (&body);
1215 gfc_add_expr_to_block (pblock, tmp);
1219 /* Build the implied do-loop. */
1229 loopbody = gfc_finish_block (&body);
1231 gfc_init_se (&se, NULL);
1232 gfc_conv_expr (&se, c->iterator->var);
1233 gfc_add_block_to_block (pblock, &se.pre);
1236 /* Make a temporary, store the current value in that
1237 and return it, once the loop is done. */
1238 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1239 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1241 /* Initialize the loop. */
1242 gfc_init_se (&se, NULL);
1243 gfc_conv_expr_val (&se, c->iterator->start);
1244 gfc_add_block_to_block (pblock, &se.pre);
1245 gfc_add_modify_expr (pblock, loopvar, se.expr);
1247 gfc_init_se (&se, NULL);
1248 gfc_conv_expr_val (&se, c->iterator->end);
1249 gfc_add_block_to_block (pblock, &se.pre);
1250 end = gfc_evaluate_now (se.expr, pblock);
1252 gfc_init_se (&se, NULL);
1253 gfc_conv_expr_val (&se, c->iterator->step);
1254 gfc_add_block_to_block (pblock, &se.pre);
1255 step = gfc_evaluate_now (se.expr, pblock);
1257 /* If this array expands dynamically, and the number of iterations
1258 is not constant, we won't have allocated space for the static
1259 part of C->EXPR's size. Do that now. */
1260 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1262 /* Get the number of iterations. */
1263 tmp = gfc_get_iteration_count (loopvar, end, step);
1265 /* Get the static part of C->EXPR's size. */
1266 gfc_get_array_constructor_element_size (&size, c->expr);
1267 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1269 /* Grow the array by TMP * TMP2 elements. */
1270 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1271 gfc_grow_array (pblock, desc, tmp);
1274 /* Generate the loop body. */
1275 exit_label = gfc_build_label_decl (NULL_TREE);
1276 gfc_start_block (&body);
1278 /* Generate the exit condition. Depending on the sign of
1279 the step variable we have to generate the correct
1281 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1282 build_int_cst (TREE_TYPE (step), 0));
1283 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1284 build2 (GT_EXPR, boolean_type_node,
1286 build2 (LT_EXPR, boolean_type_node,
1288 tmp = build1_v (GOTO_EXPR, exit_label);
1289 TREE_USED (exit_label) = 1;
1290 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1291 gfc_add_expr_to_block (&body, tmp);
1293 /* The main loop body. */
1294 gfc_add_expr_to_block (&body, loopbody);
1296 /* Increase loop variable by step. */
1297 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1298 gfc_add_modify_expr (&body, loopvar, tmp);
1300 /* Finish the loop. */
1301 tmp = gfc_finish_block (&body);
1302 tmp = build1_v (LOOP_EXPR, tmp);
1303 gfc_add_expr_to_block (pblock, tmp);
1305 /* Add the exit label. */
1306 tmp = build1_v (LABEL_EXPR, exit_label);
1307 gfc_add_expr_to_block (pblock, tmp);
1309 /* Restore the original value of the loop counter. */
1310 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1317 /* Figure out the string length of a variable reference expression.
1318 Used by get_array_ctor_strlen. */
1321 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1327 /* Don't bother if we already know the length is a constant. */
1328 if (*len && INTEGER_CST_P (*len))
1331 ts = &expr->symtree->n.sym->ts;
1332 for (ref = expr->ref; ref; ref = ref->next)
1337 /* Array references don't change the string length. */
1341 /* Use the length of the component. */
1342 ts = &ref->u.c.component->ts;
1346 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1347 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1349 mpz_init_set_ui (char_len, 1);
1350 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1351 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1352 *len = gfc_conv_mpz_to_tree (char_len,
1353 gfc_default_character_kind);
1354 *len = convert (gfc_charlen_type_node, *len);
1355 mpz_clear (char_len);
1359 /* TODO: Substrings are tricky because we can't evaluate the
1360 expression more than once. For now we just give up, and hope
1361 we can figure it out elsewhere. */
1366 *len = ts->cl->backend_decl;
1370 /* A catch-all to obtain the string length for anything that is not a
1371 constant, array or variable. */
1373 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1378 /* Don't bother if we already know the length is a constant. */
1379 if (*len && INTEGER_CST_P (*len))
1382 if (!e->ref && e->ts.cl->length
1383 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1386 gfc_conv_const_charlen (e->ts.cl);
1387 *len = e->ts.cl->backend_decl;
1391 /* Otherwise, be brutal even if inefficient. */
1392 ss = gfc_walk_expr (e);
1393 gfc_init_se (&se, NULL);
1395 /* No function call, in case of side effects. */
1396 se.no_function_call = 1;
1397 if (ss == gfc_ss_terminator)
1398 gfc_conv_expr (&se, e);
1400 gfc_conv_expr_descriptor (&se, e, ss);
1402 /* Fix the value. */
1403 *len = gfc_evaluate_now (se.string_length, &se.pre);
1405 gfc_add_block_to_block (block, &se.pre);
1406 gfc_add_block_to_block (block, &se.post);
1408 e->ts.cl->backend_decl = *len;
1413 /* Figure out the string length of a character array constructor.
1414 Returns TRUE if all elements are character constants. */
1417 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1422 for (; c; c = c->next)
1424 switch (c->expr->expr_type)
1427 if (!(*len && INTEGER_CST_P (*len)))
1428 *len = build_int_cstu (gfc_charlen_type_node,
1429 c->expr->value.character.length);
1433 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1439 get_array_ctor_var_strlen (c->expr, len);
1444 get_array_ctor_all_strlen (block, c->expr, len);
1452 /* Check whether the array constructor C consists entirely of constant
1453 elements, and if so returns the number of those elements, otherwise
1454 return zero. Note, an empty or NULL array constructor returns zero. */
1456 unsigned HOST_WIDE_INT
1457 gfc_constant_array_constructor_p (gfc_constructor * c)
1459 unsigned HOST_WIDE_INT nelem = 0;
1464 || c->expr->rank > 0
1465 || c->expr->expr_type != EXPR_CONSTANT)
1474 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1475 and the tree type of it's elements, TYPE, return a static constant
1476 variable that is compile-time initialized. */
1479 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1481 tree tmptype, list, init, tmp;
1482 HOST_WIDE_INT nelem;
1488 /* First traverse the constructor list, converting the constants
1489 to tree to build an initializer. */
1492 c = expr->value.constructor;
1495 gfc_init_se (&se, NULL);
1496 gfc_conv_constant (&se, c->expr);
1497 if (c->expr->ts.type == BT_CHARACTER
1498 && POINTER_TYPE_P (type))
1499 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
1500 list = tree_cons (NULL_TREE, se.expr, list);
1505 /* Next determine the tree type for the array. We use the gfortran
1506 front-end's gfc_get_nodesc_array_type in order to create a suitable
1507 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1509 memset (&as, 0, sizeof (gfc_array_spec));
1511 as.rank = expr->rank;
1512 as.type = AS_EXPLICIT;
1515 as.lower[0] = gfc_int_expr (0);
1516 as.upper[0] = gfc_int_expr (nelem - 1);
1519 for (i = 0; i < expr->rank; i++)
1521 int tmp = (int) mpz_get_si (expr->shape[i]);
1522 as.lower[i] = gfc_int_expr (0);
1523 as.upper[i] = gfc_int_expr (tmp - 1);
1526 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1528 init = build_constructor_from_list (tmptype, nreverse (list));
1530 TREE_CONSTANT (init) = 1;
1531 TREE_INVARIANT (init) = 1;
1532 TREE_STATIC (init) = 1;
1534 tmp = gfc_create_var (tmptype, "A");
1535 TREE_STATIC (tmp) = 1;
1536 TREE_CONSTANT (tmp) = 1;
1537 TREE_INVARIANT (tmp) = 1;
1538 TREE_READONLY (tmp) = 1;
1539 DECL_INITIAL (tmp) = init;
1545 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1546 This mostly initializes the scalarizer state info structure with the
1547 appropriate values to directly use the array created by the function
1548 gfc_build_constant_array_constructor. */
1551 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1552 gfc_ss * ss, tree type)
1558 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1560 info = &ss->data.info;
1562 info->descriptor = tmp;
1563 info->data = build_fold_addr_expr (tmp);
1564 info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
1567 for (i = 0; i < info->dimen; i++)
1569 info->delta[i] = gfc_index_zero_node;
1570 info->start[i] = gfc_index_zero_node;
1571 info->end[i] = gfc_index_zero_node;
1572 info->stride[i] = gfc_index_one_node;
1576 if (info->dimen > loop->temp_dim)
1577 loop->temp_dim = info->dimen;
1580 /* Helper routine of gfc_trans_array_constructor to determine if the
1581 bounds of the loop specified by LOOP are constant and simple enough
1582 to use with gfc_trans_constant_array_constructor. Returns the
1583 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1586 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1588 tree size = gfc_index_one_node;
1592 for (i = 0; i < loop->dimen; i++)
1594 /* If the bounds aren't constant, return NULL_TREE. */
1595 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1597 if (!integer_zerop (loop->from[i]))
1599 /* Only allow non-zero "from" in one-dimensional arrays. */
1600 if (loop->dimen != 1)
1602 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1603 loop->to[i], loop->from[i]);
1607 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1608 tmp, gfc_index_one_node);
1609 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1616 /* Array constructors are handled by constructing a temporary, then using that
1617 within the scalarization loop. This is not optimal, but seems by far the
1621 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1630 ss->data.info.dimen = loop->dimen;
1632 c = ss->expr->value.constructor;
1633 if (ss->expr->ts.type == BT_CHARACTER)
1635 bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
1636 if (!ss->string_length)
1637 gfc_todo_error ("complex character array constructors");
1639 /* It is surprising but still possible to wind up with expressions that
1640 lack a character length.
1641 TODO Find the offending part of the front end and cure this properly.
1642 Concatenation involving arrays is the main culprit. */
1643 if (!ss->expr->ts.cl)
1645 ss->expr->ts.cl = gfc_get_charlen ();
1646 ss->expr->ts.cl->next = gfc_current_ns->cl_list;
1647 gfc_current_ns->cl_list = ss->expr->ts.cl->next;
1650 ss->expr->ts.cl->backend_decl = ss->string_length;
1652 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1654 type = build_pointer_type (type);
1657 type = gfc_typenode_for_spec (&ss->expr->ts);
1659 /* See if the constructor determines the loop bounds. */
1661 if (loop->to[0] == NULL_TREE)
1665 /* We should have a 1-dimensional, zero-based loop. */
1666 gcc_assert (loop->dimen == 1);
1667 gcc_assert (integer_zerop (loop->from[0]));
1669 /* Split the constructor size into a static part and a dynamic part.
1670 Allocate the static size up-front and record whether the dynamic
1671 size might be nonzero. */
1673 dynamic = gfc_get_array_constructor_size (&size, c);
1674 mpz_sub_ui (size, size, 1);
1675 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1679 /* Special case constant array constructors. */
1682 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1685 tree size = constant_array_constructor_loop_size (loop);
1686 if (size && compare_tree_int (size, nelem) == 0)
1688 gfc_trans_constant_array_constructor (loop, ss, type);
1694 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1695 type, dynamic, true, false);
1697 desc = ss->data.info.descriptor;
1698 offset = gfc_index_zero_node;
1699 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1700 TREE_USED (offsetvar) = 0;
1701 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1702 &offset, &offsetvar, dynamic);
1704 /* If the array grows dynamically, the upper bound of the loop variable
1705 is determined by the array's final upper bound. */
1707 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1709 if (TREE_USED (offsetvar))
1710 pushdecl (offsetvar);
1712 gcc_assert (INTEGER_CST_P (offset));
1714 /* Disable bound checking for now because it's probably broken. */
1715 if (flag_bounds_check)
1723 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1724 called after evaluating all of INFO's vector dimensions. Go through
1725 each such vector dimension and see if we can now fill in any missing
1729 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1738 for (n = 0; n < loop->dimen; n++)
1741 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1742 && loop->to[n] == NULL)
1744 /* Loop variable N indexes vector dimension DIM, and we don't
1745 yet know the upper bound of loop variable N. Set it to the
1746 difference between the vector's upper and lower bounds. */
1747 gcc_assert (loop->from[n] == gfc_index_zero_node);
1748 gcc_assert (info->subscript[dim]
1749 && info->subscript[dim]->type == GFC_SS_VECTOR);
1751 gfc_init_se (&se, NULL);
1752 desc = info->subscript[dim]->data.info.descriptor;
1753 zero = gfc_rank_cst[0];
1754 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1755 gfc_conv_descriptor_ubound (desc, zero),
1756 gfc_conv_descriptor_lbound (desc, zero));
1757 tmp = gfc_evaluate_now (tmp, &loop->pre);
1764 /* Add the pre and post chains for all the scalar expressions in a SS chain
1765 to loop. This is called after the loop parameters have been calculated,
1766 but before the actual scalarizing loops. */
1769 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1774 /* TODO: This can generate bad code if there are ordering dependencies.
1775 eg. a callee allocated function and an unknown size constructor. */
1776 gcc_assert (ss != NULL);
1778 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1785 /* Scalar expression. Evaluate this now. This includes elemental
1786 dimension indices, but not array section bounds. */
1787 gfc_init_se (&se, NULL);
1788 gfc_conv_expr (&se, ss->expr);
1789 gfc_add_block_to_block (&loop->pre, &se.pre);
1791 if (ss->expr->ts.type != BT_CHARACTER)
1793 /* Move the evaluation of scalar expressions outside the
1794 scalarization loop. */
1796 se.expr = convert(gfc_array_index_type, se.expr);
1797 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1798 gfc_add_block_to_block (&loop->pre, &se.post);
1801 gfc_add_block_to_block (&loop->post, &se.post);
1803 ss->data.scalar.expr = se.expr;
1804 ss->string_length = se.string_length;
1807 case GFC_SS_REFERENCE:
1808 /* Scalar reference. Evaluate this now. */
1809 gfc_init_se (&se, NULL);
1810 gfc_conv_expr_reference (&se, ss->expr);
1811 gfc_add_block_to_block (&loop->pre, &se.pre);
1812 gfc_add_block_to_block (&loop->post, &se.post);
1814 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1815 ss->string_length = se.string_length;
1818 case GFC_SS_SECTION:
1819 /* Add the expressions for scalar and vector subscripts. */
1820 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1821 if (ss->data.info.subscript[n])
1822 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1824 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1828 /* Get the vector's descriptor and store it in SS. */
1829 gfc_init_se (&se, NULL);
1830 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1831 gfc_add_block_to_block (&loop->pre, &se.pre);
1832 gfc_add_block_to_block (&loop->post, &se.post);
1833 ss->data.info.descriptor = se.expr;
1836 case GFC_SS_INTRINSIC:
1837 gfc_add_intrinsic_ss_code (loop, ss);
1840 case GFC_SS_FUNCTION:
1841 /* Array function return value. We call the function and save its
1842 result in a temporary for use inside the loop. */
1843 gfc_init_se (&se, NULL);
1846 gfc_conv_expr (&se, ss->expr);
1847 gfc_add_block_to_block (&loop->pre, &se.pre);
1848 gfc_add_block_to_block (&loop->post, &se.post);
1849 ss->string_length = se.string_length;
1852 case GFC_SS_CONSTRUCTOR:
1853 gfc_trans_array_constructor (loop, ss);
1857 case GFC_SS_COMPONENT:
1858 /* Do nothing. These are handled elsewhere. */
1868 /* Translate expressions for the descriptor and data pointer of a SS. */
1872 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1877 /* Get the descriptor for the array to be scalarized. */
1878 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1879 gfc_init_se (&se, NULL);
1880 se.descriptor_only = 1;
1881 gfc_conv_expr_lhs (&se, ss->expr);
1882 gfc_add_block_to_block (block, &se.pre);
1883 ss->data.info.descriptor = se.expr;
1884 ss->string_length = se.string_length;
1888 /* Also the data pointer. */
1889 tmp = gfc_conv_array_data (se.expr);
1890 /* If this is a variable or address of a variable we use it directly.
1891 Otherwise we must evaluate it now to avoid breaking dependency
1892 analysis by pulling the expressions for elemental array indices
1895 || (TREE_CODE (tmp) == ADDR_EXPR
1896 && DECL_P (TREE_OPERAND (tmp, 0)))))
1897 tmp = gfc_evaluate_now (tmp, block);
1898 ss->data.info.data = tmp;
1900 tmp = gfc_conv_array_offset (se.expr);
1901 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1906 /* Initialize a gfc_loopinfo structure. */
1909 gfc_init_loopinfo (gfc_loopinfo * loop)
1913 memset (loop, 0, sizeof (gfc_loopinfo));
1914 gfc_init_block (&loop->pre);
1915 gfc_init_block (&loop->post);
1917 /* Initially scalarize in order. */
1918 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1921 loop->ss = gfc_ss_terminator;
1925 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1929 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1935 /* Return an expression for the data pointer of an array. */
1938 gfc_conv_array_data (tree descriptor)
1942 type = TREE_TYPE (descriptor);
1943 if (GFC_ARRAY_TYPE_P (type))
1945 if (TREE_CODE (type) == POINTER_TYPE)
1949 /* Descriptorless arrays. */
1950 return build_fold_addr_expr (descriptor);
1954 return gfc_conv_descriptor_data_get (descriptor);
1958 /* Return an expression for the base offset of an array. */
1961 gfc_conv_array_offset (tree descriptor)
1965 type = TREE_TYPE (descriptor);
1966 if (GFC_ARRAY_TYPE_P (type))
1967 return GFC_TYPE_ARRAY_OFFSET (type);
1969 return gfc_conv_descriptor_offset (descriptor);
1973 /* Get an expression for the array stride. */
1976 gfc_conv_array_stride (tree descriptor, int dim)
1981 type = TREE_TYPE (descriptor);
1983 /* For descriptorless arrays use the array size. */
1984 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1985 if (tmp != NULL_TREE)
1988 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1993 /* Like gfc_conv_array_stride, but for the lower bound. */
1996 gfc_conv_array_lbound (tree descriptor, int dim)
2001 type = TREE_TYPE (descriptor);
2003 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2004 if (tmp != NULL_TREE)
2007 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2012 /* Like gfc_conv_array_stride, but for the upper bound. */
2015 gfc_conv_array_ubound (tree descriptor, int dim)
2020 type = TREE_TYPE (descriptor);
2022 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2023 if (tmp != NULL_TREE)
2026 /* This should only ever happen when passing an assumed shape array
2027 as an actual parameter. The value will never be used. */
2028 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2029 return gfc_index_zero_node;
2031 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2036 /* Generate code to perform an array index bound check. */
2039 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2040 locus * where, bool check_upper)
2045 const char * name = NULL;
2047 if (!flag_bounds_check)
2050 index = gfc_evaluate_now (index, &se->pre);
2052 /* We find a name for the error message. */
2054 name = se->ss->expr->symtree->name;
2056 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2057 && se->loop->ss->expr->symtree)
2058 name = se->loop->ss->expr->symtree->name;
2060 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2061 && se->loop->ss->loop_chain->expr
2062 && se->loop->ss->loop_chain->expr->symtree)
2063 name = se->loop->ss->loop_chain->expr->symtree->name;
2065 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2066 && se->loop->ss->loop_chain->expr->symtree)
2067 name = se->loop->ss->loop_chain->expr->symtree->name;
2069 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2071 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2072 && se->loop->ss->expr->value.function.name)
2073 name = se->loop->ss->expr->value.function.name;
2075 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2076 || se->loop->ss->type == GFC_SS_SCALAR)
2077 name = "unnamed constant";
2080 /* Check lower bound. */
2081 tmp = gfc_conv_array_lbound (descriptor, n);
2082 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2084 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
2085 gfc_msg_fault, name, n+1);
2087 asprintf (&msg, "%s, lower bound of dimension %d exceeded",
2088 gfc_msg_fault, n+1);
2089 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2092 /* Check upper bound. */
2095 tmp = gfc_conv_array_ubound (descriptor, n);
2096 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2098 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2099 " exceeded", gfc_msg_fault, name, n+1);
2101 asprintf (&msg, "%s, upper bound of dimension %d exceeded",
2102 gfc_msg_fault, n+1);
2103 gfc_trans_runtime_check (fault, msg, &se->pre, where);
2111 /* Return the offset for an index. Performs bound checking for elemental
2112 dimensions. Single element references are processed separately. */
2115 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2116 gfc_array_ref * ar, tree stride)
2122 /* Get the index into the array for this dimension. */
2125 gcc_assert (ar->type != AR_ELEMENT);
2126 switch (ar->dimen_type[dim])
2129 gcc_assert (i == -1);
2130 /* Elemental dimension. */
2131 gcc_assert (info->subscript[dim]
2132 && info->subscript[dim]->type == GFC_SS_SCALAR);
2133 /* We've already translated this value outside the loop. */
2134 index = info->subscript[dim]->data.scalar.expr;
2136 index = gfc_trans_array_bound_check (se, info->descriptor,
2137 index, dim, &ar->where,
2138 (ar->as->type != AS_ASSUMED_SIZE
2139 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2143 gcc_assert (info && se->loop);
2144 gcc_assert (info->subscript[dim]
2145 && info->subscript[dim]->type == GFC_SS_VECTOR);
2146 desc = info->subscript[dim]->data.info.descriptor;
2148 /* Get a zero-based index into the vector. */
2149 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2150 se->loop->loopvar[i], se->loop->from[i]);
2152 /* Multiply the index by the stride. */
2153 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2154 index, gfc_conv_array_stride (desc, 0));
2156 /* Read the vector to get an index into info->descriptor. */
2157 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2158 index = gfc_build_array_ref (data, index);
2159 index = gfc_evaluate_now (index, &se->pre);
2161 /* Do any bounds checking on the final info->descriptor index. */
2162 index = gfc_trans_array_bound_check (se, info->descriptor,
2163 index, dim, &ar->where,
2164 (ar->as->type != AS_ASSUMED_SIZE
2165 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2169 /* Scalarized dimension. */
2170 gcc_assert (info && se->loop);
2172 /* Multiply the loop variable by the stride and delta. */
2173 index = se->loop->loopvar[i];
2174 if (!integer_onep (info->stride[i]))
2175 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2177 if (!integer_zerop (info->delta[i]))
2178 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2188 /* Temporary array or derived type component. */
2189 gcc_assert (se->loop);
2190 index = se->loop->loopvar[se->loop->order[i]];
2191 if (!integer_zerop (info->delta[i]))
2192 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2193 index, info->delta[i]);
2196 /* Multiply by the stride. */
2197 if (!integer_onep (stride))
2198 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2204 /* Build a scalarized reference to an array. */
2207 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2214 info = &se->ss->data.info;
2216 n = se->loop->order[0];
2220 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2222 /* Add the offset for this dimension to the stored offset for all other
2224 if (!integer_zerop (info->offset))
2225 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2227 tmp = build_fold_indirect_ref (info->data);
2228 se->expr = gfc_build_array_ref (tmp, index);
2232 /* Translate access of temporary array. */
2235 gfc_conv_tmp_array_ref (gfc_se * se)
2237 se->string_length = se->ss->string_length;
2238 gfc_conv_scalarized_array_ref (se, NULL);
2242 /* Build an array reference. se->expr already holds the array descriptor.
2243 This should be either a variable, indirect variable reference or component
2244 reference. For arrays which do not have a descriptor, se->expr will be
2246 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2249 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2258 /* Handle scalarized references separately. */
2259 if (ar->type != AR_ELEMENT)
2261 gfc_conv_scalarized_array_ref (se, ar);
2262 gfc_advance_se_ss_chain (se);
2266 index = gfc_index_zero_node;
2268 /* Calculate the offsets from all the dimensions. */
2269 for (n = 0; n < ar->dimen; n++)
2271 /* Calculate the index for this dimension. */
2272 gfc_init_se (&indexse, se);
2273 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2274 gfc_add_block_to_block (&se->pre, &indexse.pre);
2276 if (flag_bounds_check)
2278 /* Check array bounds. */
2283 tmp = gfc_conv_array_lbound (se->expr, n);
2284 cond = fold_build2 (LT_EXPR, boolean_type_node,
2286 asprintf (&msg, "%s for array '%s', "
2287 "lower bound of dimension %d exceeded", gfc_msg_fault,
2289 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2292 /* Upper bound, but not for the last dimension of assumed-size
2294 if (n < ar->dimen - 1
2295 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2297 tmp = gfc_conv_array_ubound (se->expr, n);
2298 cond = fold_build2 (GT_EXPR, boolean_type_node,
2300 asprintf (&msg, "%s for array '%s', "
2301 "upper bound of dimension %d exceeded", gfc_msg_fault,
2303 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2308 /* Multiply the index by the stride. */
2309 stride = gfc_conv_array_stride (se->expr, n);
2310 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2313 /* And add it to the total. */
2314 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2317 tmp = gfc_conv_array_offset (se->expr);
2318 if (!integer_zerop (tmp))
2319 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2321 /* Access the calculated element. */
2322 tmp = gfc_conv_array_data (se->expr);
2323 tmp = build_fold_indirect_ref (tmp);
2324 se->expr = gfc_build_array_ref (tmp, index);
2328 /* Generate the code to be executed immediately before entering a
2329 scalarization loop. */
2332 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2333 stmtblock_t * pblock)
2342 /* This code will be executed before entering the scalarization loop
2343 for this dimension. */
2344 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2346 if ((ss->useflags & flag) == 0)
2349 if (ss->type != GFC_SS_SECTION
2350 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2351 && ss->type != GFC_SS_COMPONENT)
2354 info = &ss->data.info;
2356 if (dim >= info->dimen)
2359 if (dim == info->dimen - 1)
2361 /* For the outermost loop calculate the offset due to any
2362 elemental dimensions. It will have been initialized with the
2363 base offset of the array. */
2366 for (i = 0; i < info->ref->u.ar.dimen; i++)
2368 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2371 gfc_init_se (&se, NULL);
2373 se.expr = info->descriptor;
2374 stride = gfc_conv_array_stride (info->descriptor, i);
2375 index = gfc_conv_array_index_offset (&se, info, i, -1,
2378 gfc_add_block_to_block (pblock, &se.pre);
2380 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2381 info->offset, index);
2382 info->offset = gfc_evaluate_now (info->offset, pblock);
2386 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2389 stride = gfc_conv_array_stride (info->descriptor, 0);
2391 /* Calculate the stride of the innermost loop. Hopefully this will
2392 allow the backend optimizers to do their stuff more effectively.
2394 info->stride0 = gfc_evaluate_now (stride, pblock);
2398 /* Add the offset for the previous loop dimension. */
2403 ar = &info->ref->u.ar;
2404 i = loop->order[dim + 1];
2412 gfc_init_se (&se, NULL);
2414 se.expr = info->descriptor;
2415 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2416 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2418 gfc_add_block_to_block (pblock, &se.pre);
2419 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2420 info->offset, index);
2421 info->offset = gfc_evaluate_now (info->offset, pblock);
2424 /* Remember this offset for the second loop. */
2425 if (dim == loop->temp_dim - 1)
2426 info->saved_offset = info->offset;
2431 /* Start a scalarized expression. Creates a scope and declares loop
2435 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2441 gcc_assert (!loop->array_parameter);
2443 for (dim = loop->dimen - 1; dim >= 0; dim--)
2445 n = loop->order[dim];
2447 gfc_start_block (&loop->code[n]);
2449 /* Create the loop variable. */
2450 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2452 if (dim < loop->temp_dim)
2456 /* Calculate values that will be constant within this loop. */
2457 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2459 gfc_start_block (pbody);
2463 /* Generates the actual loop code for a scalarization loop. */
2466 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2467 stmtblock_t * pbody)
2475 loopbody = gfc_finish_block (pbody);
2477 /* Initialize the loopvar. */
2478 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2480 exit_label = gfc_build_label_decl (NULL_TREE);
2482 /* Generate the loop body. */
2483 gfc_init_block (&block);
2485 /* The exit condition. */
2486 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2487 tmp = build1_v (GOTO_EXPR, exit_label);
2488 TREE_USED (exit_label) = 1;
2489 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2490 gfc_add_expr_to_block (&block, tmp);
2492 /* The main body. */
2493 gfc_add_expr_to_block (&block, loopbody);
2495 /* Increment the loopvar. */
2496 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2497 loop->loopvar[n], gfc_index_one_node);
2498 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2500 /* Build the loop. */
2501 tmp = gfc_finish_block (&block);
2502 tmp = build1_v (LOOP_EXPR, tmp);
2503 gfc_add_expr_to_block (&loop->code[n], tmp);
2505 /* Add the exit label. */
2506 tmp = build1_v (LABEL_EXPR, exit_label);
2507 gfc_add_expr_to_block (&loop->code[n], tmp);
2511 /* Finishes and generates the loops for a scalarized expression. */
2514 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2519 stmtblock_t *pblock;
2523 /* Generate the loops. */
2524 for (dim = 0; dim < loop->dimen; dim++)
2526 n = loop->order[dim];
2527 gfc_trans_scalarized_loop_end (loop, n, pblock);
2528 loop->loopvar[n] = NULL_TREE;
2529 pblock = &loop->code[n];
2532 tmp = gfc_finish_block (pblock);
2533 gfc_add_expr_to_block (&loop->pre, tmp);
2535 /* Clear all the used flags. */
2536 for (ss = loop->ss; ss; ss = ss->loop_chain)
2541 /* Finish the main body of a scalarized expression, and start the secondary
2545 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2549 stmtblock_t *pblock;
2553 /* We finish as many loops as are used by the temporary. */
2554 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2556 n = loop->order[dim];
2557 gfc_trans_scalarized_loop_end (loop, n, pblock);
2558 loop->loopvar[n] = NULL_TREE;
2559 pblock = &loop->code[n];
2562 /* We don't want to finish the outermost loop entirely. */
2563 n = loop->order[loop->temp_dim - 1];
2564 gfc_trans_scalarized_loop_end (loop, n, pblock);
2566 /* Restore the initial offsets. */
2567 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2569 if ((ss->useflags & 2) == 0)
2572 if (ss->type != GFC_SS_SECTION
2573 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2574 && ss->type != GFC_SS_COMPONENT)
2577 ss->data.info.offset = ss->data.info.saved_offset;
2580 /* Restart all the inner loops we just finished. */
2581 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2583 n = loop->order[dim];
2585 gfc_start_block (&loop->code[n]);
2587 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2589 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2592 /* Start a block for the secondary copying code. */
2593 gfc_start_block (body);
2597 /* Calculate the upper bound of an array section. */
2600 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2609 gcc_assert (ss->type == GFC_SS_SECTION);
2611 info = &ss->data.info;
2614 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2615 /* We'll calculate the upper bound once we have access to the
2616 vector's descriptor. */
2619 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2620 desc = info->descriptor;
2621 end = info->ref->u.ar.end[dim];
2625 /* The upper bound was specified. */
2626 gfc_init_se (&se, NULL);
2627 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2628 gfc_add_block_to_block (pblock, &se.pre);
2633 /* No upper bound was specified, so use the bound of the array. */
2634 bound = gfc_conv_array_ubound (desc, dim);
2641 /* Calculate the lower bound of an array section. */
2644 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2654 gcc_assert (ss->type == GFC_SS_SECTION);
2656 info = &ss->data.info;
2659 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2661 /* We use a zero-based index to access the vector. */
2662 info->start[n] = gfc_index_zero_node;
2663 info->end[n] = gfc_index_zero_node;
2664 info->stride[n] = gfc_index_one_node;
2668 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2669 desc = info->descriptor;
2670 start = info->ref->u.ar.start[dim];
2671 end = info->ref->u.ar.end[dim];
2672 stride = info->ref->u.ar.stride[dim];
2674 /* Calculate the start of the range. For vector subscripts this will
2675 be the range of the vector. */
2678 /* Specified section start. */
2679 gfc_init_se (&se, NULL);
2680 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2681 gfc_add_block_to_block (&loop->pre, &se.pre);
2682 info->start[n] = se.expr;
2686 /* No lower bound specified so use the bound of the array. */
2687 info->start[n] = gfc_conv_array_lbound (desc, dim);
2689 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2691 /* Similarly calculate the end. Although this is not used in the
2692 scalarizer, it is needed when checking bounds and where the end
2693 is an expression with side-effects. */
2696 /* Specified section start. */
2697 gfc_init_se (&se, NULL);
2698 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2699 gfc_add_block_to_block (&loop->pre, &se.pre);
2700 info->end[n] = se.expr;
2704 /* No upper bound specified so use the bound of the array. */
2705 info->end[n] = gfc_conv_array_ubound (desc, dim);
2707 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2709 /* Calculate the stride. */
2711 info->stride[n] = gfc_index_one_node;
2714 gfc_init_se (&se, NULL);
2715 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2716 gfc_add_block_to_block (&loop->pre, &se.pre);
2717 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2722 /* Calculates the range start and stride for a SS chain. Also gets the
2723 descriptor and data pointer. The range of vector subscripts is the size
2724 of the vector. Array bounds are also checked. */
2727 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2735 /* Determine the rank of the loop. */
2737 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2741 case GFC_SS_SECTION:
2742 case GFC_SS_CONSTRUCTOR:
2743 case GFC_SS_FUNCTION:
2744 case GFC_SS_COMPONENT:
2745 loop->dimen = ss->data.info.dimen;
2748 /* As usual, lbound and ubound are exceptions!. */
2749 case GFC_SS_INTRINSIC:
2750 switch (ss->expr->value.function.isym->id)
2752 case GFC_ISYM_LBOUND:
2753 case GFC_ISYM_UBOUND:
2754 loop->dimen = ss->data.info.dimen;
2765 if (loop->dimen == 0)
2766 gfc_todo_error ("Unable to determine rank of expression");
2769 /* Loop over all the SS in the chain. */
2770 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2772 if (ss->expr && ss->expr->shape && !ss->shape)
2773 ss->shape = ss->expr->shape;
2777 case GFC_SS_SECTION:
2778 /* Get the descriptor for the array. */
2779 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2781 for (n = 0; n < ss->data.info.dimen; n++)
2782 gfc_conv_section_startstride (loop, ss, n);
2785 case GFC_SS_INTRINSIC:
2786 switch (ss->expr->value.function.isym->id)
2788 /* Fall through to supply start and stride. */
2789 case GFC_ISYM_LBOUND:
2790 case GFC_ISYM_UBOUND:
2796 case GFC_SS_CONSTRUCTOR:
2797 case GFC_SS_FUNCTION:
2798 for (n = 0; n < ss->data.info.dimen; n++)
2800 ss->data.info.start[n] = gfc_index_zero_node;
2801 ss->data.info.end[n] = gfc_index_zero_node;
2802 ss->data.info.stride[n] = gfc_index_one_node;
2811 /* The rest is just runtime bound checking. */
2812 if (flag_bounds_check)
2815 tree lbound, ubound;
2817 tree size[GFC_MAX_DIMENSIONS];
2818 tree stride_pos, stride_neg, non_zerosized, tmp2;
2823 gfc_start_block (&block);
2825 for (n = 0; n < loop->dimen; n++)
2826 size[n] = NULL_TREE;
2828 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2830 if (ss->type != GFC_SS_SECTION)
2833 /* TODO: range checking for mapped dimensions. */
2834 info = &ss->data.info;
2836 /* This code only checks ranges. Elemental and vector
2837 dimensions are checked later. */
2838 for (n = 0; n < loop->dimen; n++)
2843 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2846 if (n == info->ref->u.ar.dimen - 1
2847 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2848 || info->ref->u.ar.as->cp_was_assumed))
2849 check_upper = false;
2853 /* Zero stride is not allowed. */
2854 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2855 gfc_index_zero_node);
2856 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2857 "of array '%s'", info->dim[n]+1,
2858 ss->expr->symtree->name);
2859 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2862 desc = ss->data.info.descriptor;
2864 /* This is the run-time equivalent of resolve.c's
2865 check_dimension(). The logical is more readable there
2866 than it is here, with all the trees. */
2867 lbound = gfc_conv_array_lbound (desc, dim);
2870 ubound = gfc_conv_array_ubound (desc, dim);
2874 /* non_zerosized is true when the selected range is not
2876 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2877 info->stride[n], gfc_index_zero_node);
2878 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2880 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2883 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2884 info->stride[n], gfc_index_zero_node);
2885 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2887 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2889 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2890 stride_pos, stride_neg);
2892 /* Check the start of the range against the lower and upper
2893 bounds of the array, if the range is not empty. */
2894 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2896 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2897 non_zerosized, tmp);
2898 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2899 " exceeded", gfc_msg_fault, info->dim[n]+1,
2900 ss->expr->symtree->name);
2901 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2906 tmp = fold_build2 (GT_EXPR, boolean_type_node,
2907 info->start[n], ubound);
2908 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2909 non_zerosized, tmp);
2910 asprintf (&msg, "%s, upper bound of dimension %d of array "
2911 "'%s' exceeded", gfc_msg_fault, info->dim[n]+1,
2912 ss->expr->symtree->name);
2913 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2917 /* Compute the last element of the range, which is not
2918 necessarily "end" (think 0:5:3, which doesn't contain 5)
2919 and check it against both lower and upper bounds. */
2920 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2922 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2924 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2927 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2928 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2929 non_zerosized, tmp);
2930 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2931 " exceeded", gfc_msg_fault, info->dim[n]+1,
2932 ss->expr->symtree->name);
2933 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2938 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2939 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2940 non_zerosized, tmp);
2941 asprintf (&msg, "%s, upper bound of dimension %d of array "
2942 "'%s' exceeded", gfc_msg_fault, info->dim[n]+1,
2943 ss->expr->symtree->name);
2944 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2948 /* Check the section sizes match. */
2949 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2951 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2953 /* We remember the size of the first section, and check all the
2954 others against this. */
2958 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2959 asprintf (&msg, "%s, size mismatch for dimension %d "
2960 "of array '%s'", gfc_msg_bounds, info->dim[n]+1,
2961 ss->expr->symtree->name);
2962 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2966 size[n] = gfc_evaluate_now (tmp, &block);
2970 tmp = gfc_finish_block (&block);
2971 gfc_add_expr_to_block (&loop->pre, tmp);
2976 /* Return true if the two SS could be aliased, i.e. both point to the same data
2978 /* TODO: resolve aliases based on frontend expressions. */
2981 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2988 lsym = lss->expr->symtree->n.sym;
2989 rsym = rss->expr->symtree->n.sym;
2990 if (gfc_symbols_could_alias (lsym, rsym))
2993 if (rsym->ts.type != BT_DERIVED
2994 && lsym->ts.type != BT_DERIVED)
2997 /* For derived types we must check all the component types. We can ignore
2998 array references as these will have the same base type as the previous
3000 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3002 if (lref->type != REF_COMPONENT)
3005 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3008 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3011 if (rref->type != REF_COMPONENT)
3014 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3019 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3021 if (rref->type != REF_COMPONENT)
3024 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3032 /* Resolve array data dependencies. Creates a temporary if required. */
3033 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3037 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3047 loop->temp_ss = NULL;
3048 aref = dest->data.info.ref;
3051 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3053 if (ss->type != GFC_SS_SECTION)
3056 if (gfc_could_be_alias (dest, ss)
3057 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3063 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
3065 lref = dest->expr->ref;
3066 rref = ss->expr->ref;
3068 nDepend = gfc_dep_resolver (lref, rref);
3072 /* TODO : loop shifting. */
3075 /* Mark the dimensions for LOOP SHIFTING */
3076 for (n = 0; n < loop->dimen; n++)
3078 int dim = dest->data.info.dim[n];
3080 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3082 else if (! gfc_is_same_range (&lref->u.ar,
3083 &rref->u.ar, dim, 0))
3087 /* Put all the dimensions with dependencies in the
3090 for (n = 0; n < loop->dimen; n++)
3092 gcc_assert (loop->order[n] == n);
3094 loop->order[dim++] = n;
3097 for (n = 0; n < loop->dimen; n++)
3100 loop->order[dim++] = n;
3103 gcc_assert (dim == loop->dimen);
3112 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3113 if (GFC_ARRAY_TYPE_P (base_type)
3114 || GFC_DESCRIPTOR_TYPE_P (base_type))
3115 base_type = gfc_get_element_type (base_type);
3116 loop->temp_ss = gfc_get_ss ();
3117 loop->temp_ss->type = GFC_SS_TEMP;
3118 loop->temp_ss->data.temp.type = base_type;
3119 loop->temp_ss->string_length = dest->string_length;
3120 loop->temp_ss->data.temp.dimen = loop->dimen;
3121 loop->temp_ss->next = gfc_ss_terminator;
3122 gfc_add_ss_to_loop (loop, loop->temp_ss);
3125 loop->temp_ss = NULL;
3129 /* Initialize the scalarization loop. Creates the loop variables. Determines
3130 the range of the loop variables. Creates a temporary if required.
3131 Calculates how to transform from loop variables to array indices for each
3132 expression. Also generates code for scalar expressions which have been
3133 moved outside the loop. */
3136 gfc_conv_loop_setup (gfc_loopinfo * loop)
3141 gfc_ss_info *specinfo;
3145 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3146 bool dynamic[GFC_MAX_DIMENSIONS];
3152 for (n = 0; n < loop->dimen; n++)
3156 /* We use one SS term, and use that to determine the bounds of the
3157 loop for this dimension. We try to pick the simplest term. */
3158 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3162 /* The frontend has worked out the size for us. */
3167 if (ss->type == GFC_SS_CONSTRUCTOR)
3169 /* An unknown size constructor will always be rank one.
3170 Higher rank constructors will either have known shape,
3171 or still be wrapped in a call to reshape. */
3172 gcc_assert (loop->dimen == 1);
3174 /* Always prefer to use the constructor bounds if the size
3175 can be determined at compile time. Prefer not to otherwise,
3176 since the general case involves realloc, and it's better to
3177 avoid that overhead if possible. */
3178 c = ss->expr->value.constructor;
3179 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3180 if (!dynamic[n] || !loopspec[n])
3185 /* TODO: Pick the best bound if we have a choice between a
3186 function and something else. */
3187 if (ss->type == GFC_SS_FUNCTION)
3193 if (ss->type != GFC_SS_SECTION)
3197 specinfo = &loopspec[n]->data.info;
3200 info = &ss->data.info;
3204 /* Criteria for choosing a loop specifier (most important first):
3205 doesn't need realloc
3211 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3213 else if (integer_onep (info->stride[n])
3214 && !integer_onep (specinfo->stride[n]))
3216 else if (INTEGER_CST_P (info->stride[n])
3217 && !INTEGER_CST_P (specinfo->stride[n]))
3219 else if (INTEGER_CST_P (info->start[n])
3220 && !INTEGER_CST_P (specinfo->start[n]))
3222 /* We don't work out the upper bound.
3223 else if (INTEGER_CST_P (info->finish[n])
3224 && ! INTEGER_CST_P (specinfo->finish[n]))
3225 loopspec[n] = ss; */
3229 gfc_todo_error ("Unable to find scalarization loop specifier");
3231 info = &loopspec[n]->data.info;
3233 /* Set the extents of this range. */
3234 cshape = loopspec[n]->shape;
3235 if (cshape && INTEGER_CST_P (info->start[n])
3236 && INTEGER_CST_P (info->stride[n]))
3238 loop->from[n] = info->start[n];
3239 mpz_set (i, cshape[n]);
3240 mpz_sub_ui (i, i, 1);
3241 /* To = from + (size - 1) * stride. */
3242 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3243 if (!integer_onep (info->stride[n]))
3244 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3245 tmp, info->stride[n]);
3246 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3247 loop->from[n], tmp);
3251 loop->from[n] = info->start[n];
3252 switch (loopspec[n]->type)
3254 case GFC_SS_CONSTRUCTOR:
3255 /* The upper bound is calculated when we expand the
3257 gcc_assert (loop->to[n] == NULL_TREE);
3260 case GFC_SS_SECTION:
3261 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3265 case GFC_SS_FUNCTION:
3266 /* The loop bound will be set when we generate the call. */
3267 gcc_assert (loop->to[n] == NULL_TREE);
3275 /* Transform everything so we have a simple incrementing variable. */
3276 if (integer_onep (info->stride[n]))
3277 info->delta[n] = gfc_index_zero_node;
3280 /* Set the delta for this section. */
3281 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3282 /* Number of iterations is (end - start + step) / step.
3283 with start = 0, this simplifies to
3285 for (i = 0; i<=last; i++){...}; */
3286 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3287 loop->to[n], loop->from[n]);
3288 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3289 tmp, info->stride[n]);
3290 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3291 /* Make the loop variable start at 0. */
3292 loop->from[n] = gfc_index_zero_node;
3296 /* Add all the scalar code that can be taken out of the loops.
3297 This may include calculating the loop bounds, so do it before
3298 allocating the temporary. */
3299 gfc_add_loop_ss_code (loop, loop->ss, false);
3301 /* If we want a temporary then create it. */
3302 if (loop->temp_ss != NULL)
3304 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3305 tmp = loop->temp_ss->data.temp.type;
3306 len = loop->temp_ss->string_length;
3307 n = loop->temp_ss->data.temp.dimen;
3308 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3309 loop->temp_ss->type = GFC_SS_SECTION;
3310 loop->temp_ss->data.info.dimen = n;
3311 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3312 &loop->temp_ss->data.info, tmp, false, true,
3316 for (n = 0; n < loop->temp_dim; n++)
3317 loopspec[loop->order[n]] = NULL;
3321 /* For array parameters we don't have loop variables, so don't calculate the
3323 if (loop->array_parameter)
3326 /* Calculate the translation from loop variables to array indices. */
3327 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3329 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3332 info = &ss->data.info;
3334 for (n = 0; n < info->dimen; n++)
3338 /* If we are specifying the range the delta is already set. */
3339 if (loopspec[n] != ss)
3341 /* Calculate the offset relative to the loop variable.
3342 First multiply by the stride. */
3343 tmp = loop->from[n];
3344 if (!integer_onep (info->stride[n]))
3345 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3346 tmp, info->stride[n]);
3348 /* Then subtract this from our starting value. */
3349 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3350 info->start[n], tmp);
3352 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3359 /* Fills in an array descriptor, and returns the size of the array. The size
3360 will be a simple_val, ie a variable or a constant. Also calculates the
3361 offset of the base. Returns the size of the array.
3365 for (n = 0; n < rank; n++)
3367 a.lbound[n] = specified_lower_bound;
3368 offset = offset + a.lbond[n] * stride;
3370 a.ubound[n] = specified_upper_bound;
3371 a.stride[n] = stride;
3372 size = ubound + size; //size = ubound + 1 - lbound
3373 stride = stride * size;
3380 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3381 gfc_expr ** lower, gfc_expr ** upper,
3382 stmtblock_t * pblock)
3394 stmtblock_t thenblock;
3395 stmtblock_t elseblock;
3400 type = TREE_TYPE (descriptor);
3402 stride = gfc_index_one_node;
3403 offset = gfc_index_zero_node;
3405 /* Set the dtype. */
3406 tmp = gfc_conv_descriptor_dtype (descriptor);
3407 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3409 or_expr = NULL_TREE;
3411 for (n = 0; n < rank; n++)
3413 /* We have 3 possibilities for determining the size of the array:
3414 lower == NULL => lbound = 1, ubound = upper[n]
3415 upper[n] = NULL => lbound = 1, ubound = lower[n]
3416 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3419 /* Set lower bound. */
3420 gfc_init_se (&se, NULL);
3422 se.expr = gfc_index_one_node;
3425 gcc_assert (lower[n]);
3428 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3429 gfc_add_block_to_block (pblock, &se.pre);
3433 se.expr = gfc_index_one_node;
3437 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3438 gfc_add_modify_expr (pblock, tmp, se.expr);
3440 /* Work out the offset for this component. */
3441 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3442 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3444 /* Start the calculation for the size of this dimension. */
3445 size = build2 (MINUS_EXPR, gfc_array_index_type,
3446 gfc_index_one_node, se.expr);
3448 /* Set upper bound. */
3449 gfc_init_se (&se, NULL);
3450 gcc_assert (ubound);
3451 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3452 gfc_add_block_to_block (pblock, &se.pre);
3454 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3455 gfc_add_modify_expr (pblock, tmp, se.expr);
3457 /* Store the stride. */
3458 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3459 gfc_add_modify_expr (pblock, tmp, stride);
3461 /* Calculate the size of this dimension. */
3462 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3464 /* Check whether the size for this dimension is negative. */
3465 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3466 gfc_index_zero_node);
3470 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3472 /* Multiply the stride by the number of elements in this dimension. */
3473 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3474 stride = gfc_evaluate_now (stride, pblock);
3477 /* The stride is the number of elements in the array, so multiply by the
3478 size of an element to get the total size. */
3479 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3480 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3481 fold_convert (gfc_array_index_type, tmp));
3483 if (poffset != NULL)
3485 offset = gfc_evaluate_now (offset, pblock);
3489 if (integer_zerop (or_expr))
3491 if (integer_onep (or_expr))
3492 return gfc_index_zero_node;
3494 var = gfc_create_var (TREE_TYPE (size), "size");
3495 gfc_start_block (&thenblock);
3496 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3497 thencase = gfc_finish_block (&thenblock);
3499 gfc_start_block (&elseblock);
3500 gfc_add_modify_expr (&elseblock, var, size);
3501 elsecase = gfc_finish_block (&elseblock);
3503 tmp = gfc_evaluate_now (or_expr, pblock);
3504 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3505 gfc_add_expr_to_block (pblock, tmp);
3511 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3512 the work for an ALLOCATE statement. */
3516 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3525 gfc_ref *ref, *prev_ref = NULL;
3526 bool allocatable_array;
3530 /* Find the last reference in the chain. */
3531 while (ref && ref->next != NULL)
3533 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3538 if (ref == NULL || ref->type != REF_ARRAY)
3542 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3544 allocatable_array = prev_ref->u.c.component->allocatable;
3546 /* Figure out the size of the array. */
3547 switch (ref->u.ar.type)
3551 upper = ref->u.ar.start;
3555 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3557 lower = ref->u.ar.as->lower;
3558 upper = ref->u.ar.as->upper;
3562 lower = ref->u.ar.start;
3563 upper = ref->u.ar.end;
3571 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3572 lower, upper, &se->pre);
3574 /* Allocate memory to store the data. */
3575 pointer = gfc_conv_descriptor_data_get (se->expr);
3576 STRIP_NOPS (pointer);
3578 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3580 if (allocatable_array)
3581 allocate = gfor_fndecl_allocate_array;
3583 allocate = gfor_fndecl_allocate;
3585 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3587 if (allocatable_array)
3588 allocate = gfor_fndecl_allocate64_array;
3590 allocate = gfor_fndecl_allocate64;
3595 /* The allocate_array variants take the old pointer as first argument. */
3596 if (allocatable_array)
3597 tmp = build_call_expr (allocate, 3, pointer, size, pstat);
3599 tmp = build_call_expr (allocate, 2, size, pstat);
3600 tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3601 gfc_add_expr_to_block (&se->pre, tmp);
3603 tmp = gfc_conv_descriptor_offset (se->expr);
3604 gfc_add_modify_expr (&se->pre, tmp, offset);
3606 if (expr->ts.type == BT_DERIVED
3607 && expr->ts.derived->attr.alloc_comp)
3609 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3610 ref->u.ar.as->rank);
3611 gfc_add_expr_to_block (&se->pre, tmp);
3618 /* Deallocate an array variable. Also used when an allocated variable goes
3623 gfc_array_deallocate (tree descriptor, tree pstat)
3629 gfc_start_block (&block);
3630 /* Get a pointer to the data. */
3631 var = gfc_conv_descriptor_data_get (descriptor);
3634 /* Parameter is the address of the data component. */
3635 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
3636 gfc_add_expr_to_block (&block, tmp);
3638 /* Zero the data pointer. */
3639 tmp = build2 (MODIFY_EXPR, void_type_node,
3640 var, build_int_cst (TREE_TYPE (var), 0));
3641 gfc_add_expr_to_block (&block, tmp);
3643 return gfc_finish_block (&block);
3647 /* Create an array constructor from an initialization expression.
3648 We assume the frontend already did any expansions and conversions. */
3651 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3658 unsigned HOST_WIDE_INT lo;
3660 VEC(constructor_elt,gc) *v = NULL;
3662 switch (expr->expr_type)
3665 case EXPR_STRUCTURE:
3666 /* A single scalar or derived type value. Create an array with all
3667 elements equal to that value. */
3668 gfc_init_se (&se, NULL);
3670 if (expr->expr_type == EXPR_CONSTANT)
3671 gfc_conv_constant (&se, expr);
3673 gfc_conv_structure (&se, expr, 1);
3675 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3676 gcc_assert (tmp && INTEGER_CST_P (tmp));
3677 hi = TREE_INT_CST_HIGH (tmp);
3678 lo = TREE_INT_CST_LOW (tmp);
3682 /* This will probably eat buckets of memory for large arrays. */
3683 while (hi != 0 || lo != 0)
3685 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3693 /* Create a vector of all the elements. */
3694 for (c = expr->value.constructor; c; c = c->next)
3698 /* Problems occur when we get something like
3699 integer :: a(lots) = (/(i, i=1,lots)/) */
3700 /* TODO: Unexpanded array initializers. */
3702 ("Possible frontend bug: array constructor not expanded");
3704 if (mpz_cmp_si (c->n.offset, 0) != 0)
3705 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3709 if (mpz_cmp_si (c->repeat, 0) != 0)
3713 mpz_set (maxval, c->repeat);
3714 mpz_add (maxval, c->n.offset, maxval);
3715 mpz_sub_ui (maxval, maxval, 1);
3716 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3717 if (mpz_cmp_si (c->n.offset, 0) != 0)
3719 mpz_add_ui (maxval, c->n.offset, 1);
3720 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3723 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3725 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3731 gfc_init_se (&se, NULL);
3732 switch (c->expr->expr_type)
3735 gfc_conv_constant (&se, c->expr);
3736 if (range == NULL_TREE)
3737 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3740 if (index != NULL_TREE)
3741 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3742 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3746 case EXPR_STRUCTURE:
3747 gfc_conv_structure (&se, c->expr, 1);
3748 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3758 return gfc_build_null_descriptor (type);
3764 /* Create a constructor from the list of elements. */
3765 tmp = build_constructor (type, v);
3766 TREE_CONSTANT (tmp) = 1;
3767 TREE_INVARIANT (tmp) = 1;
3772 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3773 returns the size (in elements) of the array. */
3776 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3777 stmtblock_t * pblock)
3792 size = gfc_index_one_node;
3793 offset = gfc_index_zero_node;
3794 for (dim = 0; dim < as->rank; dim++)
3796 /* Evaluate non-constant array bound expressions. */
3797 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3798 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3800 gfc_init_se (&se, NULL);
3801 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3802 gfc_add_block_to_block (pblock, &se.pre);
3803 gfc_add_modify_expr (pblock, lbound, se.expr);
3805 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3806 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3808 gfc_init_se (&se, NULL);
3809 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3810 gfc_add_block_to_block (pblock, &se.pre);
3811 gfc_add_modify_expr (pblock, ubound, se.expr);
3813 /* The offset of this dimension. offset = offset - lbound * stride. */
3814 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3815 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3817 /* The size of this dimension, and the stride of the next. */
3818 if (dim + 1 < as->rank)
3819 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3821 stride = GFC_TYPE_ARRAY_SIZE (type);
3823 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3825 /* Calculate stride = size * (ubound + 1 - lbound). */
3826 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3827 gfc_index_one_node, lbound);
3828 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3829 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3831 gfc_add_modify_expr (pblock, stride, tmp);
3833 stride = gfc_evaluate_now (tmp, pblock);
3835 /* Make sure that negative size arrays are translated
3836 to being zero size. */
3837 tmp = build2 (GE_EXPR, boolean_type_node,
3838 stride, gfc_index_zero_node);
3839 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3840 stride, gfc_index_zero_node);
3841 gfc_add_modify_expr (pblock, stride, tmp);
3847 gfc_trans_vla_type_sizes (sym, pblock);
3854 /* Generate code to initialize/allocate an array variable. */
3857 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3866 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3868 /* Do nothing for USEd variables. */
3869 if (sym->attr.use_assoc)
3872 type = TREE_TYPE (decl);
3873 gcc_assert (GFC_ARRAY_TYPE_P (type));
3874 onstack = TREE_CODE (type) != POINTER_TYPE;
3876 gfc_start_block (&block);
3878 /* Evaluate character string length. */
3879 if (sym->ts.type == BT_CHARACTER
3880 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3882 gfc_trans_init_string_length (sym->ts.cl, &block);
3884 gfc_trans_vla_type_sizes (sym, &block);
3886 /* Emit a DECL_EXPR for this variable, which will cause the
3887 gimplifier to allocate storage, and all that good stuff. */
3888 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3889 gfc_add_expr_to_block (&block, tmp);
3894 gfc_add_expr_to_block (&block, fnbody);
3895 return gfc_finish_block (&block);
3898 type = TREE_TYPE (type);
3900 gcc_assert (!sym->attr.use_assoc);
3901 gcc_assert (!TREE_STATIC (decl));
3902 gcc_assert (!sym->module);
3904 if (sym->ts.type == BT_CHARACTER
3905 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3906 gfc_trans_init_string_length (sym->ts.cl, &block);
3908 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3910 /* Don't actually allocate space for Cray Pointees. */
3911 if (sym->attr.cray_pointee)
3913 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3914 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3915 gfc_add_expr_to_block (&block, fnbody);
3916 return gfc_finish_block (&block);
3919 /* The size is the number of elements in the array, so multiply by the
3920 size of an element to get the total size. */
3921 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3922 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
3923 fold_convert (gfc_array_index_type, tmp));
3925 /* Allocate memory to hold the data. */
3926 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
3927 gfc_add_modify_expr (&block, decl, tmp);
3929 /* Set offset of the array. */
3930 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3931 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3934 /* Automatic arrays should not have initializers. */
3935 gcc_assert (!sym->value);
3937 gfc_add_expr_to_block (&block, fnbody);
3939 /* Free the temporary. */
3940 tmp = gfc_call_free (convert (pvoid_type_node, decl));
3941 gfc_add_expr_to_block (&block, tmp);
3943 return gfc_finish_block (&block);
3947 /* Generate entry and exit code for g77 calling convention arrays. */
3950 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3960 gfc_get_backend_locus (&loc);
3961 gfc_set_backend_locus (&sym->declared_at);
3963 /* Descriptor type. */
3964 parm = sym->backend_decl;
3965 type = TREE_TYPE (parm);
3966 gcc_assert (GFC_ARRAY_TYPE_P (type));
3968 gfc_start_block (&block);
3970 if (sym->ts.type == BT_CHARACTER
3971 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3972 gfc_trans_init_string_length (sym->ts.cl, &block);
3974 /* Evaluate the bounds of the array. */
3975 gfc_trans_array_bounds (type, sym, &offset, &block);
3977 /* Set the offset. */
3978 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3979 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3981 /* Set the pointer itself if we aren't using the parameter directly. */
3982 if (TREE_CODE (parm) != PARM_DECL)
3984 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3985 gfc_add_modify_expr (&block, parm, tmp);
3987 stmt = gfc_finish_block (&block);
3989 gfc_set_backend_locus (&loc);
3991 gfc_start_block (&block);
3993 /* Add the initialization code to the start of the function. */
3995 if (sym->attr.optional || sym->attr.not_always_present)
3997 tmp = gfc_conv_expr_present (sym);
3998 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4001 gfc_add_expr_to_block (&block, stmt);
4002 gfc_add_expr_to_block (&block, body);
4004 return gfc_finish_block (&block);
4008 /* Modify the descriptor of an array parameter so that it has the
4009 correct lower bound. Also move the upper bound accordingly.
4010 If the array is not packed, it will be copied into a temporary.
4011 For each dimension we set the new lower and upper bounds. Then we copy the
4012 stride and calculate the offset for this dimension. We also work out
4013 what the stride of a packed array would be, and see it the two match.
4014 If the array need repacking, we set the stride to the values we just
4015 calculated, recalculate the offset and copy the array data.
4016 Code is also added to copy the data back at the end of the function.
4020 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4027 stmtblock_t cleanup;
4035 tree stride, stride2;
4045 /* Do nothing for pointer and allocatable arrays. */
4046 if (sym->attr.pointer || sym->attr.allocatable)
4049 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4050 return gfc_trans_g77_array (sym, body);
4052 gfc_get_backend_locus (&loc);
4053 gfc_set_backend_locus (&sym->declared_at);
4055 /* Descriptor type. */
4056 type = TREE_TYPE (tmpdesc);
4057 gcc_assert (GFC_ARRAY_TYPE_P (type));
4058 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4059 dumdesc = build_fold_indirect_ref (dumdesc);
4060 gfc_start_block (&block);
4062 if (sym->ts.type == BT_CHARACTER
4063 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4064 gfc_trans_init_string_length (sym->ts.cl, &block);
4066 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4068 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4069 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4071 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4073 /* For non-constant shape arrays we only check if the first dimension
4074 is contiguous. Repacking higher dimensions wouldn't gain us
4075 anything as we still don't know the array stride. */
4076 partial = gfc_create_var (boolean_type_node, "partial");
4077 TREE_USED (partial) = 1;
4078 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4079 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4080 gfc_add_modify_expr (&block, partial, tmp);
4084 partial = NULL_TREE;
4087 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4088 here, however I think it does the right thing. */
4091 /* Set the first stride. */
4092 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4093 stride = gfc_evaluate_now (stride, &block);
4095 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
4096 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4097 gfc_index_one_node, stride);
4098 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4099 gfc_add_modify_expr (&block, stride, tmp);
4101 /* Allow the user to disable array repacking. */
4102 stmt_unpacked = NULL_TREE;
4106 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4107 /* A library call to repack the array if necessary. */
4108 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4109 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4111 stride = gfc_index_one_node;
4114 /* This is for the case where the array data is used directly without
4115 calling the repack function. */
4116 if (no_repack || partial != NULL_TREE)
4117 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4119 stmt_packed = NULL_TREE;
4121 /* Assign the data pointer. */
4122 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4124 /* Don't repack unknown shape arrays when the first stride is 1. */
4125 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
4126 stmt_packed, stmt_unpacked);
4129 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4130 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
4132 offset = gfc_index_zero_node;
4133 size = gfc_index_one_node;
4135 /* Evaluate the bounds of the array. */
4136 for (n = 0; n < sym->as->rank; n++)
4138 if (checkparm || !sym->as->upper[n])
4140 /* Get the bounds of the actual parameter. */
4141 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4142 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4146 dubound = NULL_TREE;
4147 dlbound = NULL_TREE;
4150 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4151 if (!INTEGER_CST_P (lbound))
4153 gfc_init_se (&se, NULL);
4154 gfc_conv_expr_type (&se, sym->as->lower[n],
4155 gfc_array_index_type);
4156 gfc_add_block_to_block (&block, &se.pre);
4157 gfc_add_modify_expr (&block, lbound, se.expr);
4160 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4161 /* Set the desired upper bound. */
4162 if (sym->as->upper[n])
4164 /* We know what we want the upper bound to be. */
4165 if (!INTEGER_CST_P (ubound))
4167 gfc_init_se (&se, NULL);
4168 gfc_conv_expr_type (&se, sym->as->upper[n],
4169 gfc_array_index_type);
4170 gfc_add_block_to_block (&block, &se.pre);
4171 gfc_add_modify_expr (&block, ubound, se.expr);
4174 /* Check the sizes match. */
4177 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4180 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4182 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
4184 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4185 asprintf (&msg, "%s for dimension %d of array '%s'",
4186 gfc_msg_bounds, n+1, sym->name);
4187 gfc_trans_runtime_check (tmp, msg, &block, &loc);
4193 /* For assumed shape arrays move the upper bound by the same amount
4194 as the lower bound. */
4195 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
4196 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4197 gfc_add_modify_expr (&block, ubound, tmp);
4199 /* The offset of this dimension. offset = offset - lbound * stride. */
4200 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4201 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4203 /* The size of this dimension, and the stride of the next. */
4204 if (n + 1 < sym->as->rank)
4206 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4208 if (no_repack || partial != NULL_TREE)
4211 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4214 /* Figure out the stride if not a known constant. */
4215 if (!INTEGER_CST_P (stride))
4218 stmt_packed = NULL_TREE;
4221 /* Calculate stride = size * (ubound + 1 - lbound). */
4222 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4223 gfc_index_one_node, lbound);
4224 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4226 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4231 /* Assign the stride. */
4232 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4233 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
4234 stmt_unpacked, stmt_packed);
4236 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4237 gfc_add_modify_expr (&block, stride, tmp);
4242 stride = GFC_TYPE_ARRAY_SIZE (type);
4244 if (stride && !INTEGER_CST_P (stride))
4246 /* Calculate size = stride * (ubound + 1 - lbound). */
4247 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4248 gfc_index_one_node, lbound);
4249 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4251 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4252 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4253 gfc_add_modify_expr (&block, stride, tmp);
4258 /* Set the offset. */
4259 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4260 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4262 gfc_trans_vla_type_sizes (sym, &block);
4264 stmt = gfc_finish_block (&block);
4266 gfc_start_block (&block);
4268 /* Only do the entry/initialization code if the arg is present. */
4269 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4270 optional_arg = (sym->attr.optional
4271 || (sym->ns->proc_name->attr.entry_master
4272 && sym->attr.dummy));
4275 tmp = gfc_conv_expr_present (sym);
4276 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4278 gfc_add_expr_to_block (&block, stmt);
4280 /* Add the main function body. */
4281 gfc_add_expr_to_block (&block, body);
4286 gfc_start_block (&cleanup);
4288 if (sym->attr.intent != INTENT_IN)
4290 /* Copy the data back. */
4291 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4292 gfc_add_expr_to_block (&cleanup, tmp);
4295 /* Free the temporary. */
4296 tmp = gfc_call_free (tmpdesc);
4297 gfc_add_expr_to_block (&cleanup, tmp);
4299 stmt = gfc_finish_block (&cleanup);
4301 /* Only do the cleanup if the array was repacked. */
4302 tmp = build_fold_indirect_ref (dumdesc);
4303 tmp = gfc_conv_descriptor_data_get (tmp);
4304 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4305 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4309 tmp = gfc_conv_expr_present (sym);
4310 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4312 gfc_add_expr_to_block (&block, stmt);
4314 /* We don't need to free any memory allocated by internal_pack as it will
4315 be freed at the end of the function by pop_context. */
4316 return gfc_finish_block (&block);
4320 /* Convert an array for passing as an actual argument. Expressions and
4321 vector subscripts are evaluated and stored in a temporary, which is then
4322 passed. For whole arrays the descriptor is passed. For array sections
4323 a modified copy of the descriptor is passed, but using the original data.
4325 This function is also used for array pointer assignments, and there
4328 - se->want_pointer && !se->direct_byref
4329 EXPR is an actual argument. On exit, se->expr contains a
4330 pointer to the array descriptor.
4332 - !se->want_pointer && !se->direct_byref
4333 EXPR is an actual argument to an intrinsic function or the
4334 left-hand side of a pointer assignment. On exit, se->expr
4335 contains the descriptor for EXPR.
4337 - !se->want_pointer && se->direct_byref
4338 EXPR is the right-hand side of a pointer assignment and
4339 se->expr is the descriptor for the previously-evaluated
4340 left-hand side. The function creates an assignment from
4341 EXPR to se->expr. */
4344 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4358 gcc_assert (ss != gfc_ss_terminator);
4360 /* Special case things we know we can pass easily. */
4361 switch (expr->expr_type)
4364 /* If we have a linear array section, we can pass it directly.
4365 Otherwise we need to copy it into a temporary. */
4367 /* Find the SS for the array section. */
4369 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4370 secss = secss->next;
4372 gcc_assert (secss != gfc_ss_terminator);
4373 info = &secss->data.info;
4375 /* Get the descriptor for the array. */
4376 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4377 desc = info->descriptor;
4379 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4382 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4384 /* Create a new descriptor if the array doesn't have one. */
4387 else if (info->ref->u.ar.type == AR_FULL)
4389 else if (se->direct_byref)
4392 full = gfc_full_array_ref_p (info->ref);
4396 if (se->direct_byref)
4398 /* Copy the descriptor for pointer assignments. */
4399 gfc_add_modify_expr (&se->pre, se->expr, desc);
4401 else if (se->want_pointer)
4403 /* We pass full arrays directly. This means that pointers and
4404 allocatable arrays should also work. */
4405 se->expr = build_fold_addr_expr (desc);
4412 if (expr->ts.type == BT_CHARACTER)
4413 se->string_length = gfc_get_expr_charlen (expr);
4420 /* A transformational function return value will be a temporary
4421 array descriptor. We still need to go through the scalarizer
4422 to create the descriptor. Elemental functions ar handled as
4423 arbitrary expressions, i.e. copy to a temporary. */
4425 /* Look for the SS for this function. */
4426 while (secss != gfc_ss_terminator
4427 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4428 secss = secss->next;
4430 if (se->direct_byref)
4432 gcc_assert (secss != gfc_ss_terminator);
4434 /* For pointer assignments pass the descriptor directly. */
4436 se->expr = build_fold_addr_expr (se->expr);
4437 gfc_conv_expr (se, expr);
4441 if (secss == gfc_ss_terminator)
4443 /* Elemental function. */
4449 /* Transformational function. */
4450 info = &secss->data.info;
4456 /* Constant array constructors don't need a temporary. */
4457 if (ss->type == GFC_SS_CONSTRUCTOR
4458 && expr->ts.type != BT_CHARACTER
4459 && gfc_constant_array_constructor_p (expr->value.constructor))
4462 info = &ss->data.info;
4474 /* Something complicated. Copy it into a temporary. */
4482 gfc_init_loopinfo (&loop);
4484 /* Associate the SS with the loop. */
4485 gfc_add_ss_to_loop (&loop, ss);
4487 /* Tell the scalarizer not to bother creating loop variables, etc. */
4489 loop.array_parameter = 1;
4491 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4492 gcc_assert (!se->direct_byref);
4494 /* Setup the scalarizing loops and bounds. */
4495 gfc_conv_ss_startstride (&loop);
4499 /* Tell the scalarizer to make a temporary. */
4500 loop.temp_ss = gfc_get_ss ();
4501 loop.temp_ss->type = GFC_SS_TEMP;
4502 loop.temp_ss->next = gfc_ss_terminator;
4503 if (expr->ts.type == BT_CHARACTER)
4505 if (expr->ts.cl == NULL)
4507 /* This had better be a substring reference! */
4508 gfc_ref *char_ref = expr->ref;
4509 for (; char_ref; char_ref = char_ref->next)
4510 if (char_ref->type == REF_SUBSTRING)
4513 expr->ts.cl = gfc_get_charlen ();
4514 expr->ts.cl->next = char_ref->u.ss.length->next;
4515 char_ref->u.ss.length->next = expr->ts.cl;
4517 mpz_init_set_ui (char_len, 1);
4518 mpz_add (char_len, char_len,
4519 char_ref->u.ss.end->value.integer);
4520 mpz_sub (char_len, char_len,
4521 char_ref->u.ss.start->value.integer);
4522 expr->ts.cl->backend_decl
4523 = gfc_conv_mpz_to_tree (char_len,
4524 gfc_default_character_kind);
4525 /* Cast is necessary for *-charlen refs. */
4526 expr->ts.cl->backend_decl
4527 = convert (gfc_charlen_type_node,
4528 expr->ts.cl->backend_decl);
4529 mpz_clear (char_len);
4532 gcc_assert (char_ref != NULL);
4533 loop.temp_ss->data.temp.type
4534 = gfc_typenode_for_spec (&expr->ts);
4535 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4537 else if (expr->ts.cl->length
4538 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4540 expr->ts.cl->backend_decl
4541 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4542 expr->ts.cl->length->ts.kind);
4543 loop.temp_ss->data.temp.type
4544 = gfc_typenode_for_spec (&expr->ts);
4545 loop.temp_ss->string_length
4546 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4550 loop.temp_ss->data.temp.type
4551 = gfc_typenode_for_spec (&expr->ts);
4552 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4554 se->string_length = loop.temp_ss->string_length;
4558 loop.temp_ss->data.temp.type
4559 = gfc_typenode_for_spec (&expr->ts);
4560 loop.temp_ss->string_length = NULL;
4562 loop.temp_ss->data.temp.dimen = loop.dimen;
4563 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4566 gfc_conv_loop_setup (&loop);
4570 /* Copy into a temporary and pass that. We don't need to copy the data
4571 back because expressions and vector subscripts must be INTENT_IN. */
4572 /* TODO: Optimize passing function return values. */
4576 /* Start the copying loops. */
4577 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4578 gfc_mark_ss_chain_used (ss, 1);
4579 gfc_start_scalarized_body (&loop, &block);
4581 /* Copy each data element. */
4582 gfc_init_se (&lse, NULL);
4583 gfc_copy_loopinfo_to_se (&lse, &loop);
4584 gfc_init_se (&rse, NULL);
4585 gfc_copy_loopinfo_to_se (&rse, &loop);
4587 lse.ss = loop.temp_ss;
4590 gfc_conv_scalarized_array_ref (&lse, NULL);
4591 if (expr->ts.type == BT_CHARACTER)
4593 gfc_conv_expr (&rse, expr);
4594 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4595 rse.expr = build_fold_indirect_ref (rse.expr);
4598 gfc_conv_expr_val (&rse, expr);
4600 gfc_add_block_to_block (&block, &rse.pre);
4601 gfc_add_block_to_block (&block, &lse.pre);
4603 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4605 /* Finish the copying loops. */
4606 gfc_trans_scalarizing_loops (&loop, &block);
4608 desc = loop.temp_ss->data.info.descriptor;
4610 gcc_assert (is_gimple_lvalue (desc));
4612 else if (expr->expr_type == EXPR_FUNCTION)
4614 desc = info->descriptor;
4615 se->string_length = ss->string_length;
4619 /* We pass sections without copying to a temporary. Make a new
4620 descriptor and point it at the section we want. The loop variable
4621 limits will be the limits of the section.
4622 A function may decide to repack the array to speed up access, but
4623 we're not bothered about that here. */
4632 /* Set the string_length for a character array. */
4633 if (expr->ts.type == BT_CHARACTER)
4634 se->string_length = gfc_get_expr_charlen (expr);
4636 desc = info->descriptor;
4637 gcc_assert (secss && secss != gfc_ss_terminator);
4638 if (se->direct_byref)
4640 /* For pointer assignments we fill in the destination. */
4642 parmtype = TREE_TYPE (parm);
4646 /* Otherwise make a new one. */
4647 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4648 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4649 loop.from, loop.to, 0);
4650 parm = gfc_create_var (parmtype, "parm");
4653 offset = gfc_index_zero_node;
4656 /* The following can be somewhat confusing. We have two
4657 descriptors, a new one and the original array.
4658 {parm, parmtype, dim} refer to the new one.
4659 {desc, type, n, secss, loop} refer to the original, which maybe
4660 a descriptorless array.
4661 The bounds of the scalarization are the bounds of the section.
4662 We don't have to worry about numeric overflows when calculating
4663 the offsets because all elements are within the array data. */
4665 /* Set the dtype. */
4666 tmp = gfc_conv_descriptor_dtype (parm);
4667 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4669 if (se->direct_byref)
4670 base = gfc_index_zero_node;
4671 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4672 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
4676 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
4677 for (n = 0; n < ndim; n++)
4679 stride = gfc_conv_array_stride (desc, n);
4681 /* Work out the offset. */
4683 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4685 gcc_assert (info->subscript[n]
4686 && info->subscript[n]->type == GFC_SS_SCALAR);
4687 start = info->subscript[n]->data.scalar.expr;
4691 /* Check we haven't somehow got out of sync. */
4692 gcc_assert (info->dim[dim] == n);
4694 /* Evaluate and remember the start of the section. */
4695 start = info->start[dim];
4696 stride = gfc_evaluate_now (stride, &loop.pre);
4699 tmp = gfc_conv_array_lbound (desc, n);
4700 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4702 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4703 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4706 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4708 /* For elemental dimensions, we only need the offset. */
4712 /* Vector subscripts need copying and are handled elsewhere. */
4714 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4716 /* Set the new lower bound. */
4717 from = loop.from[dim];
4720 /* If we have an array section or are assigning to a pointer,
4721 make sure that the lower bound is 1. References to the full
4722 array should otherwise keep the original bounds. */
4724 || info->ref->u.ar.type != AR_FULL
4725 || se->direct_byref)
4726 && !integer_onep (from))
4728 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4729 gfc_index_one_node, from);
4730 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4731 from = gfc_index_one_node;
4733 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4734 gfc_add_modify_expr (&loop.pre, tmp, from);
4736 /* Set the new upper bound. */
4737 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4738 gfc_add_modify_expr (&loop.pre, tmp, to);
4740 /* Multiply the stride by the section stride to get the
4742 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4743 stride, info->stride[dim]);
4745 if (se->direct_byref)
4747 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4750 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4752 tmp = gfc_conv_array_lbound (desc, n);
4753 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4754 tmp, loop.from[dim]);
4755 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
4756 tmp, gfc_conv_array_stride (desc, n));
4757 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
4761 /* Store the new stride. */
4762 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4763 gfc_add_modify_expr (&loop.pre, tmp, stride);
4768 if (se->data_not_needed)
4769 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4772 /* Point the data pointer at the first element in the section. */
4773 tmp = gfc_conv_array_data (desc);
4774 tmp = build_fold_indirect_ref (tmp);
4775 tmp = gfc_build_array_ref (tmp, offset);
4776 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4777 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4780 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4781 && !se->data_not_needed)
4783 /* Set the offset. */
4784 tmp = gfc_conv_descriptor_offset (parm);
4785 gfc_add_modify_expr (&loop.pre, tmp, base);
4789 /* Only the callee knows what the correct offset it, so just set
4791 tmp = gfc_conv_descriptor_offset (parm);
4792 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4797 if (!se->direct_byref)
4799 /* Get a pointer to the new descriptor. */
4800 if (se->want_pointer)
4801 se->expr = build_fold_addr_expr (desc);
4806 gfc_add_block_to_block (&se->pre, &loop.pre);
4807 gfc_add_block_to_block (&se->post, &loop.post);
4809 /* Cleanup the scalarizer. */
4810 gfc_cleanup_loop (&loop);
4814 /* Convert an array for passing as an actual parameter. */
4815 /* TODO: Optimize passing g77 arrays. */
4818 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4822 tree tmp = NULL_TREE;
4824 tree parent = DECL_CONTEXT (current_function_decl);
4825 bool full_array_var, this_array_result;
4829 full_array_var = (expr->expr_type == EXPR_VARIABLE
4830 && expr->ref->u.ar.type == AR_FULL);
4831 sym = full_array_var ? expr->symtree->n.sym : NULL;
4833 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
4835 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
4836 expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
4837 se->string_length = expr->ts.cl->backend_decl;
4840 /* Is this the result of the enclosing procedure? */
4841 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
4842 if (this_array_result
4843 && (sym->backend_decl != current_function_decl)
4844 && (sym->backend_decl != parent))
4845 this_array_result = false;
4847 /* Passing address of the array if it is not pointer or assumed-shape. */
4848 if (full_array_var && g77 && !this_array_result)
4850 tmp = gfc_get_symbol_decl (sym);
4852 if (sym->ts.type == BT_CHARACTER)
4853 se->string_length = sym->ts.cl->backend_decl;
4854 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4855 && !sym->attr.allocatable)
4857 /* Some variables are declared directly, others are declared as
4858 pointers and allocated on the heap. */
4859 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4862 se->expr = build_fold_addr_expr (tmp);
4865 if (sym->attr.allocatable)
4867 if (sym->attr.dummy)
4869 gfc_conv_expr_descriptor (se, expr, ss);
4870 se->expr = gfc_conv_array_data (se->expr);
4873 se->expr = gfc_conv_array_data (tmp);
4878 if (this_array_result)
4880 /* Result of the enclosing function. */
4881 gfc_conv_expr_descriptor (se, expr, ss);
4882 se->expr = build_fold_addr_expr (se->expr);
4884 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
4885 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4886 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
4892 /* Every other type of array. */
4893 se->want_pointer = 1;
4894 gfc_conv_expr_descriptor (se, expr, ss);
4898 /* Deallocate the allocatable components of structures that are
4900 if (expr->ts.type == BT_DERIVED
4901 && expr->ts.derived->attr.alloc_comp
4902 && expr->expr_type != EXPR_VARIABLE)
4904 tmp = build_fold_indirect_ref (se->expr);
4905 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4906 gfc_add_expr_to_block (&se->post, tmp);
4912 /* Repack the array. */
4913 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
4914 ptr = gfc_evaluate_now (ptr, &se->pre);
4917 gfc_start_block (&block);
4919 /* Copy the data back. */
4920 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
4921 gfc_add_expr_to_block (&block, tmp);
4923 /* Free the temporary. */
4924 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
4925 gfc_add_expr_to_block (&block, tmp);
4927 stmt = gfc_finish_block (&block);
4929 gfc_init_block (&block);
4930 /* Only if it was repacked. This code needs to be executed before the
4931 loop cleanup code. */
4932 tmp = build_fold_indirect_ref (desc);
4933 tmp = gfc_conv_array_data (tmp);
4934 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4935 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4937 gfc_add_expr_to_block (&block, tmp);
4938 gfc_add_block_to_block (&block, &se->post);
4940 gfc_init_block (&se->post);
4941 gfc_add_block_to_block (&se->post, &block);
4946 /* Generate code to deallocate an array, if it is allocated. */
4949 gfc_trans_dealloc_allocated (tree descriptor)
4956 gfc_start_block (&block);
4958 var = gfc_conv_descriptor_data_get (descriptor);
4960 tmp = gfc_create_var (gfc_array_index_type, NULL);
4961 ptr = build_fold_addr_expr (tmp);
4963 /* Call array_deallocate with an int* present in the second argument.
4964 Although it is ignored here, it's presence ensures that arrays that
4965 are already deallocated are ignored. */
4966 tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
4967 gfc_add_expr_to_block (&block, tmp);
4969 /* Zero the data pointer. */
4970 tmp = build2 (MODIFY_EXPR, void_type_node,
4971 var, build_int_cst (TREE_TYPE (var), 0));
4972 gfc_add_expr_to_block (&block, tmp);
4974 return gfc_finish_block (&block);
4978 /* This helper function calculates the size in words of a full array. */
4981 get_full_array_size (stmtblock_t *block, tree decl, int rank)
4986 idx = gfc_rank_cst[rank - 1];
4987 nelems = gfc_conv_descriptor_ubound (decl, idx);
4988 tmp = gfc_conv_descriptor_lbound (decl, idx);
4989 tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4990 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4991 tmp, gfc_index_one_node);
4992 tmp = gfc_evaluate_now (tmp, block);
4994 nelems = gfc_conv_descriptor_stride (decl, idx);
4995 tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4996 return gfc_evaluate_now (tmp, block);
5000 /* Allocate dest to the same size as src, and copy src -> dest. */
5003 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5012 /* If the source is null, set the destination to null. */
5013 gfc_init_block (&block);
5014 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5015 null_data = gfc_finish_block (&block);
5017 gfc_init_block (&block);
5019 nelems = get_full_array_size (&block, src, rank);
5020 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5021 fold_convert (gfc_array_index_type,
5022 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5024 /* Allocate memory to the destination. */
5025 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5027 gfc_conv_descriptor_data_set (&block, dest, tmp);
5029 /* We know the temporary and the value will be the same length,
5030 so can use memcpy. */
5031 tmp = built_in_decls[BUILT_IN_MEMCPY];
5032 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5033 gfc_conv_descriptor_data_get (src), size);
5034 gfc_add_expr_to_block (&block, tmp);
5035 tmp = gfc_finish_block (&block);
5037 /* Null the destination if the source is null; otherwise do
5038 the allocate and copy. */
5039 null_cond = gfc_conv_descriptor_data_get (src);
5040 null_cond = convert (pvoid_type_node, null_cond);
5041 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5043 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5047 /* Recursively traverse an object of derived type, generating code to
5048 deallocate, nullify or copy allocatable components. This is the work horse
5049 function for the functions named in this enum. */
5051 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5054 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5055 tree dest, int rank, int purpose)
5059 stmtblock_t fnblock;
5060 stmtblock_t loopbody;
5070 tree null_cond = NULL_TREE;
5072 gfc_init_block (&fnblock);
5074 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5075 decl = build_fold_indirect_ref (decl);
5077 /* If this an array of derived types with allocatable components
5078 build a loop and recursively call this function. */
5079 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5080 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5082 tmp = gfc_conv_array_data (decl);
5083 var = build_fold_indirect_ref (tmp);
5085 /* Get the number of elements - 1 and set the counter. */
5086 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5088 /* Use the descriptor for an allocatable array. Since this
5089 is a full array reference, we only need the descriptor
5090 information from dimension = rank. */
5091 tmp = get_full_array_size (&fnblock, decl, rank);
5092 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
5093 tmp, gfc_index_one_node);
5095 null_cond = gfc_conv_descriptor_data_get (decl);
5096 null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
5097 build_int_cst (TREE_TYPE (null_cond), 0));
5101 /* Otherwise use the TYPE_DOMAIN information. */
5102 tmp = array_type_nelts (TREE_TYPE (decl));
5103 tmp = fold_convert (gfc_array_index_type, tmp);
5106 /* Remember that this is, in fact, the no. of elements - 1. */
5107 nelems = gfc_evaluate_now (tmp, &fnblock);
5108 index = gfc_create_var (gfc_array_index_type, "S");
5110 /* Build the body of the loop. */
5111 gfc_init_block (&loopbody);
5113 vref = gfc_build_array_ref (var, index);
5115 if (purpose == COPY_ALLOC_COMP)
5117 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5118 gfc_add_expr_to_block (&fnblock, tmp);
5120 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5121 dref = gfc_build_array_ref (tmp, index);
5122 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5125 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5127 gfc_add_expr_to_block (&loopbody, tmp);
5129 /* Build the loop and return. */
5130 gfc_init_loopinfo (&loop);
5132 loop.from[0] = gfc_index_zero_node;
5133 loop.loopvar[0] = index;
5134 loop.to[0] = nelems;
5135 gfc_trans_scalarizing_loops (&loop, &loopbody);
5136 gfc_add_block_to_block (&fnblock, &loop.pre);
5138 tmp = gfc_finish_block (&fnblock);
5139 if (null_cond != NULL_TREE)
5140 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5145 /* Otherwise, act on the components or recursively call self to
5146 act on a chain of components. */
5147 for (c = der_type->components; c; c = c->next)
5149 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5150 && c->ts.derived->attr.alloc_comp;
5151 cdecl = c->backend_decl;
5152 ctype = TREE_TYPE (cdecl);
5156 case DEALLOCATE_ALLOC_COMP:
5157 /* Do not deallocate the components of ultimate pointer
5159 if (cmp_has_alloc_comps && !c->pointer)
5161 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5162 rank = c->as ? c->as->rank : 0;
5163 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5165 gfc_add_expr_to_block (&fnblock, tmp);
5170 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5171 tmp = gfc_trans_dealloc_allocated (comp);
5172 gfc_add_expr_to_block (&fnblock, tmp);
5176 case NULLIFY_ALLOC_COMP:
5179 else if (c->allocatable)
5181 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5182 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5184 else if (cmp_has_alloc_comps)
5186 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5187 rank = c->as ? c->as->rank : 0;
5188 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5190 gfc_add_expr_to_block (&fnblock, tmp);
5194 case COPY_ALLOC_COMP:
5198 /* We need source and destination components. */
5199 comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5200 dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5201 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5203 if (c->allocatable && !cmp_has_alloc_comps)
5205 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5206 gfc_add_expr_to_block (&fnblock, tmp);
5209 if (cmp_has_alloc_comps)
5211 rank = c->as ? c->as->rank : 0;
5212 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5213 gfc_add_modify_expr (&fnblock, dcmp, tmp);
5214 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5216 gfc_add_expr_to_block (&fnblock, tmp);
5226 return gfc_finish_block (&fnblock);
5229 /* Recursively traverse an object of derived type, generating code to
5230 nullify allocatable components. */
5233 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5235 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5236 NULLIFY_ALLOC_COMP);
5240 /* Recursively traverse an object of derived type, generating code to
5241 deallocate allocatable components. */
5244 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5246 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5247 DEALLOCATE_ALLOC_COMP);
5251 /* Recursively traverse an object of derived type, generating code to
5252 copy its allocatable components. */
5255 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5257 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5261 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5262 Do likewise, recursively if necessary, with the allocatable components of
5266 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5271 stmtblock_t fnblock;
5274 bool sym_has_alloc_comp;
5276 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5277 && sym->ts.derived->attr.alloc_comp;
5279 /* Make sure the frontend gets these right. */
5280 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5281 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5282 "allocatable attribute or derived type without allocatable "
5285 gfc_init_block (&fnblock);
5287 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5288 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5290 if (sym->ts.type == BT_CHARACTER
5291 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5293 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
5294 gfc_trans_vla_type_sizes (sym, &fnblock);
5297 /* Dummy and use associated variables don't need anything special. */
5298 if (sym->attr.dummy || sym->attr.use_assoc)
5300 gfc_add_expr_to_block (&fnblock, body);
5302 return gfc_finish_block (&fnblock);
5305 gfc_get_backend_locus (&loc);
5306 gfc_set_backend_locus (&sym->declared_at);
5307 descriptor = sym->backend_decl;
5309 /* Although static, derived types with default initializers and
5310 allocatable components must not be nulled wholesale; instead they
5311 are treated component by component. */
5312 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5314 /* SAVEd variables are not freed on exit. */
5315 gfc_trans_static_array_pointer (sym);
5319 /* Get the descriptor type. */
5320 type = TREE_TYPE (sym->backend_decl);
5322 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5324 if (!sym->attr.save)
5326 rank = sym->as ? sym->as->rank : 0;
5327 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5328 gfc_add_expr_to_block (&fnblock, tmp);
5331 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5333 /* If the backend_decl is not a descriptor, we must have a pointer
5335 descriptor = build_fold_indirect_ref (sym->backend_decl);
5336 type = TREE_TYPE (descriptor);
5339 /* NULLIFY the data pointer. */
5340 if (GFC_DESCRIPTOR_TYPE_P (type))
5341 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5343 gfc_add_expr_to_block (&fnblock, body);
5345 gfc_set_backend_locus (&loc);
5347 /* Allocatable arrays need to be freed when they go out of scope.
5348 The allocatable components of pointers must not be touched. */
5349 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5350 && !sym->attr.pointer && !sym->attr.save)
5353 rank = sym->as ? sym->as->rank : 0;
5354 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5355 gfc_add_expr_to_block (&fnblock, tmp);
5358 if (sym->attr.allocatable)
5360 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5361 gfc_add_expr_to_block (&fnblock, tmp);
5364 return gfc_finish_block (&fnblock);
5367 /************ Expression Walking Functions ******************/
5369 /* Walk a variable reference.
5371 Possible extension - multiple component subscripts.
5372 x(:,:) = foo%a(:)%b(:)
5374 forall (i=..., j=...)
5375 x(i,j) = foo%a(j)%b(i)
5377 This adds a fair amount of complexity because you need to deal with more
5378 than one ref. Maybe handle in a similar manner to vector subscripts.
5379 Maybe not worth the effort. */
5383 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5391 for (ref = expr->ref; ref; ref = ref->next)
5392 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5395 for (; ref; ref = ref->next)
5397 if (ref->type == REF_SUBSTRING)
5399 newss = gfc_get_ss ();
5400 newss->type = GFC_SS_SCALAR;
5401 newss->expr = ref->u.ss.start;
5405 newss = gfc_get_ss ();
5406 newss->type = GFC_SS_SCALAR;
5407 newss->expr = ref->u.ss.end;
5412 /* We're only interested in array sections from now on. */
5413 if (ref->type != REF_ARRAY)
5420 for (n = 0; n < ar->dimen; n++)
5422 newss = gfc_get_ss ();
5423 newss->type = GFC_SS_SCALAR;
5424 newss->expr = ar->start[n];
5431 newss = gfc_get_ss ();
5432 newss->type = GFC_SS_SECTION;
5435 newss->data.info.dimen = ar->as->rank;
5436 newss->data.info.ref = ref;
5438 /* Make sure array is the same as array(:,:), this way
5439 we don't need to special case all the time. */
5440 ar->dimen = ar->as->rank;
5441 for (n = 0; n < ar->dimen; n++)
5443 newss->data.info.dim[n] = n;
5444 ar->dimen_type[n] = DIMEN_RANGE;
5446 gcc_assert (ar->start[n] == NULL);
5447 gcc_assert (ar->end[n] == NULL);
5448 gcc_assert (ar->stride[n] == NULL);
5454 newss = gfc_get_ss ();
5455 newss->type = GFC_SS_SECTION;
5458 newss->data.info.dimen = 0;
5459 newss->data.info.ref = ref;
5463 /* We add SS chains for all the subscripts in the section. */
5464 for (n = 0; n < ar->dimen; n++)
5468 switch (ar->dimen_type[n])
5471 /* Add SS for elemental (scalar) subscripts. */
5472 gcc_assert (ar->start[n]);
5473 indexss = gfc_get_ss ();
5474 indexss->type = GFC_SS_SCALAR;
5475 indexss->expr = ar->start[n];
5476 indexss->next = gfc_ss_terminator;
5477 indexss->loop_chain = gfc_ss_terminator;
5478 newss->data.info.subscript[n] = indexss;
5482 /* We don't add anything for sections, just remember this
5483 dimension for later. */
5484 newss->data.info.dim[newss->data.info.dimen] = n;
5485 newss->data.info.dimen++;
5489 /* Create a GFC_SS_VECTOR index in which we can store
5490 the vector's descriptor. */
5491 indexss = gfc_get_ss ();
5492 indexss->type = GFC_SS_VECTOR;
5493 indexss->expr = ar->start[n];
5494 indexss->next = gfc_ss_terminator;
5495 indexss->loop_chain = gfc_ss_terminator;
5496 newss->data.info.subscript[n] = indexss;
5497 newss->data.info.dim[newss->data.info.dimen] = n;
5498 newss->data.info.dimen++;
5502 /* We should know what sort of section it is by now. */
5506 /* We should have at least one non-elemental dimension. */
5507 gcc_assert (newss->data.info.dimen > 0);
5512 /* We should know what sort of section it is by now. */
5521 /* Walk an expression operator. If only one operand of a binary expression is
5522 scalar, we must also add the scalar term to the SS chain. */
5525 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5531 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5532 if (expr->value.op.op2 == NULL)
5535 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5537 /* All operands are scalar. Pass back and let the caller deal with it. */
5541 /* All operands require scalarization. */
5542 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5545 /* One of the operands needs scalarization, the other is scalar.
5546 Create a gfc_ss for the scalar expression. */
5547 newss = gfc_get_ss ();
5548 newss->type = GFC_SS_SCALAR;
5551 /* First operand is scalar. We build the chain in reverse order, so
5552 add the scarar SS after the second operand. */
5554 while (head && head->next != ss)
5556 /* Check we haven't somehow broken the chain. */
5560 newss->expr = expr->value.op.op1;
5562 else /* head2 == head */
5564 gcc_assert (head2 == head);
5565 /* Second operand is scalar. */
5566 newss->next = head2;
5568 newss->expr = expr->value.op.op2;
5575 /* Reverse a SS chain. */
5578 gfc_reverse_ss (gfc_ss * ss)
5583 gcc_assert (ss != NULL);
5585 head = gfc_ss_terminator;
5586 while (ss != gfc_ss_terminator)
5589 /* Check we didn't somehow break the chain. */
5590 gcc_assert (next != NULL);
5600 /* Walk the arguments of an elemental function. */
5603 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
5611 head = gfc_ss_terminator;
5614 for (; arg; arg = arg->next)
5619 newss = gfc_walk_subexpr (head, arg->expr);
5622 /* Scalar argument. */
5623 newss = gfc_get_ss ();
5625 newss->expr = arg->expr;
5635 while (tail->next != gfc_ss_terminator)
5642 /* If all the arguments are scalar we don't need the argument SS. */
5643 gfc_free_ss_chain (head);
5648 /* Add it onto the existing chain. */
5654 /* Walk a function call. Scalar functions are passed back, and taken out of
5655 scalarization loops. For elemental functions we walk their arguments.
5656 The result of functions returning arrays is stored in a temporary outside
5657 the loop, so that the function is only called once. Hence we do not need
5658 to walk their arguments. */
5661 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
5664 gfc_intrinsic_sym *isym;
5667 isym = expr->value.function.isym;
5669 /* Handle intrinsic functions separately. */
5671 return gfc_walk_intrinsic_function (ss, expr, isym);
5673 sym = expr->value.function.esym;
5675 sym = expr->symtree->n.sym;
5677 /* A function that returns arrays. */
5678 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5680 newss = gfc_get_ss ();
5681 newss->type = GFC_SS_FUNCTION;
5684 newss->data.info.dimen = expr->rank;
5688 /* Walk the parameters of an elemental function. For now we always pass
5690 if (sym->attr.elemental)
5691 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5694 /* Scalar functions are OK as these are evaluated outside the scalarization
5695 loop. Pass back and let the caller deal with it. */
5700 /* An array temporary is constructed for array constructors. */
5703 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5708 newss = gfc_get_ss ();
5709 newss->type = GFC_SS_CONSTRUCTOR;
5712 newss->data.info.dimen = expr->rank;
5713 for (n = 0; n < expr->rank; n++)
5714 newss->data.info.dim[n] = n;
5720 /* Walk an expression. Add walked expressions to the head of the SS chain.
5721 A wholly scalar expression will not be added. */
5724 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5728 switch (expr->expr_type)
5731 head = gfc_walk_variable_expr (ss, expr);
5735 head = gfc_walk_op_expr (ss, expr);
5739 head = gfc_walk_function_expr (ss, expr);
5744 case EXPR_STRUCTURE:
5745 /* Pass back and let the caller deal with it. */
5749 head = gfc_walk_array_constructor (ss, expr);
5752 case EXPR_SUBSTRING:
5753 /* Pass back and let the caller deal with it. */
5757 internal_error ("bad expression type during walk (%d)",
5764 /* Entry point for expression walking.
5765 A return value equal to the passed chain means this is
5766 a scalar expression. It is up to the caller to take whatever action is
5767 necessary to translate these. */
5770 gfc_walk_expr (gfc_expr * expr)
5774 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5775 return gfc_reverse_ss (res);