1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var;
100 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
104 gfc_array_dataptr_type (tree desc)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
133 #define STRIDE_SUBFIELD 0
134 #define LBOUND_SUBFIELD 1
135 #define UBOUND_SUBFIELD 2
137 /* This provides READ-ONLY access to the data field. The field itself
138 doesn't have the proper type. */
141 gfc_conv_descriptor_data_get (tree desc)
145 type = TREE_TYPE (desc);
146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
148 field = TYPE_FIELDS (type);
149 gcc_assert (DATA_FIELD == 0);
151 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
152 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
157 /* This provides WRITE access to the data field. */
160 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
164 type = TREE_TYPE (desc);
165 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
167 field = TYPE_FIELDS (type);
168 gcc_assert (DATA_FIELD == 0);
170 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
171 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
175 /* This provides address access to the data field. This should only be
176 used by array allocation, passing this on to the runtime. */
179 gfc_conv_descriptor_data_addr (tree desc)
183 type = TREE_TYPE (desc);
184 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
186 field = TYPE_FIELDS (type);
187 gcc_assert (DATA_FIELD == 0);
189 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
190 return gfc_build_addr_expr (NULL, t);
194 gfc_conv_descriptor_offset (tree desc)
199 type = TREE_TYPE (desc);
200 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
202 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
203 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
205 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
209 gfc_conv_descriptor_dtype (tree desc)
214 type = TREE_TYPE (desc);
215 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
217 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
218 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
220 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
224 gfc_conv_descriptor_dimension (tree desc, tree dim)
230 type = TREE_TYPE (desc);
231 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
233 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
234 gcc_assert (field != NULL_TREE
235 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
236 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
238 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
239 tmp = gfc_build_array_ref (tmp, dim);
244 gfc_conv_descriptor_stride (tree desc, tree dim)
249 tmp = gfc_conv_descriptor_dimension (desc, dim);
250 field = TYPE_FIELDS (TREE_TYPE (tmp));
251 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
252 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
254 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
259 gfc_conv_descriptor_lbound (tree desc, tree dim)
264 tmp = gfc_conv_descriptor_dimension (desc, dim);
265 field = TYPE_FIELDS (TREE_TYPE (tmp));
266 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
267 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
269 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
274 gfc_conv_descriptor_ubound (tree desc, tree dim)
279 tmp = gfc_conv_descriptor_dimension (desc, dim);
280 field = TYPE_FIELDS (TREE_TYPE (tmp));
281 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
282 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
284 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
289 /* Build a null array descriptor constructor. */
292 gfc_build_null_descriptor (tree type)
297 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
298 gcc_assert (DATA_FIELD == 0);
299 field = TYPE_FIELDS (type);
301 /* Set a NULL data pointer. */
302 tmp = build_constructor_single (type, field, null_pointer_node);
303 TREE_CONSTANT (tmp) = 1;
304 TREE_INVARIANT (tmp) = 1;
305 /* All other fields are ignored. */
311 /* Cleanup those #defines. */
316 #undef DIMENSION_FIELD
317 #undef STRIDE_SUBFIELD
318 #undef LBOUND_SUBFIELD
319 #undef UBOUND_SUBFIELD
322 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
323 flags & 1 = Main loop body.
324 flags & 2 = temp copy loop. */
327 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
329 for (; ss != gfc_ss_terminator; ss = ss->next)
330 ss->useflags = flags;
333 static void gfc_free_ss (gfc_ss *);
336 /* Free a gfc_ss chain. */
339 gfc_free_ss_chain (gfc_ss * ss)
343 while (ss != gfc_ss_terminator)
345 gcc_assert (ss != NULL);
356 gfc_free_ss (gfc_ss * ss)
364 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
366 if (ss->data.info.subscript[n])
367 gfc_free_ss_chain (ss->data.info.subscript[n]);
379 /* Free all the SS associated with a loop. */
382 gfc_cleanup_loop (gfc_loopinfo * loop)
388 while (ss != gfc_ss_terminator)
390 gcc_assert (ss != NULL);
391 next = ss->loop_chain;
398 /* Associate a SS chain with a loop. */
401 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
405 if (head == gfc_ss_terminator)
409 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
411 if (ss->next == gfc_ss_terminator)
412 ss->loop_chain = loop->ss;
414 ss->loop_chain = ss->next;
416 gcc_assert (ss == gfc_ss_terminator);
421 /* Generate an initializer for a static pointer or allocatable array. */
424 gfc_trans_static_array_pointer (gfc_symbol * sym)
428 gcc_assert (TREE_STATIC (sym->backend_decl));
429 /* Just zero the data member. */
430 type = TREE_TYPE (sym->backend_decl);
431 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
435 /* Generate code to allocate an array temporary, or create a variable to
436 hold the data. If size is NULL zero the descriptor so that so that the
437 callee will allocate the array. Also generates code to free the array
441 gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
442 tree size, tree nelem)
449 desc = info->descriptor;
450 info->offset = gfc_index_zero_node;
451 if (size == NULL_TREE)
453 /* A callee allocated array. */
454 gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
459 /* Allocate the temporary. */
460 onstack = gfc_can_put_var_on_stack (size);
464 /* Make a temporary variable to hold the data. */
465 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
467 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
469 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
471 tmp = gfc_create_var (tmp, "A");
472 tmp = gfc_build_addr_expr (NULL, tmp);
473 gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
477 /* Allocate memory to hold the data. */
478 args = gfc_chainon_list (NULL_TREE, size);
480 if (gfc_index_integer_kind == 4)
481 tmp = gfor_fndecl_internal_malloc;
482 else if (gfc_index_integer_kind == 8)
483 tmp = gfor_fndecl_internal_malloc64;
486 tmp = gfc_build_function_call (tmp, args);
487 tmp = gfc_evaluate_now (tmp, &loop->pre);
488 gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
491 info->data = gfc_conv_descriptor_data_get (desc);
493 /* The offset is zero because we create temporaries with a zero
495 tmp = gfc_conv_descriptor_offset (desc);
496 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
500 /* Free the temporary. */
501 tmp = gfc_conv_descriptor_data_get (desc);
502 tmp = fold_convert (pvoid_type_node, tmp);
503 tmp = gfc_chainon_list (NULL_TREE, tmp);
504 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
505 gfc_add_expr_to_block (&loop->post, tmp);
510 /* Generate code to allocate and initialize the descriptor for a temporary
511 array. This is used for both temporaries needed by the scalarizer, and
512 functions returning arrays. Adjusts the loop variables to be zero-based,
513 and calculates the loop bounds for callee allocated arrays.
514 Also fills in the descriptor, data and offset fields of info if known.
515 Returns the size of the array, or NULL for a callee allocated array. */
518 gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
529 gcc_assert (info->dimen > 0);
530 /* Set the lower bound to zero. */
531 for (dim = 0; dim < info->dimen; dim++)
533 n = loop->order[dim];
534 if (n < loop->temp_dim)
535 gcc_assert (integer_zerop (loop->from[n]));
538 /* Callee allocated arrays may not have a known bound yet. */
540 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
541 loop->to[n], loop->from[n]);
542 loop->from[n] = gfc_index_zero_node;
545 info->delta[dim] = gfc_index_zero_node;
546 info->start[dim] = gfc_index_zero_node;
547 info->stride[dim] = gfc_index_one_node;
548 info->dim[dim] = dim;
551 /* Initialize the descriptor. */
553 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
554 desc = gfc_create_var (type, "atmp");
555 GFC_DECL_PACKED_ARRAY (desc) = 1;
557 info->descriptor = desc;
558 size = gfc_index_one_node;
560 /* Fill in the array dtype. */
561 tmp = gfc_conv_descriptor_dtype (desc);
562 gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
565 Fill in the bounds and stride. This is a packed array, so:
568 for (n = 0; n < rank; n++)
571 delta = ubound[n] + 1 - lbound[n];
574 size = size * sizeof(element);
577 for (n = 0; n < info->dimen; n++)
579 if (loop->to[n] == NULL_TREE)
581 /* For a callee allocated array express the loop bounds in terms
582 of the descriptor fields. */
583 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
584 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
585 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
591 /* Store the stride and bound components in the descriptor. */
592 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
593 gfc_add_modify_expr (&loop->pre, tmp, size);
595 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
596 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
598 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
599 gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
601 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
602 loop->to[n], gfc_index_one_node);
604 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
605 size = gfc_evaluate_now (size, &loop->pre);
608 /* Get the size of the array. */
611 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
612 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
614 gfc_trans_allocate_array_storage (loop, info, size, nelem);
616 if (info->dimen > loop->temp_dim)
617 loop->temp_dim = info->dimen;
623 /* Make sure offset is a variable. */
626 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
629 /* We should have already created the offset variable. We cannot
630 create it here because we may be in an inner scope. */
631 gcc_assert (*offsetvar != NULL_TREE);
632 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
633 *poffset = *offsetvar;
634 TREE_USED (*offsetvar) = 1;
638 /* Assign an element of an array constructor. */
641 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
642 tree offset, gfc_se * se, gfc_expr * expr)
647 gfc_conv_expr (se, expr);
649 /* Store the value. */
650 tmp = gfc_build_indirect_ref (pointer);
651 tmp = gfc_build_array_ref (tmp, offset);
652 if (expr->ts.type == BT_CHARACTER)
654 gfc_conv_string_parameter (se);
655 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
657 /* The temporary is an array of pointers. */
658 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
659 gfc_add_modify_expr (&se->pre, tmp, se->expr);
663 /* The temporary is an array of string values. */
664 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
665 /* We know the temporary and the value will be the same length,
666 so can use memcpy. */
667 args = gfc_chainon_list (NULL_TREE, tmp);
668 args = gfc_chainon_list (args, se->expr);
669 args = gfc_chainon_list (args, se->string_length);
670 tmp = built_in_decls[BUILT_IN_MEMCPY];
671 tmp = gfc_build_function_call (tmp, args);
672 gfc_add_expr_to_block (&se->pre, tmp);
677 /* TODO: Should the frontend already have done this conversion? */
678 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
679 gfc_add_modify_expr (&se->pre, tmp, se->expr);
682 gfc_add_block_to_block (pblock, &se->pre);
683 gfc_add_block_to_block (pblock, &se->post);
687 /* Add the contents of an array to the constructor. */
690 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
691 tree type ATTRIBUTE_UNUSED,
692 tree pointer, gfc_expr * expr,
693 tree * poffset, tree * offsetvar)
701 /* We need this to be a variable so we can increment it. */
702 gfc_put_offset_into_var (pblock, poffset, offsetvar);
704 gfc_init_se (&se, NULL);
706 /* Walk the array expression. */
707 ss = gfc_walk_expr (expr);
708 gcc_assert (ss != gfc_ss_terminator);
710 /* Initialize the scalarizer. */
711 gfc_init_loopinfo (&loop);
712 gfc_add_ss_to_loop (&loop, ss);
714 /* Initialize the loop. */
715 gfc_conv_ss_startstride (&loop);
716 gfc_conv_loop_setup (&loop);
718 /* Make the loop body. */
719 gfc_mark_ss_chain_used (ss, 1);
720 gfc_start_scalarized_body (&loop, &body);
721 gfc_copy_loopinfo_to_se (&se, &loop);
724 if (expr->ts.type == BT_CHARACTER)
725 gfc_todo_error ("character arrays in constructors");
727 gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
728 gcc_assert (se.ss == gfc_ss_terminator);
730 /* Increment the offset. */
731 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
732 gfc_add_modify_expr (&body, *poffset, tmp);
734 /* Finish the loop. */
735 gfc_trans_scalarizing_loops (&loop, &body);
736 gfc_add_block_to_block (&loop.pre, &loop.post);
737 tmp = gfc_finish_block (&loop.pre);
738 gfc_add_expr_to_block (pblock, tmp);
740 gfc_cleanup_loop (&loop);
744 /* Assign the values to the elements of an array constructor. */
747 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
748 tree pointer, gfc_constructor * c,
749 tree * poffset, tree * offsetvar)
755 for (; c; c = c->next)
757 /* If this is an iterator or an array, the offset must be a variable. */
758 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
759 gfc_put_offset_into_var (pblock, poffset, offsetvar);
761 gfc_start_block (&body);
763 if (c->expr->expr_type == EXPR_ARRAY)
765 /* Array constructors can be nested. */
766 gfc_trans_array_constructor_value (&body, type, pointer,
767 c->expr->value.constructor,
770 else if (c->expr->rank > 0)
772 gfc_trans_array_constructor_subarray (&body, type, pointer,
773 c->expr, poffset, offsetvar);
777 /* This code really upsets the gimplifier so don't bother for now. */
784 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
792 gfc_init_se (&se, NULL);
793 gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
796 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
797 *poffset, gfc_index_one_node);
801 /* Collect multiple scalar constants into a constructor. */
809 /* Count the number of consecutive scalar constants. */
810 while (p && !(p->iterator
811 || p->expr->expr_type != EXPR_CONSTANT))
813 gfc_init_se (&se, NULL);
814 gfc_conv_constant (&se, p->expr);
815 if (p->expr->ts.type == BT_CHARACTER
816 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
817 (TREE_TYPE (pointer)))))
819 /* For constant character array constructors we build
820 an array of pointers. */
821 se.expr = gfc_build_addr_expr (pchar_type_node,
825 list = tree_cons (NULL_TREE, se.expr, list);
830 bound = build_int_cst (NULL_TREE, n - 1);
831 /* Create an array type to hold them. */
832 tmptype = build_range_type (gfc_array_index_type,
833 gfc_index_zero_node, bound);
834 tmptype = build_array_type (type, tmptype);
836 init = build_constructor_from_list (tmptype, nreverse (list));
837 TREE_CONSTANT (init) = 1;
838 TREE_INVARIANT (init) = 1;
839 TREE_STATIC (init) = 1;
840 /* Create a static variable to hold the data. */
841 tmp = gfc_create_var (tmptype, "data");
842 TREE_STATIC (tmp) = 1;
843 TREE_CONSTANT (tmp) = 1;
844 TREE_INVARIANT (tmp) = 1;
845 DECL_INITIAL (tmp) = init;
848 /* Use BUILTIN_MEMCPY to assign the values. */
849 tmp = gfc_build_indirect_ref (pointer);
850 tmp = gfc_build_array_ref (tmp, *poffset);
851 tmp = gfc_build_addr_expr (NULL, tmp);
852 init = gfc_build_addr_expr (NULL, init);
854 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
855 bound = build_int_cst (NULL_TREE, n * size);
856 tmp = gfc_chainon_list (NULL_TREE, tmp);
857 tmp = gfc_chainon_list (tmp, init);
858 tmp = gfc_chainon_list (tmp, bound);
859 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
861 gfc_add_expr_to_block (&body, tmp);
863 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
864 *poffset, build_int_cst (NULL_TREE, n));
866 if (!INTEGER_CST_P (*poffset))
868 gfc_add_modify_expr (&body, *offsetvar, *poffset);
869 *poffset = *offsetvar;
873 /* The frontend should already have done any expansions possible
877 /* Pass the code as is. */
878 tmp = gfc_finish_block (&body);
879 gfc_add_expr_to_block (pblock, tmp);
883 /* Build the implied do-loop. */
891 loopbody = gfc_finish_block (&body);
893 gfc_init_se (&se, NULL);
894 gfc_conv_expr (&se, c->iterator->var);
895 gfc_add_block_to_block (pblock, &se.pre);
898 /* Initialize the loop. */
899 gfc_init_se (&se, NULL);
900 gfc_conv_expr_val (&se, c->iterator->start);
901 gfc_add_block_to_block (pblock, &se.pre);
902 gfc_add_modify_expr (pblock, loopvar, se.expr);
904 gfc_init_se (&se, NULL);
905 gfc_conv_expr_val (&se, c->iterator->end);
906 gfc_add_block_to_block (pblock, &se.pre);
907 end = gfc_evaluate_now (se.expr, pblock);
909 gfc_init_se (&se, NULL);
910 gfc_conv_expr_val (&se, c->iterator->step);
911 gfc_add_block_to_block (pblock, &se.pre);
912 step = gfc_evaluate_now (se.expr, pblock);
914 /* Generate the loop body. */
915 exit_label = gfc_build_label_decl (NULL_TREE);
916 gfc_start_block (&body);
918 /* Generate the exit condition. Depending on the sign of
919 the step variable we have to generate the correct
921 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
922 build_int_cst (TREE_TYPE (step), 0));
923 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
924 build2 (GT_EXPR, boolean_type_node,
926 build2 (LT_EXPR, boolean_type_node,
928 tmp = build1_v (GOTO_EXPR, exit_label);
929 TREE_USED (exit_label) = 1;
930 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
931 gfc_add_expr_to_block (&body, tmp);
933 /* The main loop body. */
934 gfc_add_expr_to_block (&body, loopbody);
936 /* Increase loop variable by step. */
937 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
938 gfc_add_modify_expr (&body, loopvar, tmp);
940 /* Finish the loop. */
941 tmp = gfc_finish_block (&body);
942 tmp = build1_v (LOOP_EXPR, tmp);
943 gfc_add_expr_to_block (pblock, tmp);
945 /* Add the exit label. */
946 tmp = build1_v (LABEL_EXPR, exit_label);
947 gfc_add_expr_to_block (pblock, tmp);
953 /* Get the size of an expression. Returns -1 if the size isn't constant.
954 Implied do loops with non-constant bounds are tricky because we must only
955 evaluate the bounds once. */
958 gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
964 mpz_set_ui (*size, 0);
968 for (; c; c = c->next)
970 if (c->expr->expr_type == EXPR_ARRAY)
972 /* A nested array constructor. */
973 gfc_get_array_cons_size (&len, c->expr->value.constructor);
974 if (mpz_sgn (len) < 0)
976 mpz_set (*size, len);
984 if (c->expr->rank > 0)
986 mpz_set_si (*size, -1);
998 if (i->start->expr_type != EXPR_CONSTANT
999 || i->end->expr_type != EXPR_CONSTANT
1000 || i->step->expr_type != EXPR_CONSTANT)
1002 mpz_set_si (*size, -1);
1008 mpz_add (val, i->end->value.integer, i->start->value.integer);
1009 mpz_tdiv_q (val, val, i->step->value.integer);
1010 mpz_add_ui (val, val, 1);
1011 mpz_mul (len, len, val);
1013 mpz_add (*size, *size, len);
1020 /* Figure out the string length of a variable reference expression.
1021 Used by get_array_ctor_strlen. */
1024 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1029 /* Don't bother if we already know the length is a constant. */
1030 if (*len && INTEGER_CST_P (*len))
1033 ts = &expr->symtree->n.sym->ts;
1034 for (ref = expr->ref; ref; ref = ref->next)
1039 /* Array references don't change the string length. */
1043 /* Use the length of the component. */
1044 ts = &ref->u.c.component->ts;
1048 /* TODO: Substrings are tricky because we can't evaluate the
1049 expression more than once. For now we just give up, and hope
1050 we can figure it out elsewhere. */
1055 *len = ts->cl->backend_decl;
1059 /* Figure out the string length of a character array constructor.
1060 Returns TRUE if all elements are character constants. */
1063 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1068 for (; c; c = c->next)
1070 switch (c->expr->expr_type)
1073 if (!(*len && INTEGER_CST_P (*len)))
1074 *len = build_int_cstu (gfc_charlen_type_node,
1075 c->expr->value.character.length);
1079 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1085 get_array_ctor_var_strlen (c->expr, len);
1090 /* TODO: For now we just ignore anything we don't know how to
1091 handle, and hope we can figure it out a different way. */
1100 /* Array constructors are handled by constructing a temporary, then using that
1101 within the scalarization loop. This is not optimal, but seems by far the
1105 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1114 ss->data.info.dimen = loop->dimen;
1116 if (ss->expr->ts.type == BT_CHARACTER)
1118 const_string = get_array_ctor_strlen (ss->expr->value.constructor,
1119 &ss->string_length);
1120 if (!ss->string_length)
1121 gfc_todo_error ("complex character array constructors");
1123 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1125 type = build_pointer_type (type);
1129 const_string = TRUE;
1130 type = gfc_typenode_for_spec (&ss->expr->ts);
1133 size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
1135 desc = ss->data.info.descriptor;
1136 offset = gfc_index_zero_node;
1137 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1138 TREE_USED (offsetvar) = 0;
1139 gfc_trans_array_constructor_value (&loop->pre, type,
1141 ss->expr->value.constructor, &offset,
1144 if (TREE_USED (offsetvar))
1145 pushdecl (offsetvar);
1147 gcc_assert (INTEGER_CST_P (offset));
1149 /* Disable bound checking for now because it's probably broken. */
1150 if (flag_bounds_check)
1158 /* Add the pre and post chains for all the scalar expressions in a SS chain
1159 to loop. This is called after the loop parameters have been calculated,
1160 but before the actual scalarizing loops. */
1163 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1168 /* TODO: This can generate bad code if there are ordering dependencies.
1169 eg. a callee allocated function and an unknown size constructor. */
1170 gcc_assert (ss != NULL);
1172 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1179 /* Scalar expression. Evaluate this now. This includes elemental
1180 dimension indices, but not array section bounds. */
1181 gfc_init_se (&se, NULL);
1182 gfc_conv_expr (&se, ss->expr);
1183 gfc_add_block_to_block (&loop->pre, &se.pre);
1185 if (ss->expr->ts.type != BT_CHARACTER)
1187 /* Move the evaluation of scalar expressions outside the
1188 scalarization loop. */
1190 se.expr = convert(gfc_array_index_type, se.expr);
1191 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1192 gfc_add_block_to_block (&loop->pre, &se.post);
1195 gfc_add_block_to_block (&loop->post, &se.post);
1197 ss->data.scalar.expr = se.expr;
1198 ss->string_length = se.string_length;
1201 case GFC_SS_REFERENCE:
1202 /* Scalar reference. Evaluate this now. */
1203 gfc_init_se (&se, NULL);
1204 gfc_conv_expr_reference (&se, ss->expr);
1205 gfc_add_block_to_block (&loop->pre, &se.pre);
1206 gfc_add_block_to_block (&loop->post, &se.post);
1208 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1209 ss->string_length = se.string_length;
1212 case GFC_SS_SECTION:
1214 /* Scalarized expression. Evaluate any scalar subscripts. */
1215 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1217 /* Add the expressions for scalar subscripts. */
1218 if (ss->data.info.subscript[n])
1219 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1223 case GFC_SS_INTRINSIC:
1224 gfc_add_intrinsic_ss_code (loop, ss);
1227 case GFC_SS_FUNCTION:
1228 /* Array function return value. We call the function and save its
1229 result in a temporary for use inside the loop. */
1230 gfc_init_se (&se, NULL);
1233 gfc_conv_expr (&se, ss->expr);
1234 gfc_add_block_to_block (&loop->pre, &se.pre);
1235 gfc_add_block_to_block (&loop->post, &se.post);
1236 ss->string_length = se.string_length;
1239 case GFC_SS_CONSTRUCTOR:
1240 gfc_trans_array_constructor (loop, ss);
1244 case GFC_SS_COMPONENT:
1245 /* Do nothing. These are handled elsewhere. */
1255 /* Translate expressions for the descriptor and data pointer of a SS. */
1259 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1264 /* Get the descriptor for the array to be scalarized. */
1265 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1266 gfc_init_se (&se, NULL);
1267 se.descriptor_only = 1;
1268 gfc_conv_expr_lhs (&se, ss->expr);
1269 gfc_add_block_to_block (block, &se.pre);
1270 ss->data.info.descriptor = se.expr;
1271 ss->string_length = se.string_length;
1275 /* Also the data pointer. */
1276 tmp = gfc_conv_array_data (se.expr);
1277 /* If this is a variable or address of a variable we use it directly.
1278 Otherwise we must evaluate it now to avoid breaking dependency
1279 analysis by pulling the expressions for elemental array indices
1282 || (TREE_CODE (tmp) == ADDR_EXPR
1283 && DECL_P (TREE_OPERAND (tmp, 0)))))
1284 tmp = gfc_evaluate_now (tmp, block);
1285 ss->data.info.data = tmp;
1287 tmp = gfc_conv_array_offset (se.expr);
1288 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1293 /* Initialize a gfc_loopinfo structure. */
1296 gfc_init_loopinfo (gfc_loopinfo * loop)
1300 memset (loop, 0, sizeof (gfc_loopinfo));
1301 gfc_init_block (&loop->pre);
1302 gfc_init_block (&loop->post);
1304 /* Initially scalarize in order. */
1305 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1308 loop->ss = gfc_ss_terminator;
1312 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1316 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1322 /* Return an expression for the data pointer of an array. */
1325 gfc_conv_array_data (tree descriptor)
1329 type = TREE_TYPE (descriptor);
1330 if (GFC_ARRAY_TYPE_P (type))
1332 if (TREE_CODE (type) == POINTER_TYPE)
1336 /* Descriptorless arrays. */
1337 return gfc_build_addr_expr (NULL, descriptor);
1341 return gfc_conv_descriptor_data_get (descriptor);
1345 /* Return an expression for the base offset of an array. */
1348 gfc_conv_array_offset (tree descriptor)
1352 type = TREE_TYPE (descriptor);
1353 if (GFC_ARRAY_TYPE_P (type))
1354 return GFC_TYPE_ARRAY_OFFSET (type);
1356 return gfc_conv_descriptor_offset (descriptor);
1360 /* Get an expression for the array stride. */
1363 gfc_conv_array_stride (tree descriptor, int dim)
1368 type = TREE_TYPE (descriptor);
1370 /* For descriptorless arrays use the array size. */
1371 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1372 if (tmp != NULL_TREE)
1375 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1380 /* Like gfc_conv_array_stride, but for the lower bound. */
1383 gfc_conv_array_lbound (tree descriptor, int dim)
1388 type = TREE_TYPE (descriptor);
1390 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1391 if (tmp != NULL_TREE)
1394 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1399 /* Like gfc_conv_array_stride, but for the upper bound. */
1402 gfc_conv_array_ubound (tree descriptor, int dim)
1407 type = TREE_TYPE (descriptor);
1409 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1410 if (tmp != NULL_TREE)
1413 /* This should only ever happen when passing an assumed shape array
1414 as an actual parameter. The value will never be used. */
1415 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1416 return gfc_index_zero_node;
1418 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1423 /* Translate an array reference. The descriptor should be in se->expr.
1424 Do not use this function, it wil be removed soon. */
1428 gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
1429 tree offset, int dimen)
1436 array = gfc_build_indirect_ref (pointer);
1439 for (n = 0; n < dimen; n++)
1441 /* index = index + stride[n]*indices[n] */
1442 tmp = gfc_conv_array_stride (se->expr, n);
1443 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
1445 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1448 /* Result = data[index]. */
1449 tmp = gfc_build_array_ref (array, index);
1451 /* Check we've used the correct number of dimensions. */
1452 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
1458 /* Generate code to perform an array index bound check. */
1461 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1467 if (!flag_bounds_check)
1470 index = gfc_evaluate_now (index, &se->pre);
1471 /* Check lower bound. */
1472 tmp = gfc_conv_array_lbound (descriptor, n);
1473 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1474 /* Check upper bound. */
1475 tmp = gfc_conv_array_ubound (descriptor, n);
1476 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1477 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1479 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1485 /* A reference to an array vector subscript. Uses recursion to handle nested
1486 vector subscripts. */
1489 gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
1492 tree indices[GFC_MAX_DIMENSIONS];
1497 gcc_assert (ss && ss->type == GFC_SS_VECTOR);
1499 /* Save the descriptor. */
1500 descsave = se->expr;
1501 info = &ss->data.info;
1502 se->expr = info->descriptor;
1504 ar = &info->ref->u.ar;
1505 for (n = 0; n < ar->dimen; n++)
1507 switch (ar->dimen_type[n])
1510 gcc_assert (info->subscript[n] != gfc_ss_terminator
1511 && info->subscript[n]->type == GFC_SS_SCALAR);
1512 indices[n] = info->subscript[n]->data.scalar.expr;
1520 index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
1523 gfc_trans_array_bound_check (se, info->descriptor, index, n);
1530 /* Get the index from the vector. */
1531 gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
1533 /* Put the descriptor back. */
1534 se->expr = descsave;
1540 /* Return the offset for an index. Performs bound checking for elemental
1541 dimensions. Single element references are processed separately. */
1544 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1545 gfc_array_ref * ar, tree stride)
1549 /* Get the index into the array for this dimension. */
1552 gcc_assert (ar->type != AR_ELEMENT);
1553 if (ar->dimen_type[dim] == DIMEN_ELEMENT)
1555 gcc_assert (i == -1);
1556 /* Elemental dimension. */
1557 gcc_assert (info->subscript[dim]
1558 && info->subscript[dim]->type == GFC_SS_SCALAR);
1559 /* We've already translated this value outside the loop. */
1560 index = info->subscript[dim]->data.scalar.expr;
1563 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1567 /* Scalarized dimension. */
1568 gcc_assert (info && se->loop);
1570 /* Multiply the loop variable by the stride and delta. */
1571 index = se->loop->loopvar[i];
1572 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1574 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1577 if (ar->dimen_type[dim] == DIMEN_VECTOR)
1579 /* Handle vector subscripts. */
1580 index = gfc_conv_vector_array_index (se, index,
1581 info->subscript[dim]);
1583 gfc_trans_array_bound_check (se, info->descriptor, index,
1587 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
1592 /* Temporary array or derived type component. */
1593 gcc_assert (se->loop);
1594 index = se->loop->loopvar[se->loop->order[i]];
1595 if (!integer_zerop (info->delta[i]))
1596 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1597 index, info->delta[i]);
1600 /* Multiply by the stride. */
1601 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1607 /* Build a scalarized reference to an array. */
1610 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1617 info = &se->ss->data.info;
1619 n = se->loop->order[0];
1623 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1625 /* Add the offset for this dimension to the stored offset for all other
1627 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1629 tmp = gfc_build_indirect_ref (info->data);
1630 se->expr = gfc_build_array_ref (tmp, index);
1634 /* Translate access of temporary array. */
1637 gfc_conv_tmp_array_ref (gfc_se * se)
1639 se->string_length = se->ss->string_length;
1640 gfc_conv_scalarized_array_ref (se, NULL);
1644 /* Build an array reference. se->expr already holds the array descriptor.
1645 This should be either a variable, indirect variable reference or component
1646 reference. For arrays which do not have a descriptor, se->expr will be
1648 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1651 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1660 /* Handle scalarized references separately. */
1661 if (ar->type != AR_ELEMENT)
1663 gfc_conv_scalarized_array_ref (se, ar);
1664 gfc_advance_se_ss_chain (se);
1668 index = gfc_index_zero_node;
1670 fault = gfc_index_zero_node;
1672 /* Calculate the offsets from all the dimensions. */
1673 for (n = 0; n < ar->dimen; n++)
1675 /* Calculate the index for this dimension. */
1676 gfc_init_se (&indexse, se);
1677 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1678 gfc_add_block_to_block (&se->pre, &indexse.pre);
1680 if (flag_bounds_check)
1682 /* Check array bounds. */
1685 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1687 tmp = gfc_conv_array_lbound (se->expr, n);
1688 cond = fold_build2 (LT_EXPR, boolean_type_node,
1691 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1693 tmp = gfc_conv_array_ubound (se->expr, n);
1694 cond = fold_build2 (GT_EXPR, boolean_type_node,
1697 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1700 /* Multiply the index by the stride. */
1701 stride = gfc_conv_array_stride (se->expr, n);
1702 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1705 /* And add it to the total. */
1706 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1709 if (flag_bounds_check)
1710 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1712 tmp = gfc_conv_array_offset (se->expr);
1713 if (!integer_zerop (tmp))
1714 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1716 /* Access the calculated element. */
1717 tmp = gfc_conv_array_data (se->expr);
1718 tmp = gfc_build_indirect_ref (tmp);
1719 se->expr = gfc_build_array_ref (tmp, index);
1723 /* Generate the code to be executed immediately before entering a
1724 scalarization loop. */
1727 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1728 stmtblock_t * pblock)
1737 /* This code will be executed before entering the scalarization loop
1738 for this dimension. */
1739 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1741 if ((ss->useflags & flag) == 0)
1744 if (ss->type != GFC_SS_SECTION
1745 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1746 && ss->type != GFC_SS_COMPONENT)
1749 info = &ss->data.info;
1751 if (dim >= info->dimen)
1754 if (dim == info->dimen - 1)
1756 /* For the outermost loop calculate the offset due to any
1757 elemental dimensions. It will have been initialized with the
1758 base offset of the array. */
1761 for (i = 0; i < info->ref->u.ar.dimen; i++)
1763 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1766 gfc_init_se (&se, NULL);
1768 se.expr = info->descriptor;
1769 stride = gfc_conv_array_stride (info->descriptor, i);
1770 index = gfc_conv_array_index_offset (&se, info, i, -1,
1773 gfc_add_block_to_block (pblock, &se.pre);
1775 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1776 info->offset, index);
1777 info->offset = gfc_evaluate_now (info->offset, pblock);
1781 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1784 stride = gfc_conv_array_stride (info->descriptor, 0);
1786 /* Calculate the stride of the innermost loop. Hopefully this will
1787 allow the backend optimizers to do their stuff more effectively.
1789 info->stride0 = gfc_evaluate_now (stride, pblock);
1793 /* Add the offset for the previous loop dimension. */
1798 ar = &info->ref->u.ar;
1799 i = loop->order[dim + 1];
1807 gfc_init_se (&se, NULL);
1809 se.expr = info->descriptor;
1810 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1811 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
1813 gfc_add_block_to_block (pblock, &se.pre);
1814 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1815 info->offset, index);
1816 info->offset = gfc_evaluate_now (info->offset, pblock);
1819 /* Remember this offset for the second loop. */
1820 if (dim == loop->temp_dim - 1)
1821 info->saved_offset = info->offset;
1826 /* Start a scalarized expression. Creates a scope and declares loop
1830 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
1836 gcc_assert (!loop->array_parameter);
1838 for (dim = loop->dimen - 1; dim >= 0; dim--)
1840 n = loop->order[dim];
1842 gfc_start_block (&loop->code[n]);
1844 /* Create the loop variable. */
1845 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
1847 if (dim < loop->temp_dim)
1851 /* Calculate values that will be constant within this loop. */
1852 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
1854 gfc_start_block (pbody);
1858 /* Generates the actual loop code for a scalarization loop. */
1861 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
1862 stmtblock_t * pbody)
1870 loopbody = gfc_finish_block (pbody);
1872 /* Initialize the loopvar. */
1873 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
1875 exit_label = gfc_build_label_decl (NULL_TREE);
1877 /* Generate the loop body. */
1878 gfc_init_block (&block);
1880 /* The exit condition. */
1881 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
1882 tmp = build1_v (GOTO_EXPR, exit_label);
1883 TREE_USED (exit_label) = 1;
1884 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1885 gfc_add_expr_to_block (&block, tmp);
1887 /* The main body. */
1888 gfc_add_expr_to_block (&block, loopbody);
1890 /* Increment the loopvar. */
1891 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1892 loop->loopvar[n], gfc_index_one_node);
1893 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
1895 /* Build the loop. */
1896 tmp = gfc_finish_block (&block);
1897 tmp = build1_v (LOOP_EXPR, tmp);
1898 gfc_add_expr_to_block (&loop->code[n], tmp);
1900 /* Add the exit label. */
1901 tmp = build1_v (LABEL_EXPR, exit_label);
1902 gfc_add_expr_to_block (&loop->code[n], tmp);
1906 /* Finishes and generates the loops for a scalarized expression. */
1909 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
1914 stmtblock_t *pblock;
1918 /* Generate the loops. */
1919 for (dim = 0; dim < loop->dimen; dim++)
1921 n = loop->order[dim];
1922 gfc_trans_scalarized_loop_end (loop, n, pblock);
1923 loop->loopvar[n] = NULL_TREE;
1924 pblock = &loop->code[n];
1927 tmp = gfc_finish_block (pblock);
1928 gfc_add_expr_to_block (&loop->pre, tmp);
1930 /* Clear all the used flags. */
1931 for (ss = loop->ss; ss; ss = ss->loop_chain)
1936 /* Finish the main body of a scalarized expression, and start the secondary
1940 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
1944 stmtblock_t *pblock;
1948 /* We finish as many loops as are used by the temporary. */
1949 for (dim = 0; dim < loop->temp_dim - 1; dim++)
1951 n = loop->order[dim];
1952 gfc_trans_scalarized_loop_end (loop, n, pblock);
1953 loop->loopvar[n] = NULL_TREE;
1954 pblock = &loop->code[n];
1957 /* We don't want to finish the outermost loop entirely. */
1958 n = loop->order[loop->temp_dim - 1];
1959 gfc_trans_scalarized_loop_end (loop, n, pblock);
1961 /* Restore the initial offsets. */
1962 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1964 if ((ss->useflags & 2) == 0)
1967 if (ss->type != GFC_SS_SECTION
1968 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1969 && ss->type != GFC_SS_COMPONENT)
1972 ss->data.info.offset = ss->data.info.saved_offset;
1975 /* Restart all the inner loops we just finished. */
1976 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
1978 n = loop->order[dim];
1980 gfc_start_block (&loop->code[n]);
1982 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
1984 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
1987 /* Start a block for the secondary copying code. */
1988 gfc_start_block (body);
1992 /* Calculate the upper bound of an array section. */
1995 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2004 gcc_assert (ss->type == GFC_SS_SECTION);
2006 /* For vector array subscripts we want the size of the vector. */
2007 dim = ss->data.info.dim[n];
2009 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2011 vecss = vecss->data.info.subscript[dim];
2012 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2013 dim = vecss->data.info.dim[0];
2016 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2017 end = vecss->data.info.ref->u.ar.end[dim];
2018 desc = vecss->data.info.descriptor;
2022 /* The upper bound was specified. */
2023 gfc_init_se (&se, NULL);
2024 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2025 gfc_add_block_to_block (pblock, &se.pre);
2030 /* No upper bound was specified, so use the bound of the array. */
2031 bound = gfc_conv_array_ubound (desc, dim);
2038 /* Calculate the lower bound of an array section. */
2041 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2051 info = &ss->data.info;
2055 /* For vector array subscripts we want the size of the vector. */
2057 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2059 vecss = vecss->data.info.subscript[dim];
2060 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2061 /* Get the descriptors for the vector subscripts as well. */
2062 if (!vecss->data.info.descriptor)
2063 gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
2064 dim = vecss->data.info.dim[0];
2067 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2068 start = vecss->data.info.ref->u.ar.start[dim];
2069 stride = vecss->data.info.ref->u.ar.stride[dim];
2070 desc = vecss->data.info.descriptor;
2072 /* Calculate the start of the range. For vector subscripts this will
2073 be the range of the vector. */
2076 /* Specified section start. */
2077 gfc_init_se (&se, NULL);
2078 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2079 gfc_add_block_to_block (&loop->pre, &se.pre);
2080 info->start[n] = se.expr;
2084 /* No lower bound specified so use the bound of the array. */
2085 info->start[n] = gfc_conv_array_lbound (desc, dim);
2087 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2089 /* Calculate the stride. */
2091 info->stride[n] = gfc_index_one_node;
2094 gfc_init_se (&se, NULL);
2095 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2096 gfc_add_block_to_block (&loop->pre, &se.pre);
2097 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2102 /* Calculates the range start and stride for a SS chain. Also gets the
2103 descriptor and data pointer. The range of vector subscripts is the size
2104 of the vector. Array bounds are also checked. */
2107 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2116 /* Determine the rank of the loop. */
2118 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2122 case GFC_SS_SECTION:
2123 case GFC_SS_CONSTRUCTOR:
2124 case GFC_SS_FUNCTION:
2125 case GFC_SS_COMPONENT:
2126 loop->dimen = ss->data.info.dimen;
2134 if (loop->dimen == 0)
2135 gfc_todo_error ("Unable to determine rank of expression");
2138 /* Loop over all the SS in the chain. */
2139 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2141 if (ss->expr && ss->expr->shape && !ss->shape)
2142 ss->shape = ss->expr->shape;
2146 case GFC_SS_SECTION:
2147 /* Get the descriptor for the array. */
2148 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2150 for (n = 0; n < ss->data.info.dimen; n++)
2151 gfc_conv_section_startstride (loop, ss, n);
2154 case GFC_SS_CONSTRUCTOR:
2155 case GFC_SS_FUNCTION:
2156 for (n = 0; n < ss->data.info.dimen; n++)
2158 ss->data.info.start[n] = gfc_index_zero_node;
2159 ss->data.info.stride[n] = gfc_index_one_node;
2168 /* The rest is just runtime bound checking. */
2169 if (flag_bounds_check)
2175 tree size[GFC_MAX_DIMENSIONS];
2179 gfc_start_block (&block);
2181 fault = integer_zero_node;
2182 for (n = 0; n < loop->dimen; n++)
2183 size[n] = NULL_TREE;
2185 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2187 if (ss->type != GFC_SS_SECTION)
2190 /* TODO: range checking for mapped dimensions. */
2191 info = &ss->data.info;
2193 /* This only checks scalarized dimensions, elemental dimensions are
2195 for (n = 0; n < loop->dimen; n++)
2199 while (vecss->data.info.ref->u.ar.dimen_type[dim]
2202 vecss = vecss->data.info.subscript[dim];
2203 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2204 dim = vecss->data.info.dim[0];
2206 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
2208 desc = vecss->data.info.descriptor;
2210 /* Check lower bound. */
2211 bound = gfc_conv_array_lbound (desc, dim);
2212 tmp = info->start[n];
2213 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2214 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2217 /* Check the upper bound. */
2218 bound = gfc_conv_array_ubound (desc, dim);
2219 end = gfc_conv_section_upper_bound (ss, n, &block);
2220 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2221 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2224 /* Check the section sizes match. */
2225 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2227 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2229 /* We remember the size of the first section, and check all the
2230 others against this. */
2234 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2236 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2239 size[n] = gfc_evaluate_now (tmp, &block);
2242 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2244 tmp = gfc_finish_block (&block);
2245 gfc_add_expr_to_block (&loop->pre, tmp);
2250 /* Return true if the two SS could be aliased, i.e. both point to the same data
2252 /* TODO: resolve aliases based on frontend expressions. */
2255 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2262 lsym = lss->expr->symtree->n.sym;
2263 rsym = rss->expr->symtree->n.sym;
2264 if (gfc_symbols_could_alias (lsym, rsym))
2267 if (rsym->ts.type != BT_DERIVED
2268 && lsym->ts.type != BT_DERIVED)
2271 /* For derived types we must check all the component types. We can ignore
2272 array references as these will have the same base type as the previous
2274 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2276 if (lref->type != REF_COMPONENT)
2279 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2282 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2285 if (rref->type != REF_COMPONENT)
2288 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2293 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2295 if (rref->type != REF_COMPONENT)
2298 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2306 /* Resolve array data dependencies. Creates a temporary if required. */
2307 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2311 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2321 loop->temp_ss = NULL;
2322 aref = dest->data.info.ref;
2325 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2327 if (ss->type != GFC_SS_SECTION)
2330 if (gfc_could_be_alias (dest, ss))
2336 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2338 lref = dest->expr->ref;
2339 rref = ss->expr->ref;
2341 nDepend = gfc_dep_resolver (lref, rref);
2343 /* TODO : loop shifting. */
2346 /* Mark the dimensions for LOOP SHIFTING */
2347 for (n = 0; n < loop->dimen; n++)
2349 int dim = dest->data.info.dim[n];
2351 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2353 else if (! gfc_is_same_range (&lref->u.ar,
2354 &rref->u.ar, dim, 0))
2358 /* Put all the dimensions with dependencies in the
2361 for (n = 0; n < loop->dimen; n++)
2363 gcc_assert (loop->order[n] == n);
2365 loop->order[dim++] = n;
2368 for (n = 0; n < loop->dimen; n++)
2371 loop->order[dim++] = n;
2374 gcc_assert (dim == loop->dimen);
2383 loop->temp_ss = gfc_get_ss ();
2384 loop->temp_ss->type = GFC_SS_TEMP;
2385 loop->temp_ss->data.temp.type =
2386 gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
2387 loop->temp_ss->string_length = dest->string_length;
2388 loop->temp_ss->data.temp.dimen = loop->dimen;
2389 loop->temp_ss->next = gfc_ss_terminator;
2390 gfc_add_ss_to_loop (loop, loop->temp_ss);
2393 loop->temp_ss = NULL;
2397 /* Initialize the scalarization loop. Creates the loop variables. Determines
2398 the range of the loop variables. Creates a temporary if required.
2399 Calculates how to transform from loop variables to array indices for each
2400 expression. Also generates code for scalar expressions which have been
2401 moved outside the loop. */
2404 gfc_conv_loop_setup (gfc_loopinfo * loop)
2409 gfc_ss_info *specinfo;
2413 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2418 for (n = 0; n < loop->dimen; n++)
2421 /* We use one SS term, and use that to determine the bounds of the
2422 loop for this dimension. We try to pick the simplest term. */
2423 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2427 /* The frontend has worked out the size for us. */
2432 if (ss->type == GFC_SS_CONSTRUCTOR)
2434 /* An unknown size constructor will always be rank one.
2435 Higher rank constructors will either have known shape,
2436 or still be wrapped in a call to reshape. */
2437 gcc_assert (loop->dimen == 1);
2438 /* Try to figure out the size of the constructor. */
2439 /* TODO: avoid this by making the frontend set the shape. */
2440 gfc_get_array_cons_size (&i, ss->expr->value.constructor);
2441 /* A negative value means we failed. */
2442 if (mpz_sgn (i) > 0)
2444 mpz_sub_ui (i, i, 1);
2446 gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2452 /* TODO: Pick the best bound if we have a choice between a
2453 function and something else. */
2454 if (ss->type == GFC_SS_FUNCTION)
2460 if (ss->type != GFC_SS_SECTION)
2464 specinfo = &loopspec[n]->data.info;
2467 info = &ss->data.info;
2469 /* Criteria for choosing a loop specifier (most important first):
2477 /* TODO: Is != constructor correct? */
2478 else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
2480 if (integer_onep (info->stride[n])
2481 && !integer_onep (specinfo->stride[n]))
2483 else if (INTEGER_CST_P (info->stride[n])
2484 && !INTEGER_CST_P (specinfo->stride[n]))
2486 else if (INTEGER_CST_P (info->start[n])
2487 && !INTEGER_CST_P (specinfo->start[n]))
2489 /* We don't work out the upper bound.
2490 else if (INTEGER_CST_P (info->finish[n])
2491 && ! INTEGER_CST_P (specinfo->finish[n]))
2492 loopspec[n] = ss; */
2497 gfc_todo_error ("Unable to find scalarization loop specifier");
2499 info = &loopspec[n]->data.info;
2501 /* Set the extents of this range. */
2502 cshape = loopspec[n]->shape;
2503 if (cshape && INTEGER_CST_P (info->start[n])
2504 && INTEGER_CST_P (info->stride[n]))
2506 loop->from[n] = info->start[n];
2507 mpz_set (i, cshape[n]);
2508 mpz_sub_ui (i, i, 1);
2509 /* To = from + (size - 1) * stride. */
2510 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2511 if (!integer_onep (info->stride[n]))
2512 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2513 tmp, info->stride[n]);
2514 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2515 loop->from[n], tmp);
2519 loop->from[n] = info->start[n];
2520 switch (loopspec[n]->type)
2522 case GFC_SS_CONSTRUCTOR:
2523 gcc_assert (info->dimen == 1);
2524 gcc_assert (loop->to[n]);
2527 case GFC_SS_SECTION:
2528 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2532 case GFC_SS_FUNCTION:
2533 /* The loop bound will be set when we generate the call. */
2534 gcc_assert (loop->to[n] == NULL_TREE);
2542 /* Transform everything so we have a simple incrementing variable. */
2543 if (integer_onep (info->stride[n]))
2544 info->delta[n] = gfc_index_zero_node;
2547 /* Set the delta for this section. */
2548 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2549 /* Number of iterations is (end - start + step) / step.
2550 with start = 0, this simplifies to
2552 for (i = 0; i<=last; i++){...}; */
2553 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2554 loop->to[n], loop->from[n]);
2555 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2556 tmp, info->stride[n]);
2557 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2558 /* Make the loop variable start at 0. */
2559 loop->from[n] = gfc_index_zero_node;
2563 /* Add all the scalar code that can be taken out of the loops.
2564 This may include calculating the loop bounds, so do it before
2565 allocating the temporary. */
2566 gfc_add_loop_ss_code (loop, loop->ss, false);
2568 /* If we want a temporary then create it. */
2569 if (loop->temp_ss != NULL)
2571 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2572 tmp = loop->temp_ss->data.temp.type;
2573 len = loop->temp_ss->string_length;
2574 n = loop->temp_ss->data.temp.dimen;
2575 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2576 loop->temp_ss->type = GFC_SS_SECTION;
2577 loop->temp_ss->data.info.dimen = n;
2578 gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
2581 for (n = 0; n < loop->temp_dim; n++)
2582 loopspec[loop->order[n]] = NULL;
2586 /* For array parameters we don't have loop variables, so don't calculate the
2588 if (loop->array_parameter)
2591 /* Calculate the translation from loop variables to array indices. */
2592 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2594 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2597 info = &ss->data.info;
2599 for (n = 0; n < info->dimen; n++)
2603 /* If we are specifying the range the delta is already set. */
2604 if (loopspec[n] != ss)
2606 /* Calculate the offset relative to the loop variable.
2607 First multiply by the stride. */
2608 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2609 loop->from[n], info->stride[n]);
2611 /* Then subtract this from our starting value. */
2612 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2613 info->start[n], tmp);
2615 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2622 /* Fills in an array descriptor, and returns the size of the array. The size
2623 will be a simple_val, ie a variable or a constant. Also calculates the
2624 offset of the base. Returns the size of the array.
2628 for (n = 0; n < rank; n++)
2630 a.lbound[n] = specified_lower_bound;
2631 offset = offset + a.lbond[n] * stride;
2633 a.ubound[n] = specified_upper_bound;
2634 a.stride[n] = stride;
2635 size = ubound + size; //size = ubound + 1 - lbound
2636 stride = stride * size;
2643 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2644 gfc_expr ** lower, gfc_expr ** upper,
2645 stmtblock_t * pblock)
2656 type = TREE_TYPE (descriptor);
2658 stride = gfc_index_one_node;
2659 offset = gfc_index_zero_node;
2661 /* Set the dtype. */
2662 tmp = gfc_conv_descriptor_dtype (descriptor);
2663 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2665 for (n = 0; n < rank; n++)
2667 /* We have 3 possibilities for determining the size of the array:
2668 lower == NULL => lbound = 1, ubound = upper[n]
2669 upper[n] = NULL => lbound = 1, ubound = lower[n]
2670 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2673 /* Set lower bound. */
2674 gfc_init_se (&se, NULL);
2676 se.expr = gfc_index_one_node;
2679 gcc_assert (lower[n]);
2682 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2683 gfc_add_block_to_block (pblock, &se.pre);
2687 se.expr = gfc_index_one_node;
2691 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2692 gfc_add_modify_expr (pblock, tmp, se.expr);
2694 /* Work out the offset for this component. */
2695 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2696 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2698 /* Start the calculation for the size of this dimension. */
2699 size = build2 (MINUS_EXPR, gfc_array_index_type,
2700 gfc_index_one_node, se.expr);
2702 /* Set upper bound. */
2703 gfc_init_se (&se, NULL);
2704 gcc_assert (ubound);
2705 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2706 gfc_add_block_to_block (pblock, &se.pre);
2708 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2709 gfc_add_modify_expr (pblock, tmp, se.expr);
2711 /* Store the stride. */
2712 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2713 gfc_add_modify_expr (pblock, tmp, stride);
2715 /* Calculate the size of this dimension. */
2716 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2718 /* Multiply the stride by the number of elements in this dimension. */
2719 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2720 stride = gfc_evaluate_now (stride, pblock);
2723 /* The stride is the number of elements in the array, so multiply by the
2724 size of an element to get the total size. */
2725 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2726 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2728 if (poffset != NULL)
2730 offset = gfc_evaluate_now (offset, pblock);
2734 size = gfc_evaluate_now (size, pblock);
2739 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2740 the work for an ALLOCATE statement. */
2744 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2754 /* Figure out the size of the array. */
2755 switch (ref->u.ar.type)
2759 upper = ref->u.ar.start;
2763 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2765 lower = ref->u.ar.as->lower;
2766 upper = ref->u.ar.as->upper;
2770 lower = ref->u.ar.start;
2771 upper = ref->u.ar.end;
2779 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2780 lower, upper, &se->pre);
2782 /* Allocate memory to store the data. */
2783 tmp = gfc_conv_descriptor_data_addr (se->expr);
2784 pointer = gfc_evaluate_now (tmp, &se->pre);
2786 if (TYPE_PRECISION (gfc_array_index_type) == 32)
2787 allocate = gfor_fndecl_allocate;
2788 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2789 allocate = gfor_fndecl_allocate64;
2793 tmp = gfc_chainon_list (NULL_TREE, pointer);
2794 tmp = gfc_chainon_list (tmp, size);
2795 tmp = gfc_chainon_list (tmp, pstat);
2796 tmp = gfc_build_function_call (allocate, tmp);
2797 gfc_add_expr_to_block (&se->pre, tmp);
2799 tmp = gfc_conv_descriptor_offset (se->expr);
2800 gfc_add_modify_expr (&se->pre, tmp, offset);
2804 /* Deallocate an array variable. Also used when an allocated variable goes
2809 gfc_array_deallocate (tree descriptor, tree pstat)
2815 gfc_start_block (&block);
2816 /* Get a pointer to the data. */
2817 tmp = gfc_conv_descriptor_data_addr (descriptor);
2818 var = gfc_evaluate_now (tmp, &block);
2820 /* Parameter is the address of the data component. */
2821 tmp = gfc_chainon_list (NULL_TREE, var);
2822 tmp = gfc_chainon_list (tmp, pstat);
2823 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2824 gfc_add_expr_to_block (&block, tmp);
2826 return gfc_finish_block (&block);
2830 /* Create an array constructor from an initialization expression.
2831 We assume the frontend already did any expansions and conversions. */
2834 gfc_conv_array_initializer (tree type, gfc_expr * expr)
2841 unsigned HOST_WIDE_INT lo;
2843 VEC(constructor_elt,gc) *v = NULL;
2845 switch (expr->expr_type)
2848 case EXPR_STRUCTURE:
2849 /* A single scalar or derived type value. Create an array with all
2850 elements equal to that value. */
2851 gfc_init_se (&se, NULL);
2853 if (expr->expr_type == EXPR_CONSTANT)
2854 gfc_conv_constant (&se, expr);
2856 gfc_conv_structure (&se, expr, 1);
2858 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2859 gcc_assert (tmp && INTEGER_CST_P (tmp));
2860 hi = TREE_INT_CST_HIGH (tmp);
2861 lo = TREE_INT_CST_LOW (tmp);
2865 /* This will probably eat buckets of memory for large arrays. */
2866 while (hi != 0 || lo != 0)
2868 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
2876 /* Create a vector of all the elements. */
2877 for (c = expr->value.constructor; c; c = c->next)
2881 /* Problems occur when we get something like
2882 integer :: a(lots) = (/(i, i=1,lots)/) */
2883 /* TODO: Unexpanded array initializers. */
2885 ("Possible frontend bug: array constructor not expanded");
2887 if (mpz_cmp_si (c->n.offset, 0) != 0)
2888 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2892 if (mpz_cmp_si (c->repeat, 0) != 0)
2896 mpz_set (maxval, c->repeat);
2897 mpz_add (maxval, c->n.offset, maxval);
2898 mpz_sub_ui (maxval, maxval, 1);
2899 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2900 if (mpz_cmp_si (c->n.offset, 0) != 0)
2902 mpz_add_ui (maxval, c->n.offset, 1);
2903 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2906 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2908 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
2914 gfc_init_se (&se, NULL);
2915 switch (c->expr->expr_type)
2918 gfc_conv_constant (&se, c->expr);
2919 if (range == NULL_TREE)
2920 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
2923 if (index != NULL_TREE)
2924 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
2925 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
2929 case EXPR_STRUCTURE:
2930 gfc_conv_structure (&se, c->expr, 1);
2931 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
2944 /* Create a constructor from the list of elements. */
2945 tmp = build_constructor (type, v);
2946 TREE_CONSTANT (tmp) = 1;
2947 TREE_INVARIANT (tmp) = 1;
2952 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2953 returns the size (in elements) of the array. */
2956 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
2957 stmtblock_t * pblock)
2972 size = gfc_index_one_node;
2973 offset = gfc_index_zero_node;
2974 for (dim = 0; dim < as->rank; dim++)
2976 /* Evaluate non-constant array bound expressions. */
2977 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
2978 if (as->lower[dim] && !INTEGER_CST_P (lbound))
2980 gfc_init_se (&se, NULL);
2981 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
2982 gfc_add_block_to_block (pblock, &se.pre);
2983 gfc_add_modify_expr (pblock, lbound, se.expr);
2985 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
2986 if (as->upper[dim] && !INTEGER_CST_P (ubound))
2988 gfc_init_se (&se, NULL);
2989 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
2990 gfc_add_block_to_block (pblock, &se.pre);
2991 gfc_add_modify_expr (pblock, ubound, se.expr);
2993 /* The offset of this dimension. offset = offset - lbound * stride. */
2994 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
2995 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2997 /* The size of this dimension, and the stride of the next. */
2998 if (dim + 1 < as->rank)
2999 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3003 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3005 /* Calculate stride = size * (ubound + 1 - lbound). */
3006 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3007 gfc_index_one_node, lbound);
3008 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3009 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3011 gfc_add_modify_expr (pblock, stride, tmp);
3013 stride = gfc_evaluate_now (tmp, pblock);
3024 /* Generate code to initialize/allocate an array variable. */
3027 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3037 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3039 /* Do nothing for USEd variables. */
3040 if (sym->attr.use_assoc)
3043 type = TREE_TYPE (decl);
3044 gcc_assert (GFC_ARRAY_TYPE_P (type));
3045 onstack = TREE_CODE (type) != POINTER_TYPE;
3047 gfc_start_block (&block);
3049 /* Evaluate character string length. */
3050 if (sym->ts.type == BT_CHARACTER
3051 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3053 gfc_trans_init_string_length (sym->ts.cl, &block);
3055 /* Emit a DECL_EXPR for this variable, which will cause the
3056 gimplifier to allocate storage, and all that good stuff. */
3057 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3058 gfc_add_expr_to_block (&block, tmp);
3063 gfc_add_expr_to_block (&block, fnbody);
3064 return gfc_finish_block (&block);
3067 type = TREE_TYPE (type);
3069 gcc_assert (!sym->attr.use_assoc);
3070 gcc_assert (!TREE_STATIC (decl));
3071 gcc_assert (!sym->module);
3073 if (sym->ts.type == BT_CHARACTER
3074 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3075 gfc_trans_init_string_length (sym->ts.cl, &block);
3077 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3079 /* The size is the number of elements in the array, so multiply by the
3080 size of an element to get the total size. */
3081 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3082 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3084 /* Allocate memory to hold the data. */
3085 tmp = gfc_chainon_list (NULL_TREE, size);
3087 if (gfc_index_integer_kind == 4)
3088 fndecl = gfor_fndecl_internal_malloc;
3089 else if (gfc_index_integer_kind == 8)
3090 fndecl = gfor_fndecl_internal_malloc64;
3093 tmp = gfc_build_function_call (fndecl, tmp);
3094 tmp = fold (convert (TREE_TYPE (decl), tmp));
3095 gfc_add_modify_expr (&block, decl, tmp);
3097 /* Set offset of the array. */
3098 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3099 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3102 /* Automatic arrays should not have initializers. */
3103 gcc_assert (!sym->value);
3105 gfc_add_expr_to_block (&block, fnbody);
3107 /* Free the temporary. */
3108 tmp = convert (pvoid_type_node, decl);
3109 tmp = gfc_chainon_list (NULL_TREE, tmp);
3110 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3111 gfc_add_expr_to_block (&block, tmp);
3113 return gfc_finish_block (&block);
3117 /* Generate entry and exit code for g77 calling convention arrays. */
3120 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3129 gfc_get_backend_locus (&loc);
3130 gfc_set_backend_locus (&sym->declared_at);
3132 /* Descriptor type. */
3133 parm = sym->backend_decl;
3134 type = TREE_TYPE (parm);
3135 gcc_assert (GFC_ARRAY_TYPE_P (type));
3137 gfc_start_block (&block);
3139 if (sym->ts.type == BT_CHARACTER
3140 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3141 gfc_trans_init_string_length (sym->ts.cl, &block);
3143 /* Evaluate the bounds of the array. */
3144 gfc_trans_array_bounds (type, sym, &offset, &block);
3146 /* Set the offset. */
3147 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3148 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3150 /* Set the pointer itself if we aren't using the parameter directly. */
3151 if (TREE_CODE (parm) != PARM_DECL)
3153 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3154 gfc_add_modify_expr (&block, parm, tmp);
3156 tmp = gfc_finish_block (&block);
3158 gfc_set_backend_locus (&loc);
3160 gfc_start_block (&block);
3161 /* Add the initialization code to the start of the function. */
3162 gfc_add_expr_to_block (&block, tmp);
3163 gfc_add_expr_to_block (&block, body);
3165 return gfc_finish_block (&block);
3169 /* Modify the descriptor of an array parameter so that it has the
3170 correct lower bound. Also move the upper bound accordingly.
3171 If the array is not packed, it will be copied into a temporary.
3172 For each dimension we set the new lower and upper bounds. Then we copy the
3173 stride and calculate the offset for this dimension. We also work out
3174 what the stride of a packed array would be, and see it the two match.
3175 If the array need repacking, we set the stride to the values we just
3176 calculated, recalculate the offset and copy the array data.
3177 Code is also added to copy the data back at the end of the function.
3181 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3188 stmtblock_t cleanup;
3206 /* Do nothing for pointer and allocatable arrays. */
3207 if (sym->attr.pointer || sym->attr.allocatable)
3210 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3211 return gfc_trans_g77_array (sym, body);
3213 gfc_get_backend_locus (&loc);
3214 gfc_set_backend_locus (&sym->declared_at);
3216 /* Descriptor type. */
3217 type = TREE_TYPE (tmpdesc);
3218 gcc_assert (GFC_ARRAY_TYPE_P (type));
3219 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3220 dumdesc = gfc_build_indirect_ref (dumdesc);
3221 gfc_start_block (&block);
3223 if (sym->ts.type == BT_CHARACTER
3224 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3225 gfc_trans_init_string_length (sym->ts.cl, &block);
3227 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3229 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3230 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3232 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3234 /* For non-constant shape arrays we only check if the first dimension
3235 is contiguous. Repacking higher dimensions wouldn't gain us
3236 anything as we still don't know the array stride. */
3237 partial = gfc_create_var (boolean_type_node, "partial");
3238 TREE_USED (partial) = 1;
3239 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3240 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3241 gfc_add_modify_expr (&block, partial, tmp);
3245 partial = NULL_TREE;
3248 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3249 here, however I think it does the right thing. */
3252 /* Set the first stride. */
3253 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3254 stride = gfc_evaluate_now (stride, &block);
3256 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3257 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3258 gfc_index_one_node, stride);
3259 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3260 gfc_add_modify_expr (&block, stride, tmp);
3262 /* Allow the user to disable array repacking. */
3263 stmt_unpacked = NULL_TREE;
3267 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3268 /* A library call to repack the array if necessary. */
3269 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3270 tmp = gfc_chainon_list (NULL_TREE, tmp);
3271 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3273 stride = gfc_index_one_node;
3276 /* This is for the case where the array data is used directly without
3277 calling the repack function. */
3278 if (no_repack || partial != NULL_TREE)
3279 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3281 stmt_packed = NULL_TREE;
3283 /* Assign the data pointer. */
3284 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3286 /* Don't repack unknown shape arrays when the first stride is 1. */
3287 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3288 stmt_packed, stmt_unpacked);
3291 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3292 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3294 offset = gfc_index_zero_node;
3295 size = gfc_index_one_node;
3297 /* Evaluate the bounds of the array. */
3298 for (n = 0; n < sym->as->rank; n++)
3300 if (checkparm || !sym->as->upper[n])
3302 /* Get the bounds of the actual parameter. */
3303 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3304 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3308 dubound = NULL_TREE;
3309 dlbound = NULL_TREE;
3312 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3313 if (!INTEGER_CST_P (lbound))
3315 gfc_init_se (&se, NULL);
3316 gfc_conv_expr_type (&se, sym->as->upper[n],
3317 gfc_array_index_type);
3318 gfc_add_block_to_block (&block, &se.pre);
3319 gfc_add_modify_expr (&block, lbound, se.expr);
3322 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3323 /* Set the desired upper bound. */
3324 if (sym->as->upper[n])
3326 /* We know what we want the upper bound to be. */
3327 if (!INTEGER_CST_P (ubound))
3329 gfc_init_se (&se, NULL);
3330 gfc_conv_expr_type (&se, sym->as->upper[n],
3331 gfc_array_index_type);
3332 gfc_add_block_to_block (&block, &se.pre);
3333 gfc_add_modify_expr (&block, ubound, se.expr);
3336 /* Check the sizes match. */
3339 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3341 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3343 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3345 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3346 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3351 /* For assumed shape arrays move the upper bound by the same amount
3352 as the lower bound. */
3353 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3354 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3355 gfc_add_modify_expr (&block, ubound, tmp);
3357 /* The offset of this dimension. offset = offset - lbound * stride. */
3358 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3359 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3361 /* The size of this dimension, and the stride of the next. */
3362 if (n + 1 < sym->as->rank)
3364 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3366 if (no_repack || partial != NULL_TREE)
3369 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3372 /* Figure out the stride if not a known constant. */
3373 if (!INTEGER_CST_P (stride))
3376 stmt_packed = NULL_TREE;
3379 /* Calculate stride = size * (ubound + 1 - lbound). */
3380 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3381 gfc_index_one_node, lbound);
3382 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3384 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3389 /* Assign the stride. */
3390 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3391 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3392 stmt_unpacked, stmt_packed);
3394 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3395 gfc_add_modify_expr (&block, stride, tmp);
3400 /* Set the offset. */
3401 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3402 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3404 stmt = gfc_finish_block (&block);
3406 gfc_start_block (&block);
3408 /* Only do the entry/initialization code if the arg is present. */
3409 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3410 optional_arg = (sym->attr.optional
3411 || (sym->ns->proc_name->attr.entry_master
3412 && sym->attr.dummy));
3415 tmp = gfc_conv_expr_present (sym);
3416 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3418 gfc_add_expr_to_block (&block, stmt);
3420 /* Add the main function body. */
3421 gfc_add_expr_to_block (&block, body);
3426 gfc_start_block (&cleanup);
3428 if (sym->attr.intent != INTENT_IN)
3430 /* Copy the data back. */
3431 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3432 tmp = gfc_chainon_list (tmp, tmpdesc);
3433 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3434 gfc_add_expr_to_block (&cleanup, tmp);
3437 /* Free the temporary. */
3438 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3439 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3440 gfc_add_expr_to_block (&cleanup, tmp);
3442 stmt = gfc_finish_block (&cleanup);
3444 /* Only do the cleanup if the array was repacked. */
3445 tmp = gfc_build_indirect_ref (dumdesc);
3446 tmp = gfc_conv_descriptor_data_get (tmp);
3447 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3448 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3452 tmp = gfc_conv_expr_present (sym);
3453 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3455 gfc_add_expr_to_block (&block, stmt);
3457 /* We don't need to free any memory allocated by internal_pack as it will
3458 be freed at the end of the function by pop_context. */
3459 return gfc_finish_block (&block);
3463 /* Convert an array for passing as an actual parameter. Expressions and
3464 vector subscripts are evaluated and stored in a temporary, which is then
3465 passed. For whole arrays the descriptor is passed. For array sections
3466 a modified copy of the descriptor is passed, but using the original data.
3467 Also used for array pointer assignments by setting se->direct_byref. */
3470 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3486 gcc_assert (ss != gfc_ss_terminator);
3488 /* TODO: Pass constant array constructors without a temporary. */
3489 /* Special case things we know we can pass easily. */
3490 switch (expr->expr_type)
3493 /* If we have a linear array section, we can pass it directly.
3494 Otherwise we need to copy it into a temporary. */
3496 /* Find the SS for the array section. */
3498 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3499 secss = secss->next;
3501 gcc_assert (secss != gfc_ss_terminator);
3504 for (n = 0; n < secss->data.info.dimen; n++)
3506 vss = secss->data.info.subscript[secss->data.info.dim[n]];
3507 if (vss && vss->type == GFC_SS_VECTOR)
3511 info = &secss->data.info;
3513 /* Get the descriptor for the array. */
3514 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3515 desc = info->descriptor;
3516 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3518 /* Create a new descriptor if the array doesn't have one. */
3521 else if (info->ref->u.ar.type == AR_FULL)
3523 else if (se->direct_byref)
3528 gcc_assert (ref->u.ar.type == AR_SECTION);
3531 for (n = 0; n < ref->u.ar.dimen; n++)
3533 /* Detect passing the full array as a section. This could do
3534 even more checking, but it doesn't seem worth it. */
3535 if (ref->u.ar.start[n]
3537 || (ref->u.ar.stride[n]
3538 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3546 /* Check for substring references. */
3548 if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
3552 if (ref->type == REF_SUBSTRING)
3554 /* In general character substrings need a copy. Character
3555 array strides are expressed as multiples of the element
3556 size (consistent with other array types), not in
3565 if (se->direct_byref)
3567 /* Copy the descriptor for pointer assignments. */
3568 gfc_add_modify_expr (&se->pre, se->expr, desc);
3570 else if (se->want_pointer)
3572 /* We pass full arrays directly. This means that pointers and
3573 allocatable arrays should also work. */
3574 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3581 if (expr->ts.type == BT_CHARACTER)
3582 se->string_length = gfc_get_expr_charlen (expr);
3589 /* A transformational function return value will be a temporary
3590 array descriptor. We still need to go through the scalarizer
3591 to create the descriptor. Elemental functions ar handled as
3592 arbitrary expressions, i.e. copy to a temporary. */
3594 /* Look for the SS for this function. */
3595 while (secss != gfc_ss_terminator
3596 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3597 secss = secss->next;
3599 if (se->direct_byref)
3601 gcc_assert (secss != gfc_ss_terminator);
3603 /* For pointer assignments pass the descriptor directly. */
3605 se->expr = gfc_build_addr_expr (NULL, se->expr);
3606 gfc_conv_expr (se, expr);
3610 if (secss == gfc_ss_terminator)
3612 /* Elemental function. */
3618 /* Transformational function. */
3619 info = &secss->data.info;
3625 /* Something complicated. Copy it into a temporary. */
3633 gfc_init_loopinfo (&loop);
3635 /* Associate the SS with the loop. */
3636 gfc_add_ss_to_loop (&loop, ss);
3638 /* Tell the scalarizer not to bother creating loop variables, etc. */
3640 loop.array_parameter = 1;
3642 gcc_assert (se->want_pointer && !se->direct_byref);
3644 /* Setup the scalarizing loops and bounds. */
3645 gfc_conv_ss_startstride (&loop);
3649 /* Tell the scalarizer to make a temporary. */
3650 loop.temp_ss = gfc_get_ss ();
3651 loop.temp_ss->type = GFC_SS_TEMP;
3652 loop.temp_ss->next = gfc_ss_terminator;
3653 if (expr->ts.type == BT_CHARACTER)
3655 gcc_assert (expr->ts.cl && expr->ts.cl->length
3656 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3657 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3658 (expr->ts.cl->length->value.integer,
3659 expr->ts.cl->length->ts.kind);
3660 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3662 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3664 /* ... which can hold our string, if present. */
3665 if (expr->ts.type == BT_CHARACTER)
3667 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3668 se->string_length = loop.temp_ss->string_length;
3671 loop.temp_ss->string_length = NULL;
3672 loop.temp_ss->data.temp.dimen = loop.dimen;
3673 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3676 gfc_conv_loop_setup (&loop);
3680 /* Copy into a temporary and pass that. We don't need to copy the data
3681 back because expressions and vector subscripts must be INTENT_IN. */
3682 /* TODO: Optimize passing function return values. */
3686 /* Start the copying loops. */
3687 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3688 gfc_mark_ss_chain_used (ss, 1);
3689 gfc_start_scalarized_body (&loop, &block);
3691 /* Copy each data element. */
3692 gfc_init_se (&lse, NULL);
3693 gfc_copy_loopinfo_to_se (&lse, &loop);
3694 gfc_init_se (&rse, NULL);
3695 gfc_copy_loopinfo_to_se (&rse, &loop);
3697 lse.ss = loop.temp_ss;
3700 gfc_conv_scalarized_array_ref (&lse, NULL);
3701 if (expr->ts.type == BT_CHARACTER)
3703 gfc_conv_expr (&rse, expr);
3704 rse.expr = gfc_build_indirect_ref (rse.expr);
3707 gfc_conv_expr_val (&rse, expr);
3709 gfc_add_block_to_block (&block, &rse.pre);
3710 gfc_add_block_to_block (&block, &lse.pre);
3712 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3714 /* Finish the copying loops. */
3715 gfc_trans_scalarizing_loops (&loop, &block);
3717 /* Set the first stride component to zero to indicate a temporary. */
3718 desc = loop.temp_ss->data.info.descriptor;
3719 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3720 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3722 gcc_assert (is_gimple_lvalue (desc));
3723 se->expr = gfc_build_addr_expr (NULL, desc);
3725 else if (expr->expr_type == EXPR_FUNCTION)
3727 desc = info->descriptor;
3729 if (se->want_pointer)
3730 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3734 if (expr->ts.type == BT_CHARACTER)
3735 se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
3739 /* We pass sections without copying to a temporary. Make a new
3740 descriptor and point it at the section we want. The loop variable
3741 limits will be the limits of the section.
3742 A function may decide to repack the array to speed up access, but
3743 we're not bothered about that here. */
3752 /* Set the string_length for a character array. */
3753 if (expr->ts.type == BT_CHARACTER)
3754 se->string_length = gfc_get_expr_charlen (expr);
3756 desc = info->descriptor;
3757 gcc_assert (secss && secss != gfc_ss_terminator);
3758 if (se->direct_byref)
3760 /* For pointer assignments we fill in the destination. */
3762 parmtype = TREE_TYPE (parm);
3766 /* Otherwise make a new one. */
3767 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3768 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3769 loop.from, loop.to, 0);
3770 parm = gfc_create_var (parmtype, "parm");
3773 offset = gfc_index_zero_node;
3776 /* The following can be somewhat confusing. We have two
3777 descriptors, a new one and the original array.
3778 {parm, parmtype, dim} refer to the new one.
3779 {desc, type, n, secss, loop} refer to the original, which maybe
3780 a descriptorless array.
3781 The bounds of the scalarization are the bounds of the section.
3782 We don't have to worry about numeric overflows when calculating
3783 the offsets because all elements are within the array data. */
3785 /* Set the dtype. */
3786 tmp = gfc_conv_descriptor_dtype (parm);
3787 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
3789 if (se->direct_byref)
3790 base = gfc_index_zero_node;
3794 for (n = 0; n < info->ref->u.ar.dimen; n++)
3796 stride = gfc_conv_array_stride (desc, n);
3798 /* Work out the offset. */
3799 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3801 gcc_assert (info->subscript[n]
3802 && info->subscript[n]->type == GFC_SS_SCALAR);
3803 start = info->subscript[n]->data.scalar.expr;
3807 /* Check we haven't somehow got out of sync. */
3808 gcc_assert (info->dim[dim] == n);
3810 /* Evaluate and remember the start of the section. */
3811 start = info->start[dim];
3812 stride = gfc_evaluate_now (stride, &loop.pre);
3815 tmp = gfc_conv_array_lbound (desc, n);
3816 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
3818 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
3819 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
3821 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3823 /* For elemental dimensions, we only need the offset. */
3827 /* Vector subscripts need copying and are handled elsewhere. */
3828 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
3830 /* Set the new lower bound. */
3831 from = loop.from[dim];
3833 if (!integer_onep (from))
3835 /* Make sure the new section starts at 1. */
3836 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3837 gfc_index_one_node, from);
3838 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
3839 from = gfc_index_one_node;
3841 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
3842 gfc_add_modify_expr (&loop.pre, tmp, from);
3844 /* Set the new upper bound. */
3845 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
3846 gfc_add_modify_expr (&loop.pre, tmp, to);
3848 /* Multiply the stride by the section stride to get the
3850 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
3851 stride, info->stride[dim]);
3853 if (se->direct_byref)
3854 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
3857 /* Store the new stride. */
3858 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
3859 gfc_add_modify_expr (&loop.pre, tmp, stride);
3864 /* Point the data pointer at the first element in the section. */
3865 tmp = gfc_conv_array_data (desc);
3866 tmp = gfc_build_indirect_ref (tmp);
3867 tmp = gfc_build_array_ref (tmp, offset);
3868 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
3869 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
3871 if (se->direct_byref)
3873 /* Set the offset. */
3874 tmp = gfc_conv_descriptor_offset (parm);
3875 gfc_add_modify_expr (&loop.pre, tmp, base);
3879 /* Only the callee knows what the correct offset it, so just set
3881 tmp = gfc_conv_descriptor_offset (parm);
3882 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3885 if (!se->direct_byref)
3887 /* Get a pointer to the new descriptor. */
3888 if (se->want_pointer)
3889 se->expr = gfc_build_addr_expr (NULL, parm);
3895 gfc_add_block_to_block (&se->pre, &loop.pre);
3896 gfc_add_block_to_block (&se->post, &loop.post);
3898 /* Cleanup the scalarizer. */
3899 gfc_cleanup_loop (&loop);
3903 /* Convert an array for passing as an actual parameter. */
3904 /* TODO: Optimize passing g77 arrays. */
3907 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
3916 /* Passing address of the array if it is not pointer or assumed-shape. */
3917 if (expr->expr_type == EXPR_VARIABLE
3918 && expr->ref->u.ar.type == AR_FULL && g77)
3920 sym = expr->symtree->n.sym;
3921 tmp = gfc_get_symbol_decl (sym);
3922 if (sym->ts.type == BT_CHARACTER)
3923 se->string_length = sym->ts.cl->backend_decl;
3924 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
3925 && !sym->attr.allocatable)
3927 /* Some variables are declared directly, others are declared as
3928 pointers and allocated on the heap. */
3929 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
3932 se->expr = gfc_build_addr_expr (NULL, tmp);
3935 if (sym->attr.allocatable)
3937 se->expr = gfc_conv_array_data (tmp);
3942 se->want_pointer = 1;
3943 gfc_conv_expr_descriptor (se, expr, ss);
3948 /* Repack the array. */
3949 tmp = gfc_chainon_list (NULL_TREE, desc);
3950 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3951 ptr = gfc_evaluate_now (ptr, &se->pre);
3954 gfc_start_block (&block);
3956 /* Copy the data back. */
3957 tmp = gfc_chainon_list (NULL_TREE, desc);
3958 tmp = gfc_chainon_list (tmp, ptr);
3959 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3960 gfc_add_expr_to_block (&block, tmp);
3962 /* Free the temporary. */
3963 tmp = convert (pvoid_type_node, ptr);
3964 tmp = gfc_chainon_list (NULL_TREE, tmp);
3965 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3966 gfc_add_expr_to_block (&block, tmp);
3968 stmt = gfc_finish_block (&block);
3970 gfc_init_block (&block);
3971 /* Only if it was repacked. This code needs to be executed before the
3972 loop cleanup code. */
3973 tmp = gfc_build_indirect_ref (desc);
3974 tmp = gfc_conv_array_data (tmp);
3975 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
3976 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3978 gfc_add_expr_to_block (&block, tmp);
3979 gfc_add_block_to_block (&block, &se->post);
3981 gfc_init_block (&se->post);
3982 gfc_add_block_to_block (&se->post, &block);
3987 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
3990 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
3997 stmtblock_t fnblock;
4000 /* Make sure the frontend gets these right. */
4001 if (!(sym->attr.pointer || sym->attr.allocatable))
4003 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4005 gfc_init_block (&fnblock);
4007 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
4008 if (sym->ts.type == BT_CHARACTER
4009 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4010 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4012 /* Dummy and use associated variables don't need anything special. */
4013 if (sym->attr.dummy || sym->attr.use_assoc)
4015 gfc_add_expr_to_block (&fnblock, body);
4017 return gfc_finish_block (&fnblock);
4020 gfc_get_backend_locus (&loc);
4021 gfc_set_backend_locus (&sym->declared_at);
4022 descriptor = sym->backend_decl;
4024 if (TREE_STATIC (descriptor))
4026 /* SAVEd variables are not freed on exit. */
4027 gfc_trans_static_array_pointer (sym);
4031 /* Get the descriptor type. */
4032 type = TREE_TYPE (sym->backend_decl);
4033 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4035 /* NULLIFY the data pointer. */
4036 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4038 gfc_add_expr_to_block (&fnblock, body);
4040 gfc_set_backend_locus (&loc);
4041 /* Allocatable arrays need to be freed when they go out of scope. */
4042 if (sym->attr.allocatable)
4044 gfc_start_block (&block);
4046 /* Deallocate if still allocated at the end of the procedure. */
4047 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4049 tmp = gfc_conv_descriptor_data_get (descriptor);
4050 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4051 build_int_cst (TREE_TYPE (tmp), 0));
4052 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4053 gfc_add_expr_to_block (&block, tmp);
4055 tmp = gfc_finish_block (&block);
4056 gfc_add_expr_to_block (&fnblock, tmp);
4059 return gfc_finish_block (&fnblock);
4062 /************ Expression Walking Functions ******************/
4064 /* Walk a variable reference.
4066 Possible extension - multiple component subscripts.
4067 x(:,:) = foo%a(:)%b(:)
4069 forall (i=..., j=...)
4070 x(i,j) = foo%a(j)%b(i)
4072 This adds a fair amout of complexity because you need to deal with more
4073 than one ref. Maybe handle in a similar manner to vector subscripts.
4074 Maybe not worth the effort. */
4078 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4086 for (ref = expr->ref; ref; ref = ref->next)
4087 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4090 for (; ref; ref = ref->next)
4092 if (ref->type == REF_SUBSTRING)
4094 newss = gfc_get_ss ();
4095 newss->type = GFC_SS_SCALAR;
4096 newss->expr = ref->u.ss.start;
4100 newss = gfc_get_ss ();
4101 newss->type = GFC_SS_SCALAR;
4102 newss->expr = ref->u.ss.end;
4107 /* We're only interested in array sections from now on. */
4108 if (ref->type != REF_ARRAY)
4115 for (n = 0; n < ar->dimen; n++)
4117 newss = gfc_get_ss ();
4118 newss->type = GFC_SS_SCALAR;
4119 newss->expr = ar->start[n];
4126 newss = gfc_get_ss ();
4127 newss->type = GFC_SS_SECTION;
4130 newss->data.info.dimen = ar->as->rank;
4131 newss->data.info.ref = ref;
4133 /* Make sure array is the same as array(:,:), this way
4134 we don't need to special case all the time. */
4135 ar->dimen = ar->as->rank;
4136 for (n = 0; n < ar->dimen; n++)
4138 newss->data.info.dim[n] = n;
4139 ar->dimen_type[n] = DIMEN_RANGE;
4141 gcc_assert (ar->start[n] == NULL);
4142 gcc_assert (ar->end[n] == NULL);
4143 gcc_assert (ar->stride[n] == NULL);
4149 newss = gfc_get_ss ();
4150 newss->type = GFC_SS_SECTION;
4153 newss->data.info.dimen = 0;
4154 newss->data.info.ref = ref;
4158 /* We add SS chains for all the subscripts in the section. */
4159 for (n = 0; n < ar->dimen; n++)
4163 switch (ar->dimen_type[n])
4166 /* Add SS for elemental (scalar) subscripts. */
4167 gcc_assert (ar->start[n]);
4168 indexss = gfc_get_ss ();
4169 indexss->type = GFC_SS_SCALAR;
4170 indexss->expr = ar->start[n];
4171 indexss->next = gfc_ss_terminator;
4172 indexss->loop_chain = gfc_ss_terminator;
4173 newss->data.info.subscript[n] = indexss;
4177 /* We don't add anything for sections, just remember this
4178 dimension for later. */
4179 newss->data.info.dim[newss->data.info.dimen] = n;
4180 newss->data.info.dimen++;
4184 /* Get a SS for the vector. This will not be added to the
4186 indexss = gfc_walk_expr (ar->start[n]);
4187 if (indexss == gfc_ss_terminator)
4188 internal_error ("scalar vector subscript???");
4190 /* We currently only handle really simple vector
4192 if (indexss->next != gfc_ss_terminator)
4193 gfc_todo_error ("vector subscript expressions");
4194 indexss->loop_chain = gfc_ss_terminator;
4196 /* Mark this as a vector subscript. We don't add this
4197 directly into the chain, but as a subscript of the
4198 existing SS for this term. */
4199 indexss->type = GFC_SS_VECTOR;
4200 newss->data.info.subscript[n] = indexss;
4201 /* Also remember this dimension. */
4202 newss->data.info.dim[newss->data.info.dimen] = n;
4203 newss->data.info.dimen++;
4207 /* We should know what sort of section it is by now. */
4211 /* We should have at least one non-elemental dimension. */
4212 gcc_assert (newss->data.info.dimen > 0);
4217 /* We should know what sort of section it is by now. */
4226 /* Walk an expression operator. If only one operand of a binary expression is
4227 scalar, we must also add the scalar term to the SS chain. */
4230 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4236 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4237 if (expr->value.op.op2 == NULL)
4240 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4242 /* All operands are scalar. Pass back and let the caller deal with it. */
4246 /* All operands require scalarization. */
4247 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4250 /* One of the operands needs scalarization, the other is scalar.
4251 Create a gfc_ss for the scalar expression. */
4252 newss = gfc_get_ss ();
4253 newss->type = GFC_SS_SCALAR;
4256 /* First operand is scalar. We build the chain in reverse order, so
4257 add the scarar SS after the second operand. */
4259 while (head && head->next != ss)
4261 /* Check we haven't somehow broken the chain. */
4265 newss->expr = expr->value.op.op1;
4267 else /* head2 == head */
4269 gcc_assert (head2 == head);
4270 /* Second operand is scalar. */
4271 newss->next = head2;
4273 newss->expr = expr->value.op.op2;
4280 /* Reverse a SS chain. */
4283 gfc_reverse_ss (gfc_ss * ss)
4288 gcc_assert (ss != NULL);
4290 head = gfc_ss_terminator;
4291 while (ss != gfc_ss_terminator)
4294 /* Check we didn't somehow break the chain. */
4295 gcc_assert (next != NULL);
4305 /* Walk the arguments of an elemental function. */
4308 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4311 gfc_actual_arglist *arg;
4317 head = gfc_ss_terminator;
4320 for (arg = expr->value.function.actual; arg; arg = arg->next)
4325 newss = gfc_walk_subexpr (head, arg->expr);
4328 /* Scalar argument. */
4329 newss = gfc_get_ss ();
4331 newss->expr = arg->expr;
4341 while (tail->next != gfc_ss_terminator)
4348 /* If all the arguments are scalar we don't need the argument SS. */
4349 gfc_free_ss_chain (head);
4354 /* Add it onto the existing chain. */
4360 /* Walk a function call. Scalar functions are passed back, and taken out of
4361 scalarization loops. For elemental functions we walk their arguments.
4362 The result of functions returning arrays is stored in a temporary outside
4363 the loop, so that the function is only called once. Hence we do not need
4364 to walk their arguments. */
4367 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4370 gfc_intrinsic_sym *isym;
4373 isym = expr->value.function.isym;
4375 /* Handle intrinsic functions separately. */
4377 return gfc_walk_intrinsic_function (ss, expr, isym);
4379 sym = expr->value.function.esym;
4381 sym = expr->symtree->n.sym;
4383 /* A function that returns arrays. */
4384 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4386 newss = gfc_get_ss ();
4387 newss->type = GFC_SS_FUNCTION;
4390 newss->data.info.dimen = expr->rank;
4394 /* Walk the parameters of an elemental function. For now we always pass
4396 if (sym->attr.elemental)
4397 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4399 /* Scalar functions are OK as these are evaluated outside the scalarization
4400 loop. Pass back and let the caller deal with it. */
4405 /* An array temporary is constructed for array constructors. */
4408 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4413 newss = gfc_get_ss ();
4414 newss->type = GFC_SS_CONSTRUCTOR;
4417 newss->data.info.dimen = expr->rank;
4418 for (n = 0; n < expr->rank; n++)
4419 newss->data.info.dim[n] = n;
4425 /* Walk an expression. Add walked expressions to the head of the SS chain.
4426 A wholly scalar expression will not be added. */
4429 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4433 switch (expr->expr_type)
4436 head = gfc_walk_variable_expr (ss, expr);
4440 head = gfc_walk_op_expr (ss, expr);
4444 head = gfc_walk_function_expr (ss, expr);
4449 case EXPR_STRUCTURE:
4450 /* Pass back and let the caller deal with it. */
4454 head = gfc_walk_array_constructor (ss, expr);
4457 case EXPR_SUBSTRING:
4458 /* Pass back and let the caller deal with it. */
4462 internal_error ("bad expression type during walk (%d)",
4469 /* Entry point for expression walking.
4470 A return value equal to the passed chain means this is
4471 a scalar expression. It is up to the caller to take whatever action is
4472 necessary to translate these. */
4475 gfc_walk_expr (gfc_expr * expr)
4479 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4480 return gfc_reverse_ss (res);