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 an 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);
1238 case GFC_SS_CONSTRUCTOR:
1239 gfc_trans_array_constructor (loop, ss);
1243 case GFC_SS_COMPONENT:
1244 /* Do nothing. These are handled elsewhere. */
1254 /* Translate expressions for the descriptor and data pointer of a SS. */
1258 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1263 /* Get the descriptor for the array to be scalarized. */
1264 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1265 gfc_init_se (&se, NULL);
1266 se.descriptor_only = 1;
1267 gfc_conv_expr_lhs (&se, ss->expr);
1268 gfc_add_block_to_block (block, &se.pre);
1269 ss->data.info.descriptor = se.expr;
1270 ss->string_length = se.string_length;
1274 /* Also the data pointer. */
1275 tmp = gfc_conv_array_data (se.expr);
1276 /* If this is a variable or address of a variable we use it directly.
1277 Otherwise we must evaluate it now to avoid breaking dependency
1278 analysis by pulling the expressions for elemental array indices
1281 || (TREE_CODE (tmp) == ADDR_EXPR
1282 && DECL_P (TREE_OPERAND (tmp, 0)))))
1283 tmp = gfc_evaluate_now (tmp, block);
1284 ss->data.info.data = tmp;
1286 tmp = gfc_conv_array_offset (se.expr);
1287 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1292 /* Initialize a gfc_loopinfo structure. */
1295 gfc_init_loopinfo (gfc_loopinfo * loop)
1299 memset (loop, 0, sizeof (gfc_loopinfo));
1300 gfc_init_block (&loop->pre);
1301 gfc_init_block (&loop->post);
1303 /* Initially scalarize in order. */
1304 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1307 loop->ss = gfc_ss_terminator;
1311 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1315 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1321 /* Return an expression for the data pointer of an array. */
1324 gfc_conv_array_data (tree descriptor)
1328 type = TREE_TYPE (descriptor);
1329 if (GFC_ARRAY_TYPE_P (type))
1331 if (TREE_CODE (type) == POINTER_TYPE)
1335 /* Descriptorless arrays. */
1336 return gfc_build_addr_expr (NULL, descriptor);
1340 return gfc_conv_descriptor_data_get (descriptor);
1344 /* Return an expression for the base offset of an array. */
1347 gfc_conv_array_offset (tree descriptor)
1351 type = TREE_TYPE (descriptor);
1352 if (GFC_ARRAY_TYPE_P (type))
1353 return GFC_TYPE_ARRAY_OFFSET (type);
1355 return gfc_conv_descriptor_offset (descriptor);
1359 /* Get an expression for the array stride. */
1362 gfc_conv_array_stride (tree descriptor, int dim)
1367 type = TREE_TYPE (descriptor);
1369 /* For descriptorless arrays use the array size. */
1370 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1371 if (tmp != NULL_TREE)
1374 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1379 /* Like gfc_conv_array_stride, but for the lower bound. */
1382 gfc_conv_array_lbound (tree descriptor, int dim)
1387 type = TREE_TYPE (descriptor);
1389 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1390 if (tmp != NULL_TREE)
1393 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1398 /* Like gfc_conv_array_stride, but for the upper bound. */
1401 gfc_conv_array_ubound (tree descriptor, int dim)
1406 type = TREE_TYPE (descriptor);
1408 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1409 if (tmp != NULL_TREE)
1412 /* This should only ever happen when passing an assumed shape array
1413 as an actual parameter. The value will never be used. */
1414 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1415 return gfc_index_zero_node;
1417 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1422 /* Translate an array reference. The descriptor should be in se->expr.
1423 Do not use this function, it wil be removed soon. */
1427 gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
1428 tree offset, int dimen)
1435 array = gfc_build_indirect_ref (pointer);
1438 for (n = 0; n < dimen; n++)
1440 /* index = index + stride[n]*indices[n] */
1441 tmp = gfc_conv_array_stride (se->expr, n);
1442 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
1444 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1447 /* Result = data[index]. */
1448 tmp = gfc_build_array_ref (array, index);
1450 /* Check we've used the correct number of dimensions. */
1451 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
1457 /* Generate code to perform an array index bound check. */
1460 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1466 if (!flag_bounds_check)
1469 index = gfc_evaluate_now (index, &se->pre);
1470 /* Check lower bound. */
1471 tmp = gfc_conv_array_lbound (descriptor, n);
1472 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1473 /* Check upper bound. */
1474 tmp = gfc_conv_array_ubound (descriptor, n);
1475 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1476 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1478 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1484 /* A reference to an array vector subscript. Uses recursion to handle nested
1485 vector subscripts. */
1488 gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
1491 tree indices[GFC_MAX_DIMENSIONS];
1496 gcc_assert (ss && ss->type == GFC_SS_VECTOR);
1498 /* Save the descriptor. */
1499 descsave = se->expr;
1500 info = &ss->data.info;
1501 se->expr = info->descriptor;
1503 ar = &info->ref->u.ar;
1504 for (n = 0; n < ar->dimen; n++)
1506 switch (ar->dimen_type[n])
1509 gcc_assert (info->subscript[n] != gfc_ss_terminator
1510 && info->subscript[n]->type == GFC_SS_SCALAR);
1511 indices[n] = info->subscript[n]->data.scalar.expr;
1519 index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
1522 gfc_trans_array_bound_check (se, info->descriptor, index, n);
1529 /* Get the index from the vector. */
1530 gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
1532 /* Put the descriptor back. */
1533 se->expr = descsave;
1539 /* Return the offset for an index. Performs bound checking for elemental
1540 dimensions. Single element references are processed separately. */
1543 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1544 gfc_array_ref * ar, tree stride)
1548 /* Get the index into the array for this dimension. */
1551 gcc_assert (ar->type != AR_ELEMENT);
1552 if (ar->dimen_type[dim] == DIMEN_ELEMENT)
1554 gcc_assert (i == -1);
1555 /* Elemental dimension. */
1556 gcc_assert (info->subscript[dim]
1557 && info->subscript[dim]->type == GFC_SS_SCALAR);
1558 /* We've already translated this value outside the loop. */
1559 index = info->subscript[dim]->data.scalar.expr;
1562 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1566 /* Scalarized dimension. */
1567 gcc_assert (info && se->loop);
1569 /* Multiply the loop variable by the stride and delta. */
1570 index = se->loop->loopvar[i];
1571 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1573 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1576 if (ar->dimen_type[dim] == DIMEN_VECTOR)
1578 /* Handle vector subscripts. */
1579 index = gfc_conv_vector_array_index (se, index,
1580 info->subscript[dim]);
1582 gfc_trans_array_bound_check (se, info->descriptor, index,
1586 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
1591 /* Temporary array or derived type component. */
1592 gcc_assert (se->loop);
1593 index = se->loop->loopvar[se->loop->order[i]];
1594 if (!integer_zerop (info->delta[i]))
1595 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1596 index, info->delta[i]);
1599 /* Multiply by the stride. */
1600 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1606 /* Build a scalarized reference to an array. */
1609 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1616 info = &se->ss->data.info;
1618 n = se->loop->order[0];
1622 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1624 /* Add the offset for this dimension to the stored offset for all other
1626 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1628 tmp = gfc_build_indirect_ref (info->data);
1629 se->expr = gfc_build_array_ref (tmp, index);
1633 /* Translate access of temporary array. */
1636 gfc_conv_tmp_array_ref (gfc_se * se)
1638 se->string_length = se->ss->string_length;
1639 gfc_conv_scalarized_array_ref (se, NULL);
1643 /* Build an array reference. se->expr already holds the array descriptor.
1644 This should be either a variable, indirect variable reference or component
1645 reference. For arrays which do not have a descriptor, se->expr will be
1647 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1650 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1659 /* Handle scalarized references separately. */
1660 if (ar->type != AR_ELEMENT)
1662 gfc_conv_scalarized_array_ref (se, ar);
1666 index = gfc_index_zero_node;
1668 fault = gfc_index_zero_node;
1670 /* Calculate the offsets from all the dimensions. */
1671 for (n = 0; n < ar->dimen; n++)
1673 /* Calculate the index for this dimension. */
1674 gfc_init_se (&indexse, NULL);
1675 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1676 gfc_add_block_to_block (&se->pre, &indexse.pre);
1678 if (flag_bounds_check)
1680 /* Check array bounds. */
1683 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1685 tmp = gfc_conv_array_lbound (se->expr, n);
1686 cond = fold_build2 (LT_EXPR, boolean_type_node,
1689 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1691 tmp = gfc_conv_array_ubound (se->expr, n);
1692 cond = fold_build2 (GT_EXPR, boolean_type_node,
1695 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1698 /* Multiply the index by the stride. */
1699 stride = gfc_conv_array_stride (se->expr, n);
1700 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1703 /* And add it to the total. */
1704 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1707 if (flag_bounds_check)
1708 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1710 tmp = gfc_conv_array_offset (se->expr);
1711 if (!integer_zerop (tmp))
1712 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1714 /* Access the calculated element. */
1715 tmp = gfc_conv_array_data (se->expr);
1716 tmp = gfc_build_indirect_ref (tmp);
1717 se->expr = gfc_build_array_ref (tmp, index);
1721 /* Generate the code to be executed immediately before entering a
1722 scalarization loop. */
1725 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1726 stmtblock_t * pblock)
1735 /* This code will be executed before entering the scalarization loop
1736 for this dimension. */
1737 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1739 if ((ss->useflags & flag) == 0)
1742 if (ss->type != GFC_SS_SECTION
1743 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1744 && ss->type != GFC_SS_COMPONENT)
1747 info = &ss->data.info;
1749 if (dim >= info->dimen)
1752 if (dim == info->dimen - 1)
1754 /* For the outermost loop calculate the offset due to any
1755 elemental dimensions. It will have been initialized with the
1756 base offset of the array. */
1759 for (i = 0; i < info->ref->u.ar.dimen; i++)
1761 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1764 gfc_init_se (&se, NULL);
1766 se.expr = info->descriptor;
1767 stride = gfc_conv_array_stride (info->descriptor, i);
1768 index = gfc_conv_array_index_offset (&se, info, i, -1,
1771 gfc_add_block_to_block (pblock, &se.pre);
1773 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1774 info->offset, index);
1775 info->offset = gfc_evaluate_now (info->offset, pblock);
1779 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1782 stride = gfc_conv_array_stride (info->descriptor, 0);
1784 /* Calculate the stride of the innermost loop. Hopefully this will
1785 allow the backend optimizers to do their stuff more effectively.
1787 info->stride0 = gfc_evaluate_now (stride, pblock);
1791 /* Add the offset for the previous loop dimension. */
1796 ar = &info->ref->u.ar;
1797 i = loop->order[dim + 1];
1805 gfc_init_se (&se, NULL);
1807 se.expr = info->descriptor;
1808 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1809 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
1811 gfc_add_block_to_block (pblock, &se.pre);
1812 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1813 info->offset, index);
1814 info->offset = gfc_evaluate_now (info->offset, pblock);
1817 /* Remember this offset for the second loop. */
1818 if (dim == loop->temp_dim - 1)
1819 info->saved_offset = info->offset;
1824 /* Start a scalarized expression. Creates a scope and declares loop
1828 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
1834 gcc_assert (!loop->array_parameter);
1836 for (dim = loop->dimen - 1; dim >= 0; dim--)
1838 n = loop->order[dim];
1840 gfc_start_block (&loop->code[n]);
1842 /* Create the loop variable. */
1843 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
1845 if (dim < loop->temp_dim)
1849 /* Calculate values that will be constant within this loop. */
1850 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
1852 gfc_start_block (pbody);
1856 /* Generates the actual loop code for a scalarization loop. */
1859 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
1860 stmtblock_t * pbody)
1868 loopbody = gfc_finish_block (pbody);
1870 /* Initialize the loopvar. */
1871 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
1873 exit_label = gfc_build_label_decl (NULL_TREE);
1875 /* Generate the loop body. */
1876 gfc_init_block (&block);
1878 /* The exit condition. */
1879 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
1880 tmp = build1_v (GOTO_EXPR, exit_label);
1881 TREE_USED (exit_label) = 1;
1882 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1883 gfc_add_expr_to_block (&block, tmp);
1885 /* The main body. */
1886 gfc_add_expr_to_block (&block, loopbody);
1888 /* Increment the loopvar. */
1889 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1890 loop->loopvar[n], gfc_index_one_node);
1891 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
1893 /* Build the loop. */
1894 tmp = gfc_finish_block (&block);
1895 tmp = build1_v (LOOP_EXPR, tmp);
1896 gfc_add_expr_to_block (&loop->code[n], tmp);
1898 /* Add the exit label. */
1899 tmp = build1_v (LABEL_EXPR, exit_label);
1900 gfc_add_expr_to_block (&loop->code[n], tmp);
1904 /* Finishes and generates the loops for a scalarized expression. */
1907 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
1912 stmtblock_t *pblock;
1916 /* Generate the loops. */
1917 for (dim = 0; dim < loop->dimen; dim++)
1919 n = loop->order[dim];
1920 gfc_trans_scalarized_loop_end (loop, n, pblock);
1921 loop->loopvar[n] = NULL_TREE;
1922 pblock = &loop->code[n];
1925 tmp = gfc_finish_block (pblock);
1926 gfc_add_expr_to_block (&loop->pre, tmp);
1928 /* Clear all the used flags. */
1929 for (ss = loop->ss; ss; ss = ss->loop_chain)
1934 /* Finish the main body of a scalarized expression, and start the secondary
1938 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
1942 stmtblock_t *pblock;
1946 /* We finish as many loops as are used by the temporary. */
1947 for (dim = 0; dim < loop->temp_dim - 1; dim++)
1949 n = loop->order[dim];
1950 gfc_trans_scalarized_loop_end (loop, n, pblock);
1951 loop->loopvar[n] = NULL_TREE;
1952 pblock = &loop->code[n];
1955 /* We don't want to finish the outermost loop entirely. */
1956 n = loop->order[loop->temp_dim - 1];
1957 gfc_trans_scalarized_loop_end (loop, n, pblock);
1959 /* Restore the initial offsets. */
1960 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1962 if ((ss->useflags & 2) == 0)
1965 if (ss->type != GFC_SS_SECTION
1966 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1967 && ss->type != GFC_SS_COMPONENT)
1970 ss->data.info.offset = ss->data.info.saved_offset;
1973 /* Restart all the inner loops we just finished. */
1974 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
1976 n = loop->order[dim];
1978 gfc_start_block (&loop->code[n]);
1980 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
1982 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
1985 /* Start a block for the secondary copying code. */
1986 gfc_start_block (body);
1990 /* Calculate the upper bound of an array section. */
1993 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2002 gcc_assert (ss->type == GFC_SS_SECTION);
2004 /* For vector array subscripts we want the size of the vector. */
2005 dim = ss->data.info.dim[n];
2007 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2009 vecss = vecss->data.info.subscript[dim];
2010 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2011 dim = vecss->data.info.dim[0];
2014 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2015 end = vecss->data.info.ref->u.ar.end[dim];
2016 desc = vecss->data.info.descriptor;
2020 /* The upper bound was specified. */
2021 gfc_init_se (&se, NULL);
2022 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2023 gfc_add_block_to_block (pblock, &se.pre);
2028 /* No upper bound was specified, so use the bound of the array. */
2029 bound = gfc_conv_array_ubound (desc, dim);
2036 /* Calculate the lower bound of an array section. */
2039 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2049 info = &ss->data.info;
2053 /* For vector array subscripts we want the size of the vector. */
2055 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2057 vecss = vecss->data.info.subscript[dim];
2058 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2059 /* Get the descriptors for the vector subscripts as well. */
2060 if (!vecss->data.info.descriptor)
2061 gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
2062 dim = vecss->data.info.dim[0];
2065 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2066 start = vecss->data.info.ref->u.ar.start[dim];
2067 stride = vecss->data.info.ref->u.ar.stride[dim];
2068 desc = vecss->data.info.descriptor;
2070 /* Calculate the start of the range. For vector subscripts this will
2071 be the range of the vector. */
2074 /* Specified section start. */
2075 gfc_init_se (&se, NULL);
2076 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2077 gfc_add_block_to_block (&loop->pre, &se.pre);
2078 info->start[n] = se.expr;
2082 /* No lower bound specified so use the bound of the array. */
2083 info->start[n] = gfc_conv_array_lbound (desc, dim);
2085 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2087 /* Calculate the stride. */
2089 info->stride[n] = gfc_index_one_node;
2092 gfc_init_se (&se, NULL);
2093 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2094 gfc_add_block_to_block (&loop->pre, &se.pre);
2095 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2100 /* Calculates the range start and stride for a SS chain. Also gets the
2101 descriptor and data pointer. The range of vector subscripts is the size
2102 of the vector. Array bounds are also checked. */
2105 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2114 /* Determine the rank of the loop. */
2116 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2120 case GFC_SS_SECTION:
2121 case GFC_SS_CONSTRUCTOR:
2122 case GFC_SS_FUNCTION:
2123 case GFC_SS_COMPONENT:
2124 loop->dimen = ss->data.info.dimen;
2132 if (loop->dimen == 0)
2133 gfc_todo_error ("Unable to determine rank of expression");
2136 /* Loop over all the SS in the chain. */
2137 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2139 if (ss->expr && ss->expr->shape && !ss->shape)
2140 ss->shape = ss->expr->shape;
2144 case GFC_SS_SECTION:
2145 /* Get the descriptor for the array. */
2146 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2148 for (n = 0; n < ss->data.info.dimen; n++)
2149 gfc_conv_section_startstride (loop, ss, n);
2152 case GFC_SS_CONSTRUCTOR:
2153 case GFC_SS_FUNCTION:
2154 for (n = 0; n < ss->data.info.dimen; n++)
2156 ss->data.info.start[n] = gfc_index_zero_node;
2157 ss->data.info.stride[n] = gfc_index_one_node;
2166 /* The rest is just runtime bound checking. */
2167 if (flag_bounds_check)
2173 tree size[GFC_MAX_DIMENSIONS];
2177 gfc_start_block (&block);
2179 fault = integer_zero_node;
2180 for (n = 0; n < loop->dimen; n++)
2181 size[n] = NULL_TREE;
2183 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2185 if (ss->type != GFC_SS_SECTION)
2188 /* TODO: range checking for mapped dimensions. */
2189 info = &ss->data.info;
2191 /* This only checks scalarized dimensions, elemental dimensions are
2193 for (n = 0; n < loop->dimen; n++)
2197 while (vecss->data.info.ref->u.ar.dimen_type[dim]
2200 vecss = vecss->data.info.subscript[dim];
2201 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
2202 dim = vecss->data.info.dim[0];
2204 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
2206 desc = vecss->data.info.descriptor;
2208 /* Check lower bound. */
2209 bound = gfc_conv_array_lbound (desc, dim);
2210 tmp = info->start[n];
2211 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2212 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2215 /* Check the upper bound. */
2216 bound = gfc_conv_array_ubound (desc, dim);
2217 end = gfc_conv_section_upper_bound (ss, n, &block);
2218 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2219 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2222 /* Check the section sizes match. */
2223 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2225 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2227 /* We remember the size of the first section, and check all the
2228 others against this. */
2232 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2234 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2237 size[n] = gfc_evaluate_now (tmp, &block);
2240 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2242 tmp = gfc_finish_block (&block);
2243 gfc_add_expr_to_block (&loop->pre, tmp);
2248 /* Return true if the two SS could be aliased, i.e. both point to the same data
2250 /* TODO: resolve aliases based on frontend expressions. */
2253 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2260 lsym = lss->expr->symtree->n.sym;
2261 rsym = rss->expr->symtree->n.sym;
2262 if (gfc_symbols_could_alias (lsym, rsym))
2265 if (rsym->ts.type != BT_DERIVED
2266 && lsym->ts.type != BT_DERIVED)
2269 /* For derived types we must check all the component types. We can ignore
2270 array references as these will have the same base type as the previous
2272 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2274 if (lref->type != REF_COMPONENT)
2277 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2280 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2283 if (rref->type != REF_COMPONENT)
2286 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2291 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2293 if (rref->type != REF_COMPONENT)
2296 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2304 /* Resolve array data dependencies. Creates a temporary if required. */
2305 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2309 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2319 loop->temp_ss = NULL;
2320 aref = dest->data.info.ref;
2323 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2325 if (ss->type != GFC_SS_SECTION)
2328 if (gfc_could_be_alias (dest, ss))
2334 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2336 lref = dest->expr->ref;
2337 rref = ss->expr->ref;
2339 nDepend = gfc_dep_resolver (lref, rref);
2341 /* TODO : loop shifting. */
2344 /* Mark the dimensions for LOOP SHIFTING */
2345 for (n = 0; n < loop->dimen; n++)
2347 int dim = dest->data.info.dim[n];
2349 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2351 else if (! gfc_is_same_range (&lref->u.ar,
2352 &rref->u.ar, dim, 0))
2356 /* Put all the dimensions with dependencies in the
2359 for (n = 0; n < loop->dimen; n++)
2361 gcc_assert (loop->order[n] == n);
2363 loop->order[dim++] = n;
2366 for (n = 0; n < loop->dimen; n++)
2369 loop->order[dim++] = n;
2372 gcc_assert (dim == loop->dimen);
2381 loop->temp_ss = gfc_get_ss ();
2382 loop->temp_ss->type = GFC_SS_TEMP;
2383 loop->temp_ss->data.temp.type =
2384 gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
2385 loop->temp_ss->string_length = dest->string_length;
2386 loop->temp_ss->data.temp.dimen = loop->dimen;
2387 loop->temp_ss->next = gfc_ss_terminator;
2388 gfc_add_ss_to_loop (loop, loop->temp_ss);
2391 loop->temp_ss = NULL;
2395 /* Initialize the scalarization loop. Creates the loop variables. Determines
2396 the range of the loop variables. Creates a temporary if required.
2397 Calculates how to transform from loop variables to array indices for each
2398 expression. Also generates code for scalar expressions which have been
2399 moved outside the loop. */
2402 gfc_conv_loop_setup (gfc_loopinfo * loop)
2407 gfc_ss_info *specinfo;
2411 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2416 for (n = 0; n < loop->dimen; n++)
2419 /* We use one SS term, and use that to determine the bounds of the
2420 loop for this dimension. We try to pick the simplest term. */
2421 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2425 /* The frontend has worked out the size for us. */
2430 if (ss->type == GFC_SS_CONSTRUCTOR)
2432 /* An unknown size constructor will always be rank one.
2433 Higher rank constructors will either have known shape,
2434 or still be wrapped in a call to reshape. */
2435 gcc_assert (loop->dimen == 1);
2436 /* Try to figure out the size of the constructor. */
2437 /* TODO: avoid this by making the frontend set the shape. */
2438 gfc_get_array_cons_size (&i, ss->expr->value.constructor);
2439 /* A negative value means we failed. */
2440 if (mpz_sgn (i) > 0)
2442 mpz_sub_ui (i, i, 1);
2444 gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2450 /* TODO: Pick the best bound if we have a choice between a
2451 function and something else. */
2452 if (ss->type == GFC_SS_FUNCTION)
2458 if (ss->type != GFC_SS_SECTION)
2462 specinfo = &loopspec[n]->data.info;
2465 info = &ss->data.info;
2467 /* Criteria for choosing a loop specifier (most important first):
2475 /* TODO: Is != constructor correct? */
2476 else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
2478 if (integer_onep (info->stride[n])
2479 && !integer_onep (specinfo->stride[n]))
2481 else if (INTEGER_CST_P (info->stride[n])
2482 && !INTEGER_CST_P (specinfo->stride[n]))
2484 else if (INTEGER_CST_P (info->start[n])
2485 && !INTEGER_CST_P (specinfo->start[n]))
2487 /* We don't work out the upper bound.
2488 else if (INTEGER_CST_P (info->finish[n])
2489 && ! INTEGER_CST_P (specinfo->finish[n]))
2490 loopspec[n] = ss; */
2495 gfc_todo_error ("Unable to find scalarization loop specifier");
2497 info = &loopspec[n]->data.info;
2499 /* Set the extents of this range. */
2500 cshape = loopspec[n]->shape;
2501 if (cshape && INTEGER_CST_P (info->start[n])
2502 && INTEGER_CST_P (info->stride[n]))
2504 loop->from[n] = info->start[n];
2505 mpz_set (i, cshape[n]);
2506 mpz_sub_ui (i, i, 1);
2507 /* To = from + (size - 1) * stride. */
2508 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2509 if (!integer_onep (info->stride[n]))
2510 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2511 tmp, info->stride[n]);
2512 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2513 loop->from[n], tmp);
2517 loop->from[n] = info->start[n];
2518 switch (loopspec[n]->type)
2520 case GFC_SS_CONSTRUCTOR:
2521 gcc_assert (info->dimen == 1);
2522 gcc_assert (loop->to[n]);
2525 case GFC_SS_SECTION:
2526 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2530 case GFC_SS_FUNCTION:
2531 /* The loop bound will be set when we generate the call. */
2532 gcc_assert (loop->to[n] == NULL_TREE);
2540 /* Transform everything so we have a simple incrementing variable. */
2541 if (integer_onep (info->stride[n]))
2542 info->delta[n] = gfc_index_zero_node;
2545 /* Set the delta for this section. */
2546 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2547 /* Number of iterations is (end - start + step) / step.
2548 with start = 0, this simplifies to
2550 for (i = 0; i<=last; i++){...}; */
2551 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2552 loop->to[n], loop->from[n]);
2553 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2554 tmp, info->stride[n]);
2555 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2556 /* Make the loop variable start at 0. */
2557 loop->from[n] = gfc_index_zero_node;
2561 /* Add all the scalar code that can be taken out of the loops.
2562 This may include calculating the loop bounds, so do it before
2563 allocating the temporary. */
2564 gfc_add_loop_ss_code (loop, loop->ss, false);
2566 /* If we want a temporary then create it. */
2567 if (loop->temp_ss != NULL)
2569 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2570 tmp = loop->temp_ss->data.temp.type;
2571 len = loop->temp_ss->string_length;
2572 n = loop->temp_ss->data.temp.dimen;
2573 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2574 loop->temp_ss->type = GFC_SS_SECTION;
2575 loop->temp_ss->data.info.dimen = n;
2576 gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
2579 for (n = 0; n < loop->temp_dim; n++)
2580 loopspec[loop->order[n]] = NULL;
2584 /* For array parameters we don't have loop variables, so don't calculate the
2586 if (loop->array_parameter)
2589 /* Calculate the translation from loop variables to array indices. */
2590 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2592 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2595 info = &ss->data.info;
2597 for (n = 0; n < info->dimen; n++)
2601 /* If we are specifying the range the delta is already set. */
2602 if (loopspec[n] != ss)
2604 /* Calculate the offset relative to the loop variable.
2605 First multiply by the stride. */
2606 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2607 loop->from[n], info->stride[n]);
2609 /* Then subtract this from our starting value. */
2610 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2611 info->start[n], tmp);
2613 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2620 /* Fills in an array descriptor, and returns the size of the array. The size
2621 will be a simple_val, ie a variable or a constant. Also calculates the
2622 offset of the base. Returns the size of the array.
2626 for (n = 0; n < rank; n++)
2628 a.lbound[n] = specified_lower_bound;
2629 offset = offset + a.lbond[n] * stride;
2631 a.ubound[n] = specified_upper_bound;
2632 a.stride[n] = stride;
2633 size = ubound + size; //size = ubound + 1 - lbound
2634 stride = stride * size;
2641 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2642 gfc_expr ** lower, gfc_expr ** upper,
2643 stmtblock_t * pblock)
2654 type = TREE_TYPE (descriptor);
2656 stride = gfc_index_one_node;
2657 offset = gfc_index_zero_node;
2659 /* Set the dtype. */
2660 tmp = gfc_conv_descriptor_dtype (descriptor);
2661 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2663 for (n = 0; n < rank; n++)
2665 /* We have 3 possibilities for determining the size of the array:
2666 lower == NULL => lbound = 1, ubound = upper[n]
2667 upper[n] = NULL => lbound = 1, ubound = lower[n]
2668 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2671 /* Set lower bound. */
2672 gfc_init_se (&se, NULL);
2674 se.expr = gfc_index_one_node;
2677 gcc_assert (lower[n]);
2680 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2681 gfc_add_block_to_block (pblock, &se.pre);
2685 se.expr = gfc_index_one_node;
2689 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2690 gfc_add_modify_expr (pblock, tmp, se.expr);
2692 /* Work out the offset for this component. */
2693 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2694 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2696 /* Start the calculation for the size of this dimension. */
2697 size = build2 (MINUS_EXPR, gfc_array_index_type,
2698 gfc_index_one_node, se.expr);
2700 /* Set upper bound. */
2701 gfc_init_se (&se, NULL);
2702 gcc_assert (ubound);
2703 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2704 gfc_add_block_to_block (pblock, &se.pre);
2706 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2707 gfc_add_modify_expr (pblock, tmp, se.expr);
2709 /* Store the stride. */
2710 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2711 gfc_add_modify_expr (pblock, tmp, stride);
2713 /* Calculate the size of this dimension. */
2714 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2716 /* Multiply the stride by the number of elements in this dimension. */
2717 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2718 stride = gfc_evaluate_now (stride, pblock);
2721 /* The stride is the number of elements in the array, so multiply by the
2722 size of an element to get the total size. */
2723 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2724 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2726 if (poffset != NULL)
2728 offset = gfc_evaluate_now (offset, pblock);
2732 size = gfc_evaluate_now (size, pblock);
2737 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2738 the work for an ALLOCATE statement. */
2742 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2752 /* Figure out the size of the array. */
2753 switch (ref->u.ar.type)
2757 upper = ref->u.ar.start;
2761 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2763 lower = ref->u.ar.as->lower;
2764 upper = ref->u.ar.as->upper;
2768 lower = ref->u.ar.start;
2769 upper = ref->u.ar.end;
2777 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2778 lower, upper, &se->pre);
2780 /* Allocate memory to store the data. */
2781 tmp = gfc_conv_descriptor_data_addr (se->expr);
2782 pointer = gfc_evaluate_now (tmp, &se->pre);
2784 if (TYPE_PRECISION (gfc_array_index_type) == 32)
2785 allocate = gfor_fndecl_allocate;
2786 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2787 allocate = gfor_fndecl_allocate64;
2791 tmp = gfc_chainon_list (NULL_TREE, pointer);
2792 tmp = gfc_chainon_list (tmp, size);
2793 tmp = gfc_chainon_list (tmp, pstat);
2794 tmp = gfc_build_function_call (allocate, tmp);
2795 gfc_add_expr_to_block (&se->pre, tmp);
2797 tmp = gfc_conv_descriptor_offset (se->expr);
2798 gfc_add_modify_expr (&se->pre, tmp, offset);
2802 /* Deallocate an array variable. Also used when an allocated variable goes
2807 gfc_array_deallocate (tree descriptor, tree pstat)
2813 gfc_start_block (&block);
2814 /* Get a pointer to the data. */
2815 tmp = gfc_conv_descriptor_data_addr (descriptor);
2816 var = gfc_evaluate_now (tmp, &block);
2818 /* Parameter is the address of the data component. */
2819 tmp = gfc_chainon_list (NULL_TREE, var);
2820 tmp = gfc_chainon_list (tmp, pstat);
2821 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2822 gfc_add_expr_to_block (&block, tmp);
2824 return gfc_finish_block (&block);
2828 /* Create an array constructor from an initialization expression.
2829 We assume the frontend already did any expansions and conversions. */
2832 gfc_conv_array_initializer (tree type, gfc_expr * expr)
2839 unsigned HOST_WIDE_INT lo;
2841 VEC(constructor_elt,gc) *v = NULL;
2843 switch (expr->expr_type)
2846 case EXPR_STRUCTURE:
2847 /* A single scalar or derived type value. Create an array with all
2848 elements equal to that value. */
2849 gfc_init_se (&se, NULL);
2851 if (expr->expr_type == EXPR_CONSTANT)
2852 gfc_conv_constant (&se, expr);
2854 gfc_conv_structure (&se, expr, 1);
2856 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2857 gcc_assert (tmp && INTEGER_CST_P (tmp));
2858 hi = TREE_INT_CST_HIGH (tmp);
2859 lo = TREE_INT_CST_LOW (tmp);
2863 /* This will probably eat buckets of memory for large arrays. */
2864 while (hi != 0 || lo != 0)
2866 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
2874 /* Create a vector of all the elements. */
2875 for (c = expr->value.constructor; c; c = c->next)
2879 /* Problems occur when we get something like
2880 integer :: a(lots) = (/(i, i=1,lots)/) */
2881 /* TODO: Unexpanded array initializers. */
2883 ("Possible frontend bug: array constructor not expanded");
2885 if (mpz_cmp_si (c->n.offset, 0) != 0)
2886 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2890 if (mpz_cmp_si (c->repeat, 0) != 0)
2894 mpz_set (maxval, c->repeat);
2895 mpz_add (maxval, c->n.offset, maxval);
2896 mpz_sub_ui (maxval, maxval, 1);
2897 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2898 if (mpz_cmp_si (c->n.offset, 0) != 0)
2900 mpz_add_ui (maxval, c->n.offset, 1);
2901 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2904 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2906 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
2912 gfc_init_se (&se, NULL);
2913 switch (c->expr->expr_type)
2916 gfc_conv_constant (&se, c->expr);
2917 if (range == NULL_TREE)
2918 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
2921 if (index != NULL_TREE)
2922 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
2923 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
2927 case EXPR_STRUCTURE:
2928 gfc_conv_structure (&se, c->expr, 1);
2929 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
2942 /* Create a constructor from the list of elements. */
2943 tmp = build_constructor (type, v);
2944 TREE_CONSTANT (tmp) = 1;
2945 TREE_INVARIANT (tmp) = 1;
2950 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2951 returns the size (in elements) of the array. */
2954 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
2955 stmtblock_t * pblock)
2970 size = gfc_index_one_node;
2971 offset = gfc_index_zero_node;
2972 for (dim = 0; dim < as->rank; dim++)
2974 /* Evaluate non-constant array bound expressions. */
2975 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
2976 if (as->lower[dim] && !INTEGER_CST_P (lbound))
2978 gfc_init_se (&se, NULL);
2979 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
2980 gfc_add_block_to_block (pblock, &se.pre);
2981 gfc_add_modify_expr (pblock, lbound, se.expr);
2983 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
2984 if (as->upper[dim] && !INTEGER_CST_P (ubound))
2986 gfc_init_se (&se, NULL);
2987 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
2988 gfc_add_block_to_block (pblock, &se.pre);
2989 gfc_add_modify_expr (pblock, ubound, se.expr);
2991 /* The offset of this dimension. offset = offset - lbound * stride. */
2992 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
2993 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2995 /* The size of this dimension, and the stride of the next. */
2996 if (dim + 1 < as->rank)
2997 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3001 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3003 /* Calculate stride = size * (ubound + 1 - lbound). */
3004 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3005 gfc_index_one_node, lbound);
3006 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3007 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3009 gfc_add_modify_expr (pblock, stride, tmp);
3011 stride = gfc_evaluate_now (tmp, pblock);
3022 /* Generate code to initialize/allocate an array variable. */
3025 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3035 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3037 /* Do nothing for USEd variables. */
3038 if (sym->attr.use_assoc)
3041 type = TREE_TYPE (decl);
3042 gcc_assert (GFC_ARRAY_TYPE_P (type));
3043 onstack = TREE_CODE (type) != POINTER_TYPE;
3045 gfc_start_block (&block);
3047 /* Evaluate character string length. */
3048 if (sym->ts.type == BT_CHARACTER
3049 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3051 gfc_trans_init_string_length (sym->ts.cl, &block);
3053 /* Emit a DECL_EXPR for this variable, which will cause the
3054 gimplifier to allocate storage, and all that good stuff. */
3055 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3056 gfc_add_expr_to_block (&block, tmp);
3061 gfc_add_expr_to_block (&block, fnbody);
3062 return gfc_finish_block (&block);
3065 type = TREE_TYPE (type);
3067 gcc_assert (!sym->attr.use_assoc);
3068 gcc_assert (!TREE_STATIC (decl));
3069 gcc_assert (!sym->module);
3071 if (sym->ts.type == BT_CHARACTER
3072 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3073 gfc_trans_init_string_length (sym->ts.cl, &block);
3075 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3077 /* The size is the number of elements in the array, so multiply by the
3078 size of an element to get the total size. */
3079 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3080 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3082 /* Allocate memory to hold the data. */
3083 tmp = gfc_chainon_list (NULL_TREE, size);
3085 if (gfc_index_integer_kind == 4)
3086 fndecl = gfor_fndecl_internal_malloc;
3087 else if (gfc_index_integer_kind == 8)
3088 fndecl = gfor_fndecl_internal_malloc64;
3091 tmp = gfc_build_function_call (fndecl, tmp);
3092 tmp = fold (convert (TREE_TYPE (decl), tmp));
3093 gfc_add_modify_expr (&block, decl, tmp);
3095 /* Set offset of the array. */
3096 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3097 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3100 /* Automatic arrays should not have initializers. */
3101 gcc_assert (!sym->value);
3103 gfc_add_expr_to_block (&block, fnbody);
3105 /* Free the temporary. */
3106 tmp = convert (pvoid_type_node, decl);
3107 tmp = gfc_chainon_list (NULL_TREE, tmp);
3108 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3109 gfc_add_expr_to_block (&block, tmp);
3111 return gfc_finish_block (&block);
3115 /* Generate entry and exit code for g77 calling convention arrays. */
3118 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3127 gfc_get_backend_locus (&loc);
3128 gfc_set_backend_locus (&sym->declared_at);
3130 /* Descriptor type. */
3131 parm = sym->backend_decl;
3132 type = TREE_TYPE (parm);
3133 gcc_assert (GFC_ARRAY_TYPE_P (type));
3135 gfc_start_block (&block);
3137 if (sym->ts.type == BT_CHARACTER
3138 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3139 gfc_trans_init_string_length (sym->ts.cl, &block);
3141 /* Evaluate the bounds of the array. */
3142 gfc_trans_array_bounds (type, sym, &offset, &block);
3144 /* Set the offset. */
3145 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3146 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3148 /* Set the pointer itself if we aren't using the parameter directly. */
3149 if (TREE_CODE (parm) != PARM_DECL)
3151 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3152 gfc_add_modify_expr (&block, parm, tmp);
3154 tmp = gfc_finish_block (&block);
3156 gfc_set_backend_locus (&loc);
3158 gfc_start_block (&block);
3159 /* Add the initialization code to the start of the function. */
3160 gfc_add_expr_to_block (&block, tmp);
3161 gfc_add_expr_to_block (&block, body);
3163 return gfc_finish_block (&block);
3167 /* Modify the descriptor of an array parameter so that it has the
3168 correct lower bound. Also move the upper bound accordingly.
3169 If the array is not packed, it will be copied into a temporary.
3170 For each dimension we set the new lower and upper bounds. Then we copy the
3171 stride and calculate the offset for this dimension. We also work out
3172 what the stride of a packed array would be, and see it the two match.
3173 If the array need repacking, we set the stride to the values we just
3174 calculated, recalculate the offset and copy the array data.
3175 Code is also added to copy the data back at the end of the function.
3179 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3186 stmtblock_t cleanup;
3204 /* Do nothing for pointer and allocatable arrays. */
3205 if (sym->attr.pointer || sym->attr.allocatable)
3208 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3209 return gfc_trans_g77_array (sym, body);
3211 gfc_get_backend_locus (&loc);
3212 gfc_set_backend_locus (&sym->declared_at);
3214 /* Descriptor type. */
3215 type = TREE_TYPE (tmpdesc);
3216 gcc_assert (GFC_ARRAY_TYPE_P (type));
3217 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3218 dumdesc = gfc_build_indirect_ref (dumdesc);
3219 gfc_start_block (&block);
3221 if (sym->ts.type == BT_CHARACTER
3222 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3223 gfc_trans_init_string_length (sym->ts.cl, &block);
3225 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3227 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3228 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3230 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3232 /* For non-constant shape arrays we only check if the first dimension
3233 is contiguous. Repacking higher dimensions wouldn't gain us
3234 anything as we still don't know the array stride. */
3235 partial = gfc_create_var (boolean_type_node, "partial");
3236 TREE_USED (partial) = 1;
3237 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3238 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3239 gfc_add_modify_expr (&block, partial, tmp);
3243 partial = NULL_TREE;
3246 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3247 here, however I think it does the right thing. */
3250 /* Set the first stride. */
3251 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3252 stride = gfc_evaluate_now (stride, &block);
3254 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3255 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3256 gfc_index_one_node, stride);
3257 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3258 gfc_add_modify_expr (&block, stride, tmp);
3260 /* Allow the user to disable array repacking. */
3261 stmt_unpacked = NULL_TREE;
3265 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3266 /* A library call to repack the array if necessary. */
3267 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3268 tmp = gfc_chainon_list (NULL_TREE, tmp);
3269 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3271 stride = gfc_index_one_node;
3274 /* This is for the case where the array data is used directly without
3275 calling the repack function. */
3276 if (no_repack || partial != NULL_TREE)
3277 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3279 stmt_packed = NULL_TREE;
3281 /* Assign the data pointer. */
3282 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3284 /* Don't repack unknown shape arrays when the first stride is 1. */
3285 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3286 stmt_packed, stmt_unpacked);
3289 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3290 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3292 offset = gfc_index_zero_node;
3293 size = gfc_index_one_node;
3295 /* Evaluate the bounds of the array. */
3296 for (n = 0; n < sym->as->rank; n++)
3298 if (checkparm || !sym->as->upper[n])
3300 /* Get the bounds of the actual parameter. */
3301 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3302 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3306 dubound = NULL_TREE;
3307 dlbound = NULL_TREE;
3310 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3311 if (!INTEGER_CST_P (lbound))
3313 gfc_init_se (&se, NULL);
3314 gfc_conv_expr_type (&se, sym->as->upper[n],
3315 gfc_array_index_type);
3316 gfc_add_block_to_block (&block, &se.pre);
3317 gfc_add_modify_expr (&block, lbound, se.expr);
3320 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3321 /* Set the desired upper bound. */
3322 if (sym->as->upper[n])
3324 /* We know what we want the upper bound to be. */
3325 if (!INTEGER_CST_P (ubound))
3327 gfc_init_se (&se, NULL);
3328 gfc_conv_expr_type (&se, sym->as->upper[n],
3329 gfc_array_index_type);
3330 gfc_add_block_to_block (&block, &se.pre);
3331 gfc_add_modify_expr (&block, ubound, se.expr);
3334 /* Check the sizes match. */
3337 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3339 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3341 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3343 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3344 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3349 /* For assumed shape arrays move the upper bound by the same amount
3350 as the lower bound. */
3351 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3352 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3353 gfc_add_modify_expr (&block, ubound, tmp);
3355 /* The offset of this dimension. offset = offset - lbound * stride. */
3356 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3357 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3359 /* The size of this dimension, and the stride of the next. */
3360 if (n + 1 < sym->as->rank)
3362 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3364 if (no_repack || partial != NULL_TREE)
3367 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3370 /* Figure out the stride if not a known constant. */
3371 if (!INTEGER_CST_P (stride))
3374 stmt_packed = NULL_TREE;
3377 /* Calculate stride = size * (ubound + 1 - lbound). */
3378 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3379 gfc_index_one_node, lbound);
3380 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3382 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3387 /* Assign the stride. */
3388 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3389 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3390 stmt_unpacked, stmt_packed);
3392 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3393 gfc_add_modify_expr (&block, stride, tmp);
3398 /* Set the offset. */
3399 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3400 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3402 stmt = gfc_finish_block (&block);
3404 gfc_start_block (&block);
3406 /* Only do the entry/initialization code if the arg is present. */
3407 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3408 optional_arg = (sym->attr.optional
3409 || (sym->ns->proc_name->attr.entry_master
3410 && sym->attr.dummy));
3413 tmp = gfc_conv_expr_present (sym);
3414 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3416 gfc_add_expr_to_block (&block, stmt);
3418 /* Add the main function body. */
3419 gfc_add_expr_to_block (&block, body);
3424 gfc_start_block (&cleanup);
3426 if (sym->attr.intent != INTENT_IN)
3428 /* Copy the data back. */
3429 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3430 tmp = gfc_chainon_list (tmp, tmpdesc);
3431 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3432 gfc_add_expr_to_block (&cleanup, tmp);
3435 /* Free the temporary. */
3436 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3437 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3438 gfc_add_expr_to_block (&cleanup, tmp);
3440 stmt = gfc_finish_block (&cleanup);
3442 /* Only do the cleanup if the array was repacked. */
3443 tmp = gfc_build_indirect_ref (dumdesc);
3444 tmp = gfc_conv_descriptor_data_get (tmp);
3445 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3446 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3450 tmp = gfc_conv_expr_present (sym);
3451 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3453 gfc_add_expr_to_block (&block, stmt);
3455 /* We don't need to free any memory allocated by internal_pack as it will
3456 be freed at the end of the function by pop_context. */
3457 return gfc_finish_block (&block);
3461 /* Convert an array for passing as an actual parameter. Expressions and
3462 vector subscripts are evaluated and stored in a temporary, which is then
3463 passed. For whole arrays the descriptor is passed. For array sections
3464 a modified copy of the descriptor is passed, but using the original data.
3465 Also used for array pointer assignments by setting se->direct_byref. */
3468 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3484 gcc_assert (ss != gfc_ss_terminator);
3486 /* TODO: Pass constant array constructors without a temporary. */
3487 /* Special case things we know we can pass easily. */
3488 switch (expr->expr_type)
3491 /* If we have a linear array section, we can pass it directly.
3492 Otherwise we need to copy it into a temporary. */
3494 /* Find the SS for the array section. */
3496 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3497 secss = secss->next;
3499 gcc_assert (secss != gfc_ss_terminator);
3502 for (n = 0; n < secss->data.info.dimen; n++)
3504 vss = secss->data.info.subscript[secss->data.info.dim[n]];
3505 if (vss && vss->type == GFC_SS_VECTOR)
3509 info = &secss->data.info;
3511 /* Get the descriptor for the array. */
3512 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3513 desc = info->descriptor;
3514 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3516 /* Create a new descriptor if the array doesn't have one. */
3519 else if (info->ref->u.ar.type == AR_FULL)
3521 else if (se->direct_byref)
3526 gcc_assert (ref->u.ar.type == AR_SECTION);
3529 for (n = 0; n < ref->u.ar.dimen; n++)
3531 /* Detect passing the full array as a section. This could do
3532 even more checking, but it doesn't seem worth it. */
3533 if (ref->u.ar.start[n]
3535 || (ref->u.ar.stride[n]
3536 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3544 /* Check for substring references. */
3546 if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
3550 if (ref->type == REF_SUBSTRING)
3552 /* In general character substrings need a copy. Character
3553 array strides are expressed as multiples of the element
3554 size (consistent with other array types), not in
3563 if (se->direct_byref)
3565 /* Copy the descriptor for pointer assignments. */
3566 gfc_add_modify_expr (&se->pre, se->expr, desc);
3568 else if (se->want_pointer)
3570 /* We pass full arrays directly. This means that pointers and
3571 allocatable arrays should also work. */
3572 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3579 if (expr->ts.type == BT_CHARACTER)
3580 se->string_length = gfc_get_expr_charlen (expr);
3587 /* A transformational function return value will be a temporary
3588 array descriptor. We still need to go through the scalarizer
3589 to create the descriptor. Elemental functions ar handled as
3590 arbitrary expressions, i.e. copy to a temporary. */
3592 /* Look for the SS for this function. */
3593 while (secss != gfc_ss_terminator
3594 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3595 secss = secss->next;
3597 if (se->direct_byref)
3599 gcc_assert (secss != gfc_ss_terminator);
3601 /* For pointer assignments pass the descriptor directly. */
3603 se->expr = gfc_build_addr_expr (NULL, se->expr);
3604 gfc_conv_expr (se, expr);
3608 if (secss == gfc_ss_terminator)
3610 /* Elemental function. */
3616 /* Transformational function. */
3617 info = &secss->data.info;
3623 /* Something complicated. Copy it into a temporary. */
3631 gfc_init_loopinfo (&loop);
3633 /* Associate the SS with the loop. */
3634 gfc_add_ss_to_loop (&loop, ss);
3636 /* Tell the scalarizer not to bother creating loop variables, etc. */
3638 loop.array_parameter = 1;
3640 gcc_assert (se->want_pointer && !se->direct_byref);
3642 /* Setup the scalarizing loops and bounds. */
3643 gfc_conv_ss_startstride (&loop);
3647 /* Tell the scalarizer to make a temporary. */
3648 loop.temp_ss = gfc_get_ss ();
3649 loop.temp_ss->type = GFC_SS_TEMP;
3650 loop.temp_ss->next = gfc_ss_terminator;
3651 if (expr->ts.type == BT_CHARACTER)
3653 gcc_assert (expr->ts.cl && expr->ts.cl->length
3654 && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
3655 loop.temp_ss->string_length = gfc_conv_mpz_to_tree
3656 (expr->ts.cl->length->value.integer,
3657 expr->ts.cl->length->ts.kind);
3658 expr->ts.cl->backend_decl = loop.temp_ss->string_length;
3660 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3662 /* ... which can hold our string, if present. */
3663 if (expr->ts.type == BT_CHARACTER)
3665 loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3666 se->string_length = loop.temp_ss->string_length;
3669 loop.temp_ss->string_length = NULL;
3670 loop.temp_ss->data.temp.dimen = loop.dimen;
3671 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3674 gfc_conv_loop_setup (&loop);
3678 /* Copy into a temporary and pass that. We don't need to copy the data
3679 back because expressions and vector subscripts must be INTENT_IN. */
3680 /* TODO: Optimize passing function return values. */
3684 /* Start the copying loops. */
3685 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3686 gfc_mark_ss_chain_used (ss, 1);
3687 gfc_start_scalarized_body (&loop, &block);
3689 /* Copy each data element. */
3690 gfc_init_se (&lse, NULL);
3691 gfc_copy_loopinfo_to_se (&lse, &loop);
3692 gfc_init_se (&rse, NULL);
3693 gfc_copy_loopinfo_to_se (&rse, &loop);
3695 lse.ss = loop.temp_ss;
3698 gfc_conv_scalarized_array_ref (&lse, NULL);
3699 if (expr->ts.type == BT_CHARACTER)
3701 gfc_conv_expr (&rse, expr);
3702 rse.expr = gfc_build_indirect_ref (rse.expr);
3705 gfc_conv_expr_val (&rse, expr);
3707 gfc_add_block_to_block (&block, &rse.pre);
3708 gfc_add_block_to_block (&block, &lse.pre);
3710 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3712 /* Finish the copying loops. */
3713 gfc_trans_scalarizing_loops (&loop, &block);
3715 /* Set the first stride component to zero to indicate a temporary. */
3716 desc = loop.temp_ss->data.info.descriptor;
3717 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3718 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3720 gcc_assert (is_gimple_lvalue (desc));
3721 se->expr = gfc_build_addr_expr (NULL, desc);
3723 else if (expr->expr_type == EXPR_FUNCTION)
3725 desc = info->descriptor;
3727 if (se->want_pointer)
3728 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3732 if (expr->ts.type == BT_CHARACTER)
3733 se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
3737 /* We pass sections without copying to a temporary. Make a new
3738 descriptor and point it at the section we want. The loop variable
3739 limits will be the limits of the section.
3740 A function may decide to repack the array to speed up access, but
3741 we're not bothered about that here. */
3750 /* Set the string_length for a character array. */
3751 if (expr->ts.type == BT_CHARACTER)
3752 se->string_length = gfc_get_expr_charlen (expr);
3754 desc = info->descriptor;
3755 gcc_assert (secss && secss != gfc_ss_terminator);
3756 if (se->direct_byref)
3758 /* For pointer assignments we fill in the destination. */
3760 parmtype = TREE_TYPE (parm);
3764 /* Otherwise make a new one. */
3765 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3766 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3767 loop.from, loop.to, 0);
3768 parm = gfc_create_var (parmtype, "parm");
3771 offset = gfc_index_zero_node;
3774 /* The following can be somewhat confusing. We have two
3775 descriptors, a new one and the original array.
3776 {parm, parmtype, dim} refer to the new one.
3777 {desc, type, n, secss, loop} refer to the original, which maybe
3778 a descriptorless array.
3779 The bounds of the scalarization are the bounds of the section.
3780 We don't have to worry about numeric overflows when calculating
3781 the offsets because all elements are within the array data. */
3783 /* Set the dtype. */
3784 tmp = gfc_conv_descriptor_dtype (parm);
3785 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
3787 if (se->direct_byref)
3788 base = gfc_index_zero_node;
3792 for (n = 0; n < info->ref->u.ar.dimen; n++)
3794 stride = gfc_conv_array_stride (desc, n);
3796 /* Work out the offset. */
3797 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3799 gcc_assert (info->subscript[n]
3800 && info->subscript[n]->type == GFC_SS_SCALAR);
3801 start = info->subscript[n]->data.scalar.expr;
3805 /* Check we haven't somehow got out of sync. */
3806 gcc_assert (info->dim[dim] == n);
3808 /* Evaluate and remember the start of the section. */
3809 start = info->start[dim];
3810 stride = gfc_evaluate_now (stride, &loop.pre);
3813 tmp = gfc_conv_array_lbound (desc, n);
3814 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
3816 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
3817 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
3819 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3821 /* For elemental dimensions, we only need the offset. */
3825 /* Vector subscripts need copying and are handled elsewhere. */
3826 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
3828 /* Set the new lower bound. */
3829 from = loop.from[dim];
3831 if (!integer_onep (from))
3833 /* Make sure the new section starts at 1. */
3834 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3835 gfc_index_one_node, from);
3836 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
3837 from = gfc_index_one_node;
3839 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
3840 gfc_add_modify_expr (&loop.pre, tmp, from);
3842 /* Set the new upper bound. */
3843 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
3844 gfc_add_modify_expr (&loop.pre, tmp, to);
3846 /* Multiply the stride by the section stride to get the
3848 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
3849 stride, info->stride[dim]);
3851 if (se->direct_byref)
3852 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
3855 /* Store the new stride. */
3856 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
3857 gfc_add_modify_expr (&loop.pre, tmp, stride);
3862 /* Point the data pointer at the first element in the section. */
3863 tmp = gfc_conv_array_data (desc);
3864 tmp = gfc_build_indirect_ref (tmp);
3865 tmp = gfc_build_array_ref (tmp, offset);
3866 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
3867 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
3869 if (se->direct_byref)
3871 /* Set the offset. */
3872 tmp = gfc_conv_descriptor_offset (parm);
3873 gfc_add_modify_expr (&loop.pre, tmp, base);
3877 /* Only the callee knows what the correct offset it, so just set
3879 tmp = gfc_conv_descriptor_offset (parm);
3880 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3883 if (!se->direct_byref)
3885 /* Get a pointer to the new descriptor. */
3886 if (se->want_pointer)
3887 se->expr = gfc_build_addr_expr (NULL, parm);
3893 gfc_add_block_to_block (&se->pre, &loop.pre);
3894 gfc_add_block_to_block (&se->post, &loop.post);
3896 /* Cleanup the scalarizer. */
3897 gfc_cleanup_loop (&loop);
3901 /* Convert an array for passing as an actual parameter. */
3902 /* TODO: Optimize passing g77 arrays. */
3905 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
3914 /* Passing address of the array if it is not pointer or assumed-shape. */
3915 if (expr->expr_type == EXPR_VARIABLE
3916 && expr->ref->u.ar.type == AR_FULL && g77)
3918 sym = expr->symtree->n.sym;
3919 tmp = gfc_get_symbol_decl (sym);
3920 if (sym->ts.type == BT_CHARACTER)
3921 se->string_length = sym->ts.cl->backend_decl;
3922 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
3923 && !sym->attr.allocatable)
3925 /* Some variables are declared directly, others are declared as
3926 pointers and allocated on the heap. */
3927 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
3930 se->expr = gfc_build_addr_expr (NULL, tmp);
3933 if (sym->attr.allocatable)
3935 se->expr = gfc_conv_array_data (tmp);
3940 se->want_pointer = 1;
3941 gfc_conv_expr_descriptor (se, expr, ss);
3946 /* Repack the array. */
3947 tmp = gfc_chainon_list (NULL_TREE, desc);
3948 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3949 ptr = gfc_evaluate_now (ptr, &se->pre);
3952 gfc_start_block (&block);
3954 /* Copy the data back. */
3955 tmp = gfc_chainon_list (NULL_TREE, desc);
3956 tmp = gfc_chainon_list (tmp, ptr);
3957 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3958 gfc_add_expr_to_block (&block, tmp);
3960 /* Free the temporary. */
3961 tmp = convert (pvoid_type_node, ptr);
3962 tmp = gfc_chainon_list (NULL_TREE, tmp);
3963 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3964 gfc_add_expr_to_block (&block, tmp);
3966 stmt = gfc_finish_block (&block);
3968 gfc_init_block (&block);
3969 /* Only if it was repacked. This code needs to be executed before the
3970 loop cleanup code. */
3971 tmp = gfc_build_indirect_ref (desc);
3972 tmp = gfc_conv_array_data (tmp);
3973 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
3974 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3976 gfc_add_expr_to_block (&block, tmp);
3977 gfc_add_block_to_block (&block, &se->post);
3979 gfc_init_block (&se->post);
3980 gfc_add_block_to_block (&se->post, &block);
3985 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3988 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
3995 stmtblock_t fnblock;
3998 /* Make sure the frontend gets these right. */
3999 if (!(sym->attr.pointer || sym->attr.allocatable))
4001 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4003 gfc_init_block (&fnblock);
4005 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
4006 if (sym->ts.type == BT_CHARACTER
4007 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4008 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4010 /* Parameter and use associated variables don't need anything special. */
4011 if (sym->attr.dummy || sym->attr.use_assoc)
4013 gfc_add_expr_to_block (&fnblock, body);
4015 return gfc_finish_block (&fnblock);
4018 gfc_get_backend_locus (&loc);
4019 gfc_set_backend_locus (&sym->declared_at);
4020 descriptor = sym->backend_decl;
4022 if (TREE_STATIC (descriptor))
4024 /* SAVEd variables are not freed on exit. */
4025 gfc_trans_static_array_pointer (sym);
4029 /* Get the descriptor type. */
4030 type = TREE_TYPE (sym->backend_decl);
4031 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4033 /* NULLIFY the data pointer. */
4034 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4036 gfc_add_expr_to_block (&fnblock, body);
4038 gfc_set_backend_locus (&loc);
4039 /* Allocatable arrays need to be freed when they go out of scope. */
4040 if (sym->attr.allocatable)
4042 gfc_start_block (&block);
4044 /* Deallocate if still allocated at the end of the procedure. */
4045 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4047 tmp = gfc_conv_descriptor_data_get (descriptor);
4048 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4049 build_int_cst (TREE_TYPE (tmp), 0));
4050 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4051 gfc_add_expr_to_block (&block, tmp);
4053 tmp = gfc_finish_block (&block);
4054 gfc_add_expr_to_block (&fnblock, tmp);
4057 return gfc_finish_block (&fnblock);
4060 /************ Expression Walking Functions ******************/
4062 /* Walk a variable reference.
4064 Possible extension - multiple component subscripts.
4065 x(:,:) = foo%a(:)%b(:)
4067 forall (i=..., j=...)
4068 x(i,j) = foo%a(j)%b(i)
4070 This adds a fair amout of complexity because you need to deal with more
4071 than one ref. Maybe handle in a similar manner to vector subscripts.
4072 Maybe not worth the effort. */
4076 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4084 for (ref = expr->ref; ref; ref = ref->next)
4086 /* We're only interested in array sections. */
4087 if (ref->type != REF_ARRAY)
4094 /* TODO: Take elemental array references out of scalarization
4099 newss = gfc_get_ss ();
4100 newss->type = GFC_SS_SECTION;
4103 newss->data.info.dimen = ar->as->rank;
4104 newss->data.info.ref = ref;
4106 /* Make sure array is the same as array(:,:), this way
4107 we don't need to special case all the time. */
4108 ar->dimen = ar->as->rank;
4109 for (n = 0; n < ar->dimen; n++)
4111 newss->data.info.dim[n] = n;
4112 ar->dimen_type[n] = DIMEN_RANGE;
4114 gcc_assert (ar->start[n] == NULL);
4115 gcc_assert (ar->end[n] == NULL);
4116 gcc_assert (ar->stride[n] == NULL);
4121 newss = gfc_get_ss ();
4122 newss->type = GFC_SS_SECTION;
4125 newss->data.info.dimen = 0;
4126 newss->data.info.ref = ref;
4130 /* We add SS chains for all the subscripts in the section. */
4131 for (n = 0; n < ar->dimen; n++)
4135 switch (ar->dimen_type[n])
4138 /* Add SS for elemental (scalar) subscripts. */
4139 gcc_assert (ar->start[n]);
4140 indexss = gfc_get_ss ();
4141 indexss->type = GFC_SS_SCALAR;
4142 indexss->expr = ar->start[n];
4143 indexss->next = gfc_ss_terminator;
4144 indexss->loop_chain = gfc_ss_terminator;
4145 newss->data.info.subscript[n] = indexss;
4149 /* We don't add anything for sections, just remember this
4150 dimension for later. */
4151 newss->data.info.dim[newss->data.info.dimen] = n;
4152 newss->data.info.dimen++;
4156 /* Get a SS for the vector. This will not be added to the
4158 indexss = gfc_walk_expr (ar->start[n]);
4159 if (indexss == gfc_ss_terminator)
4160 internal_error ("scalar vector subscript???");
4162 /* We currently only handle really simple vector
4164 if (indexss->next != gfc_ss_terminator)
4165 gfc_todo_error ("vector subscript expressions");
4166 indexss->loop_chain = gfc_ss_terminator;
4168 /* Mark this as a vector subscript. We don't add this
4169 directly into the chain, but as a subscript of the
4170 existing SS for this term. */
4171 indexss->type = GFC_SS_VECTOR;
4172 newss->data.info.subscript[n] = indexss;
4173 /* Also remember this dimension. */
4174 newss->data.info.dim[newss->data.info.dimen] = n;
4175 newss->data.info.dimen++;
4179 /* We should know what sort of section it is by now. */
4183 /* We should have at least one non-elemental dimension. */
4184 gcc_assert (newss->data.info.dimen > 0);
4189 /* We should know what sort of section it is by now. */
4198 /* Walk an expression operator. If only one operand of a binary expression is
4199 scalar, we must also add the scalar term to the SS chain. */
4202 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4208 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4209 if (expr->value.op.op2 == NULL)
4212 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4214 /* All operands are scalar. Pass back and let the caller deal with it. */
4218 /* All operands require scalarization. */
4219 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4222 /* One of the operands needs scalarization, the other is scalar.
4223 Create a gfc_ss for the scalar expression. */
4224 newss = gfc_get_ss ();
4225 newss->type = GFC_SS_SCALAR;
4228 /* First operand is scalar. We build the chain in reverse order, so
4229 add the scarar SS after the second operand. */
4231 while (head && head->next != ss)
4233 /* Check we haven't somehow broken the chain. */
4237 newss->expr = expr->value.op.op1;
4239 else /* head2 == head */
4241 gcc_assert (head2 == head);
4242 /* Second operand is scalar. */
4243 newss->next = head2;
4245 newss->expr = expr->value.op.op2;
4252 /* Reverse a SS chain. */
4255 gfc_reverse_ss (gfc_ss * ss)
4260 gcc_assert (ss != NULL);
4262 head = gfc_ss_terminator;
4263 while (ss != gfc_ss_terminator)
4266 /* Check we didn't somehow break the chain. */
4267 gcc_assert (next != NULL);
4277 /* Walk the arguments of an elemental function. */
4280 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4283 gfc_actual_arglist *arg;
4289 head = gfc_ss_terminator;
4292 for (arg = expr->value.function.actual; arg; arg = arg->next)
4297 newss = gfc_walk_subexpr (head, arg->expr);
4300 /* Scalar argument. */
4301 newss = gfc_get_ss ();
4303 newss->expr = arg->expr;
4313 while (tail->next != gfc_ss_terminator)
4320 /* If all the arguments are scalar we don't need the argument SS. */
4321 gfc_free_ss_chain (head);
4326 /* Add it onto the existing chain. */
4332 /* Walk a function call. Scalar functions are passed back, and taken out of
4333 scalarization loops. For elemental functions we walk their arguments.
4334 The result of functions returning arrays is stored in a temporary outside
4335 the loop, so that the function is only called once. Hence we do not need
4336 to walk their arguments. */
4339 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4342 gfc_intrinsic_sym *isym;
4345 isym = expr->value.function.isym;
4347 /* Handle intrinsic functions separately. */
4349 return gfc_walk_intrinsic_function (ss, expr, isym);
4351 sym = expr->value.function.esym;
4353 sym = expr->symtree->n.sym;
4355 /* A function that returns arrays. */
4356 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4358 newss = gfc_get_ss ();
4359 newss->type = GFC_SS_FUNCTION;
4362 newss->data.info.dimen = expr->rank;
4366 /* Walk the parameters of an elemental function. For now we always pass
4368 if (sym->attr.elemental)
4369 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4371 /* Scalar functions are OK as these are evaluated outside the scalarization
4372 loop. Pass back and let the caller deal with it. */
4377 /* An array temporary is constructed for array constructors. */
4380 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4385 newss = gfc_get_ss ();
4386 newss->type = GFC_SS_CONSTRUCTOR;
4389 newss->data.info.dimen = expr->rank;
4390 for (n = 0; n < expr->rank; n++)
4391 newss->data.info.dim[n] = n;
4397 /* Walk an expression. Add walked expressions to the head of the SS chain.
4398 A wholly scalar expression will not be added. */
4401 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4405 switch (expr->expr_type)
4408 head = gfc_walk_variable_expr (ss, expr);
4412 head = gfc_walk_op_expr (ss, expr);
4416 head = gfc_walk_function_expr (ss, expr);
4421 case EXPR_STRUCTURE:
4422 /* Pass back and let the caller deal with it. */
4426 head = gfc_walk_array_constructor (ss, expr);
4429 case EXPR_SUBSTRING:
4430 /* Pass back and let the caller deal with it. */
4434 internal_error ("bad expression type during walk (%d)",
4441 /* Entry point for expression walking.
4442 A return value equal to the passed chain means this is
4443 a scalar expression. It is up to the caller to take whatever action is
4444 necessary to translate these. */
4447 gfc_walk_expr (gfc_expr * expr)
4451 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4452 return gfc_reverse_ss (res);