1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004 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, 59 Temple Place - Suite 330, 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"
92 #include "trans-stmt.h"
93 #include "trans-types.h"
94 #include "trans-array.h"
95 #include "trans-const.h"
96 #include "dependency.h"
98 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
104 unsigned HOST_WIDE_INT gfc_stack_space_left;
107 /* Returns true if a variable of specified size should go on the stack. */
110 gfc_can_put_var_on_stack (tree size)
112 unsigned HOST_WIDE_INT low;
114 if (!INTEGER_CST_P (size))
117 if (gfc_option.flag_max_stack_var_size < 0)
120 if (TREE_INT_CST_HIGH (size) != 0)
123 low = TREE_INT_CST_LOW (size);
124 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
127 /* TODO: Set a per-function stack size limit. */
129 /* We should be a bit more clever with array temps. */
130 if (gfc_option.flag_max_function_vars_size >= 0)
132 if (low > gfc_stack_space_left)
135 gfc_stack_space_left -= low;
143 gfc_array_dataptr_type (tree desc)
145 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
149 /* Build expressions to access the members of an array descriptor.
150 It's surprisingly easy to mess up here, so never access
151 an array descriptor by "brute force", always use these
152 functions. This also avoids problems if we change the format
153 of an array descriptor.
155 To understand these magic numbers, look at the comments
156 before gfc_build_array_type() in trans-types.c.
158 The code within these defines should be the only code which knows the format
159 of an array descriptor.
161 Any code just needing to read obtain the bounds of an array should use
162 gfc_conv_array_* rather than the following functions as these will return
163 know constant values, and work with arrays which do not have descriptors.
165 Don't forget to #undef these! */
168 #define OFFSET_FIELD 1
169 #define DTYPE_FIELD 2
170 #define DIMENSION_FIELD 3
172 #define STRIDE_SUBFIELD 0
173 #define LBOUND_SUBFIELD 1
174 #define UBOUND_SUBFIELD 2
177 gfc_conv_descriptor_data (tree desc)
182 type = TREE_TYPE (desc);
183 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
185 field = TYPE_FIELDS (type);
186 gcc_assert (DATA_FIELD == 0);
187 gcc_assert (field != NULL_TREE
188 && TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
189 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == ARRAY_TYPE);
191 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
195 gfc_conv_descriptor_offset (tree desc)
200 type = TREE_TYPE (desc);
201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
203 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
204 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
206 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
210 gfc_conv_descriptor_dtype (tree desc)
215 type = TREE_TYPE (desc);
216 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
218 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
219 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
221 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
225 gfc_conv_descriptor_dimension (tree desc, tree dim)
231 type = TREE_TYPE (desc);
232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
234 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
235 gcc_assert (field != NULL_TREE
236 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
237 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
239 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
240 tmp = gfc_build_array_ref (tmp, dim);
245 gfc_conv_descriptor_stride (tree desc, tree dim)
250 tmp = gfc_conv_descriptor_dimension (desc, dim);
251 field = TYPE_FIELDS (TREE_TYPE (tmp));
252 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
253 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
255 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
260 gfc_conv_descriptor_lbound (tree desc, tree dim)
265 tmp = gfc_conv_descriptor_dimension (desc, dim);
266 field = TYPE_FIELDS (TREE_TYPE (tmp));
267 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
268 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
270 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
275 gfc_conv_descriptor_ubound (tree desc, tree dim)
280 tmp = gfc_conv_descriptor_dimension (desc, dim);
281 field = TYPE_FIELDS (TREE_TYPE (tmp));
282 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
285 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
290 /* Build an null array descriptor constructor. */
293 gfc_build_null_descriptor (tree type)
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
299 gcc_assert (DATA_FIELD == 0);
300 field = TYPE_FIELDS (type);
302 /* Set a NULL data pointer. */
303 tmp = tree_cons (field, null_pointer_node, NULL_TREE);
304 tmp = build1 (CONSTRUCTOR, type, tmp);
305 TREE_CONSTANT (tmp) = 1;
306 TREE_INVARIANT (tmp) = 1;
307 /* All other fields are ignored. */
313 /* Cleanup those #defines. */
318 #undef DIMENSION_FIELD
319 #undef STRIDE_SUBFIELD
320 #undef LBOUND_SUBFIELD
321 #undef UBOUND_SUBFIELD
324 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
325 flags & 1 = Main loop body.
326 flags & 2 = temp copy loop. */
329 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
331 for (; ss != gfc_ss_terminator; ss = ss->next)
332 ss->useflags = flags;
335 static void gfc_free_ss (gfc_ss *);
338 /* Free a gfc_ss chain. */
341 gfc_free_ss_chain (gfc_ss * ss)
345 while (ss != gfc_ss_terminator)
347 gcc_assert (ss != NULL);
358 gfc_free_ss (gfc_ss * ss)
366 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
368 if (ss->data.info.subscript[n])
369 gfc_free_ss_chain (ss->data.info.subscript[n]);
381 /* Free all the SS associated with a loop. */
384 gfc_cleanup_loop (gfc_loopinfo * loop)
390 while (ss != gfc_ss_terminator)
392 gcc_assert (ss != NULL);
393 next = ss->loop_chain;
400 /* Associate a SS chain with a loop. */
403 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
407 if (head == gfc_ss_terminator)
411 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
413 if (ss->next == gfc_ss_terminator)
414 ss->loop_chain = loop->ss;
416 ss->loop_chain = ss->next;
418 gcc_assert (ss == gfc_ss_terminator);
423 /* Generate an initializer for a static pointer or allocatable array. */
426 gfc_trans_static_array_pointer (gfc_symbol * sym)
430 gcc_assert (TREE_STATIC (sym->backend_decl));
431 /* Just zero the data member. */
432 type = TREE_TYPE (sym->backend_decl);
433 DECL_INITIAL (sym->backend_decl) =gfc_build_null_descriptor (type);
437 /* Generate code to allocate an array temporary, or create a variable to
438 hold the data. If size is NULL zero the descriptor so that so that the
439 callee will allocate the array. Also generates code to free the array
443 gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
444 tree size, tree nelem)
452 desc = info->descriptor;
453 data = gfc_conv_descriptor_data (desc);
454 if (size == NULL_TREE)
456 /* A callee allocated array. */
457 gfc_add_modify_expr (&loop->pre, data, convert (TREE_TYPE (data),
458 gfc_index_zero_node));
460 info->offset = gfc_index_zero_node;
465 /* Allocate the temporary. */
466 onstack = gfc_can_put_var_on_stack (size);
470 /* Make a temporary variable to hold the data. */
471 tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
473 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
475 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
477 tmp = gfc_create_var (tmp, "A");
478 tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
479 gfc_add_modify_expr (&loop->pre, data, tmp);
481 info->offset = gfc_index_zero_node;
486 /* Allocate memory to hold the data. */
487 args = gfc_chainon_list (NULL_TREE, size);
489 if (gfc_index_integer_kind == 4)
490 tmp = gfor_fndecl_internal_malloc;
491 else if (gfc_index_integer_kind == 8)
492 tmp = gfor_fndecl_internal_malloc64;
495 tmp = gfc_build_function_call (tmp, args);
496 tmp = convert (TREE_TYPE (data), tmp);
497 gfc_add_modify_expr (&loop->pre, data, tmp);
500 info->offset = gfc_index_zero_node;
504 /* The offset is zero because we create temporaries with a zero
506 tmp = gfc_conv_descriptor_offset (desc);
507 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
511 /* Free the temporary. */
512 tmp = convert (pvoid_type_node, info->data);
513 tmp = gfc_chainon_list (NULL_TREE, tmp);
514 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
515 gfc_add_expr_to_block (&loop->post, tmp);
520 /* Generate code to allocate and initialize the descriptor for a temporary
521 array. This is used for both temporaries needed by the scaparizer, and
522 functions returning arrays. Adjusts the loop variables to be zero-based,
523 and calculates the loop bounds for callee allocated arrays.
524 Also fills in the descriptor, data and offset fields of info if known.
525 Returns the size of the array, or NULL for a callee allocated array. */
528 gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
539 gcc_assert (info->dimen > 0);
540 /* Set the lower bound to zero. */
541 for (dim = 0; dim < info->dimen; dim++)
543 n = loop->order[dim];
544 if (n < loop->temp_dim)
545 gcc_assert (integer_zerop (loop->from[n]));
548 /* Callee allocated arrays may not have a known bound yet. */
550 loop->to[n] = fold (build2 (MINUS_EXPR, gfc_array_index_type,
551 loop->to[n], loop->from[n]));
552 loop->from[n] = gfc_index_zero_node;
555 info->delta[dim] = gfc_index_zero_node;
556 info->start[dim] = gfc_index_zero_node;
557 info->stride[dim] = gfc_index_one_node;
558 info->dim[dim] = dim;
561 /* Initialize the descriptor. */
563 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
564 desc = gfc_create_var (type, "atmp");
565 GFC_DECL_PACKED_ARRAY (desc) = 1;
567 info->descriptor = desc;
568 size = gfc_index_one_node;
570 /* Fill in the array dtype. */
571 tmp = gfc_conv_descriptor_dtype (desc);
572 gfc_add_modify_expr (&loop->pre, tmp,
573 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (desc)));
576 Fill in the bounds and stride. This is a packed array, so:
579 for (n = 0; n < rank; n++)
582 delta = ubound[n] + 1 - lbound[n];
585 size = size * sizeof(element);
588 for (n = 0; n < info->dimen; n++)
590 if (loop->to[n] == NULL_TREE)
592 /* For a callee allocated array express the loop bounds in terms
593 of the descriptor fields. */
594 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
595 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
596 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
602 /* Store the stride and bound components in the descriptor. */
603 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
604 gfc_add_modify_expr (&loop->pre, tmp, size);
606 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
607 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
609 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
610 gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
612 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
613 loop->to[n], gfc_index_one_node));
615 size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
616 size = gfc_evaluate_now (size, &loop->pre);
619 /* Get the size of the array. */
622 size = fold (build2 (MULT_EXPR, gfc_array_index_type, size,
623 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
625 gfc_trans_allocate_array_storage (loop, info, size, nelem);
627 if (info->dimen > loop->temp_dim)
628 loop->temp_dim = info->dimen;
634 /* Make sure offset is a variable. */
637 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
640 /* We should have already created the offset variable. We cannot
641 create it here because we may be in an inner scope. */
642 gcc_assert (*offsetvar != NULL_TREE);
643 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
644 *poffset = *offsetvar;
645 TREE_USED (*offsetvar) = 1;
649 /* Assign an element of an array constructor. */
652 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
653 tree offset, gfc_se * se, gfc_expr * expr)
658 gfc_conv_expr (se, expr);
660 /* Store the value. */
661 tmp = gfc_build_indirect_ref (pointer);
662 tmp = gfc_build_array_ref (tmp, offset);
663 if (expr->ts.type == BT_CHARACTER)
665 gfc_conv_string_parameter (se);
666 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
668 /* The temporary is an array of pointers. */
669 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
670 gfc_add_modify_expr (&se->pre, tmp, se->expr);
674 /* The temporary is an array of string values. */
675 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
676 /* We know the temporary and the value will be the same length,
677 so can use memcpy. */
678 args = gfc_chainon_list (NULL_TREE, tmp);
679 args = gfc_chainon_list (args, se->expr);
680 args = gfc_chainon_list (args, se->string_length);
681 tmp = built_in_decls[BUILT_IN_MEMCPY];
682 tmp = gfc_build_function_call (tmp, args);
683 gfc_add_expr_to_block (&se->pre, tmp);
688 /* TODO: Should the frontend already have done this conversion? */
689 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
690 gfc_add_modify_expr (&se->pre, tmp, se->expr);
693 gfc_add_block_to_block (pblock, &se->pre);
694 gfc_add_block_to_block (pblock, &se->post);
698 /* Add the contents of an array to the constructor. */
701 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
702 tree type ATTRIBUTE_UNUSED,
703 tree pointer, gfc_expr * expr,
704 tree * poffset, tree * offsetvar)
712 /* We need this to be a variable so we can increment it. */
713 gfc_put_offset_into_var (pblock, poffset, offsetvar);
715 gfc_init_se (&se, NULL);
717 /* Walk the array expression. */
718 ss = gfc_walk_expr (expr);
719 gcc_assert (ss != gfc_ss_terminator);
721 /* Initialize the scalarizer. */
722 gfc_init_loopinfo (&loop);
723 gfc_add_ss_to_loop (&loop, ss);
725 /* Initialize the loop. */
726 gfc_conv_ss_startstride (&loop);
727 gfc_conv_loop_setup (&loop);
729 /* Make the loop body. */
730 gfc_mark_ss_chain_used (ss, 1);
731 gfc_start_scalarized_body (&loop, &body);
732 gfc_copy_loopinfo_to_se (&se, &loop);
735 if (expr->ts.type == BT_CHARACTER)
736 gfc_todo_error ("character arrays in constructors");
738 gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
739 gcc_assert (se.ss == gfc_ss_terminator);
741 /* Increment the offset. */
742 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
743 gfc_add_modify_expr (&body, *poffset, tmp);
745 /* Finish the loop. */
746 gfc_trans_scalarizing_loops (&loop, &body);
747 gfc_add_block_to_block (&loop.pre, &loop.post);
748 tmp = gfc_finish_block (&loop.pre);
749 gfc_add_expr_to_block (pblock, tmp);
751 gfc_cleanup_loop (&loop);
755 /* Assign the values to the elements of an array constructor. */
758 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
759 tree pointer, gfc_constructor * c,
760 tree * poffset, tree * offsetvar)
767 for (; c; c = c->next)
769 /* If this is an iterator or an array, the offset must be a variable. */
770 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
771 gfc_put_offset_into_var (pblock, poffset, offsetvar);
773 gfc_start_block (&body);
775 if (c->expr->expr_type == EXPR_ARRAY)
777 /* Array constructors can be nested. */
778 gfc_trans_array_constructor_value (&body, type, pointer,
779 c->expr->value.constructor,
782 else if (c->expr->rank > 0)
784 gfc_trans_array_constructor_subarray (&body, type, pointer,
785 c->expr, poffset, offsetvar);
789 /* This code really upsets the gimplifier so don't bother for now. */
796 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
804 gfc_init_se (&se, NULL);
805 gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
808 *poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
809 *poffset, gfc_index_one_node));
813 /* Collect multiple scalar constants into a constructor. */
821 /* Count the number of consecutive scalar constants. */
822 while (p && !(p->iterator
823 || p->expr->expr_type != EXPR_CONSTANT))
825 gfc_init_se (&se, NULL);
826 gfc_conv_constant (&se, p->expr);
827 if (p->expr->ts.type == BT_CHARACTER
828 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
829 (TREE_TYPE (pointer)))))
831 /* For constant character array constructors we build
832 an array of pointers. */
833 se.expr = gfc_build_addr_expr (pchar_type_node,
837 list = tree_cons (NULL_TREE, se.expr, list);
842 bound = build_int_cst (NULL_TREE, n - 1);
843 /* Create an array type to hold them. */
844 tmptype = build_range_type (gfc_array_index_type,
845 gfc_index_zero_node, bound);
846 tmptype = build_array_type (type, tmptype);
848 init = build1 (CONSTRUCTOR, tmptype, nreverse (list));
849 TREE_CONSTANT (init) = 1;
850 TREE_INVARIANT (init) = 1;
851 TREE_STATIC (init) = 1;
852 /* Create a static variable to hold the data. */
853 tmp = gfc_create_var (tmptype, "data");
854 TREE_STATIC (tmp) = 1;
855 TREE_CONSTANT (tmp) = 1;
856 TREE_INVARIANT (tmp) = 1;
857 DECL_INITIAL (tmp) = init;
860 /* Use BUILTIN_MEMCPY to assign the values. */
861 tmp = gfc_build_indirect_ref (pointer);
862 tmp = gfc_build_array_ref (tmp, *poffset);
863 tmp = gfc_build_addr_expr (NULL, tmp);
864 init = gfc_build_addr_expr (NULL, init);
866 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
867 bound = build_int_cst (NULL_TREE, n * size);
868 tmp = gfc_chainon_list (NULL_TREE, tmp);
869 tmp = gfc_chainon_list (tmp, init);
870 tmp = gfc_chainon_list (tmp, bound);
871 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
873 gfc_add_expr_to_block (&body, tmp);
875 *poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
878 if (!INTEGER_CST_P (*poffset))
880 gfc_add_modify_expr (&body, *offsetvar, *poffset);
881 *poffset = *offsetvar;
885 /* The frontend should already have done any expansions. */
893 loopbody = gfc_finish_block (&body);
895 gfc_init_se (&se, NULL);
896 gfc_conv_expr (&se, c->iterator->var);
897 gfc_add_block_to_block (pblock, &se.pre);
900 /* Initialize the loop. */
901 gfc_init_se (&se, NULL);
902 gfc_conv_expr_val (&se, c->iterator->start);
903 gfc_add_block_to_block (pblock, &se.pre);
904 gfc_add_modify_expr (pblock, loopvar, se.expr);
906 gfc_init_se (&se, NULL);
907 gfc_conv_expr_val (&se, c->iterator->end);
908 gfc_add_block_to_block (pblock, &se.pre);
909 end = gfc_evaluate_now (se.expr, pblock);
911 gfc_init_se (&se, NULL);
912 gfc_conv_expr_val (&se, c->iterator->step);
913 gfc_add_block_to_block (pblock, &se.pre);
914 step = gfc_evaluate_now (se.expr, pblock);
916 /* Generate the loop body. */
917 exit_label = gfc_build_label_decl (NULL_TREE);
918 gfc_start_block (&body);
920 /* Generate the exit condition. */
921 end = build2 (GT_EXPR, boolean_type_node, loopvar, end);
922 tmp = build1_v (GOTO_EXPR, exit_label);
923 TREE_USED (exit_label) = 1;
924 tmp = build3_v (COND_EXPR, end, tmp, build_empty_stmt ());
925 gfc_add_expr_to_block (&body, tmp);
927 /* The main loop body. */
928 gfc_add_expr_to_block (&body, loopbody);
930 /* Increment the loop variable. */
931 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
932 gfc_add_modify_expr (&body, loopvar, tmp);
934 /* Finish the loop. */
935 tmp = gfc_finish_block (&body);
936 tmp = build1_v (LOOP_EXPR, tmp);
937 gfc_add_expr_to_block (pblock, tmp);
939 /* Add the exit label. */
940 tmp = build1_v (LABEL_EXPR, exit_label);
941 gfc_add_expr_to_block (pblock, tmp);
945 /* Pass the code as is. */
946 tmp = gfc_finish_block (&body);
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 teh sting 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 to avoid break 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 sructure. 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 (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 seperately. */
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 dela. */
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 seperately. */
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,
1687 indexse.expr, tmp));
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,
1693 indexse.expr, tmp));
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 /* Remeber 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 = NULL_TREE;
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,
2662 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (descriptor)));
2664 for (n = 0; n < rank; n++)
2666 /* We have 3 possibilities for determining the size of the array:
2667 lower == NULL => lbound = 1, ubound = upper[n]
2668 upper[n] = NULL => lbound = 1, ubound = lower[n]
2669 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2672 /* Set lower bound. */
2673 gfc_init_se (&se, NULL);
2675 se.expr = gfc_index_one_node;
2678 gcc_assert (lower[n]);
2681 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2682 gfc_add_block_to_block (pblock, &se.pre);
2686 se.expr = gfc_index_one_node;
2690 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2691 gfc_add_modify_expr (pblock, tmp, se.expr);
2693 /* Work out the offset for this component. */
2694 tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride));
2695 offset = fold (build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp));
2697 /* Start the calculation for the size of this dimension. */
2698 size = build2 (MINUS_EXPR, gfc_array_index_type,
2699 gfc_index_one_node, se.expr);
2701 /* Set upper bound. */
2702 gfc_init_se (&se, NULL);
2703 gcc_assert (ubound);
2704 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2705 gfc_add_block_to_block (pblock, &se.pre);
2707 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2708 gfc_add_modify_expr (pblock, tmp, se.expr);
2710 /* Store the stride. */
2711 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2712 gfc_add_modify_expr (pblock, tmp, stride);
2714 /* Calculate the size of this dimension. */
2715 size = fold (build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size));
2717 /* Multiply the stride by the number of elements in this dimension. */
2718 stride = fold (build2 (MULT_EXPR, gfc_array_index_type, stride, size));
2719 stride = gfc_evaluate_now (stride, pblock);
2722 /* The stride is the number of elements in the array, so multiply by the
2723 size of an element to get the total size. */
2724 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2725 size = fold (build2 (MULT_EXPR, gfc_array_index_type, stride, tmp));
2727 if (poffset != NULL)
2729 offset = gfc_evaluate_now (offset, pblock);
2733 size = gfc_evaluate_now (size, pblock);
2738 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2739 the work for an ALLOCATE statement. */
2743 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2753 /* Figure out the size of the array. */
2754 switch (ref->u.ar.type)
2758 upper = ref->u.ar.start;
2762 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2764 lower = ref->u.ar.as->lower;
2765 upper = ref->u.ar.as->upper;
2769 lower = ref->u.ar.start;
2770 upper = ref->u.ar.end;
2778 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2779 lower, upper, &se->pre);
2781 /* Allocate memory to store the data. */
2782 tmp = gfc_conv_descriptor_data (se->expr);
2783 pointer = gfc_build_addr_expr (NULL, tmp);
2784 pointer = gfc_evaluate_now (pointer, &se->pre);
2786 if (TYPE_PRECISION (gfc_array_index_type) == 32)
2787 allocate = gfor_fndecl_allocate;
2788 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2789 allocate = gfor_fndecl_allocate64;
2793 tmp = gfc_chainon_list (NULL_TREE, pointer);
2794 tmp = gfc_chainon_list (tmp, size);
2795 tmp = gfc_chainon_list (tmp, pstat);
2796 tmp = gfc_build_function_call (allocate, tmp);
2797 gfc_add_expr_to_block (&se->pre, tmp);
2799 pointer = gfc_conv_descriptor_data (se->expr);
2801 tmp = gfc_conv_descriptor_offset (se->expr);
2802 gfc_add_modify_expr (&se->pre, tmp, offset);
2806 /* Deallocate an array variable. Also used when an allocated variable goes
2811 gfc_array_deallocate (tree descriptor)
2817 gfc_start_block (&block);
2818 /* Get a pointer to the data. */
2819 tmp = gfc_conv_descriptor_data (descriptor);
2820 tmp = gfc_build_addr_expr (NULL, tmp);
2821 var = gfc_create_var (TREE_TYPE (tmp), "ptr");
2822 gfc_add_modify_expr (&block, var, tmp);
2824 /* Parameter is the address of the data component. */
2825 tmp = gfc_chainon_list (NULL_TREE, var);
2826 tmp = gfc_chainon_list (tmp, integer_zero_node);
2827 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2828 gfc_add_expr_to_block (&block, tmp);
2830 return gfc_finish_block (&block);
2834 /* Create an array constructor from an initialization expression.
2835 We assume the frontend already did any expansions and conversions. */
2838 gfc_conv_array_initializer (tree type, gfc_expr * expr)
2846 unsigned HOST_WIDE_INT lo;
2850 switch (expr->expr_type)
2853 case EXPR_STRUCTURE:
2854 /* A single scalar or derived type value. Create an array with all
2855 elements equal to that value. */
2856 gfc_init_se (&se, NULL);
2858 if (expr->expr_type == EXPR_CONSTANT)
2859 gfc_conv_constant (&se, expr);
2861 gfc_conv_structure (&se, expr, 1);
2863 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2864 gcc_assert (tmp && INTEGER_CST_P (tmp));
2865 hi = TREE_INT_CST_HIGH (tmp);
2866 lo = TREE_INT_CST_LOW (tmp);
2870 /* This will probably eat buckets of memory for large arrays. */
2871 while (hi != 0 || lo != 0)
2873 list = tree_cons (NULL_TREE, se.expr, list);
2881 /* Create a list of all the elements. */
2882 for (c = expr->value.constructor; c; c = c->next)
2886 /* Problems occur when we get something like
2887 integer :: a(lots) = (/(i, i=1,lots)/) */
2888 /* TODO: Unexpanded array initializers. */
2890 ("Possible frontend bug: array constructor not expanded");
2892 if (mpz_cmp_si (c->n.offset, 0) != 0)
2893 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2897 if (mpz_cmp_si (c->repeat, 0) != 0)
2901 mpz_set (maxval, c->repeat);
2902 mpz_add (maxval, c->n.offset, maxval);
2903 mpz_sub_ui (maxval, maxval, 1);
2904 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2905 if (mpz_cmp_si (c->n.offset, 0) != 0)
2907 mpz_add_ui (maxval, c->n.offset, 1);
2908 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2911 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2913 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
2919 gfc_init_se (&se, NULL);
2920 switch (c->expr->expr_type)
2923 gfc_conv_constant (&se, c->expr);
2924 if (range == NULL_TREE)
2925 list = tree_cons (index, se.expr, list);
2928 if (index != NULL_TREE)
2929 list = tree_cons (index, se.expr, list);
2930 list = tree_cons (range, se.expr, list);
2934 case EXPR_STRUCTURE:
2935 gfc_conv_structure (&se, c->expr, 1);
2936 list = tree_cons (index, se.expr, list);
2943 /* We created the list in reverse order. */
2944 list = nreverse (list);
2951 /* Create a constructor from the list of elements. */
2952 tmp = build1 (CONSTRUCTOR, type, list);
2953 TREE_CONSTANT (tmp) = 1;
2954 TREE_INVARIANT (tmp) = 1;
2959 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2960 returns the size (in elements) of the array. */
2963 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
2964 stmtblock_t * pblock)
2979 size = gfc_index_one_node;
2980 offset = gfc_index_zero_node;
2981 for (dim = 0; dim < as->rank; dim++)
2983 /* Evaluate non-constant array bound expressions. */
2984 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
2985 if (as->lower[dim] && !INTEGER_CST_P (lbound))
2987 gfc_init_se (&se, NULL);
2988 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
2989 gfc_add_block_to_block (pblock, &se.pre);
2990 gfc_add_modify_expr (pblock, lbound, se.expr);
2992 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
2993 if (as->upper[dim] && !INTEGER_CST_P (ubound))
2995 gfc_init_se (&se, NULL);
2996 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
2997 gfc_add_block_to_block (pblock, &se.pre);
2998 gfc_add_modify_expr (pblock, ubound, se.expr);
3000 /* The offset of this dimension. offset = offset - lbound * stride. */
3001 tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, lbound, size));
3002 offset = fold (build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp));
3004 /* The size of this dimension, and the stride of the next. */
3005 if (dim + 1 < as->rank)
3006 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3010 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3012 /* Calculate stride = size * (ubound + 1 - lbound). */
3013 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
3014 gfc_index_one_node, lbound));
3015 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp));
3016 tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
3018 gfc_add_modify_expr (pblock, stride, tmp);
3020 stride = gfc_evaluate_now (tmp, pblock);
3031 /* Generate code to initialize/allocate an array variable. */
3034 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3044 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3046 /* Do nothing for USEd variables. */
3047 if (sym->attr.use_assoc)
3050 type = TREE_TYPE (decl);
3051 gcc_assert (GFC_ARRAY_TYPE_P (type));
3052 onstack = TREE_CODE (type) != POINTER_TYPE;
3054 gfc_start_block (&block);
3056 /* Evaluate character string length. */
3057 if (sym->ts.type == BT_CHARACTER
3058 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3060 gfc_trans_init_string_length (sym->ts.cl, &block);
3062 /* Emit a DECL_EXPR for this variable, which will cause the
3063 gimplifier to allocate storage, and all that good stuff. */
3064 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3065 gfc_add_expr_to_block (&block, tmp);
3070 gfc_add_expr_to_block (&block, fnbody);
3071 return gfc_finish_block (&block);
3074 type = TREE_TYPE (type);
3076 gcc_assert (!sym->attr.use_assoc);
3077 gcc_assert (!TREE_STATIC (decl));
3078 gcc_assert (!sym->module[0]);
3080 if (sym->ts.type == BT_CHARACTER
3081 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3082 gfc_trans_init_string_length (sym->ts.cl, &block);
3084 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3086 /* The size is the number of elements in the array, so multiply by the
3087 size of an element to get the total size. */
3088 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3089 size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
3091 /* Allocate memory to hold the data. */
3092 tmp = gfc_chainon_list (NULL_TREE, size);
3094 if (gfc_index_integer_kind == 4)
3095 fndecl = gfor_fndecl_internal_malloc;
3096 else if (gfc_index_integer_kind == 8)
3097 fndecl = gfor_fndecl_internal_malloc64;
3100 tmp = gfc_build_function_call (fndecl, tmp);
3101 tmp = fold (convert (TREE_TYPE (decl), tmp));
3102 gfc_add_modify_expr (&block, decl, tmp);
3104 /* Set offset of the array. */
3105 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3106 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3109 /* Automatic arrays should not have initializers. */
3110 gcc_assert (!sym->value);
3112 gfc_add_expr_to_block (&block, fnbody);
3114 /* Free the temporary. */
3115 tmp = convert (pvoid_type_node, decl);
3116 tmp = gfc_chainon_list (NULL_TREE, tmp);
3117 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3118 gfc_add_expr_to_block (&block, tmp);
3120 return gfc_finish_block (&block);
3124 /* Generate entry and exit code for g77 calling convention arrays. */
3127 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3136 gfc_get_backend_locus (&loc);
3137 gfc_set_backend_locus (&sym->declared_at);
3139 /* Descriptor type. */
3140 parm = sym->backend_decl;
3141 type = TREE_TYPE (parm);
3142 gcc_assert (GFC_ARRAY_TYPE_P (type));
3144 gfc_start_block (&block);
3146 if (sym->ts.type == BT_CHARACTER
3147 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3148 gfc_trans_init_string_length (sym->ts.cl, &block);
3150 /* Evaluate the bounds of the array. */
3151 gfc_trans_array_bounds (type, sym, &offset, &block);
3153 /* Set the offset. */
3154 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3155 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3157 /* Set the pointer itself if we aren't using the parameter directly. */
3158 if (TREE_CODE (parm) != PARM_DECL)
3160 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3161 gfc_add_modify_expr (&block, parm, tmp);
3163 tmp = gfc_finish_block (&block);
3165 gfc_set_backend_locus (&loc);
3167 gfc_start_block (&block);
3168 /* Add the initialization code to the start of the function. */
3169 gfc_add_expr_to_block (&block, tmp);
3170 gfc_add_expr_to_block (&block, body);
3172 return gfc_finish_block (&block);
3176 /* Modify the descriptor of an array parameter so that it has the
3177 correct lower bound. Also move the upper bound accordingly.
3178 If the array is not packed, it will be copied into a temporary.
3179 For each dimension we set the new lower and upper bounds. Then we copy the
3180 stride and calculate the offset for this dimension. We also work out
3181 what the stride of a packed array would be, and see it the two match.
3182 If the array need repacking, we set the stride to the values we just
3183 calculated, recalculate the offset and copy the array data.
3184 Code is also added to copy the data back at the end of the function.
3188 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3195 stmtblock_t cleanup;
3213 /* Do nothing for pointer and allocatable arrays. */
3214 if (sym->attr.pointer || sym->attr.allocatable)
3217 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3218 return gfc_trans_g77_array (sym, body);
3220 gfc_get_backend_locus (&loc);
3221 gfc_set_backend_locus (&sym->declared_at);
3223 /* Descriptor type. */
3224 type = TREE_TYPE (tmpdesc);
3225 gcc_assert (GFC_ARRAY_TYPE_P (type));
3226 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3227 dumdesc = gfc_build_indirect_ref (dumdesc);
3228 gfc_start_block (&block);
3230 if (sym->ts.type == BT_CHARACTER
3231 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3232 gfc_trans_init_string_length (sym->ts.cl, &block);
3234 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3236 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3237 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3239 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3241 /* For non-constant shape arrays we only check if the first dimension
3242 is contiguous. Repacking higher dimensions wouldn't gain us
3243 anything as we still don't know the array stride. */
3244 partial = gfc_create_var (boolean_type_node, "partial");
3245 TREE_USED (partial) = 1;
3246 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3247 tmp = fold (build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node));
3248 gfc_add_modify_expr (&block, partial, tmp);
3252 partial = NULL_TREE;
3255 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3256 here, however I think it does the right thing. */
3259 /* Set the first stride. */
3260 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3261 stride = gfc_evaluate_now (stride, &block);
3263 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3264 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3265 gfc_index_one_node, stride);
3266 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3267 gfc_add_modify_expr (&block, stride, tmp);
3269 /* Allow the user to disable array repacking. */
3270 stmt_unpacked = NULL_TREE;
3274 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3275 /* A library call to repack the array if necessary. */
3276 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3277 tmp = gfc_chainon_list (NULL_TREE, tmp);
3278 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3280 stride = gfc_index_one_node;
3283 /* This is for the case where the array data is used directly without
3284 calling the repack function. */
3285 if (no_repack || partial != NULL_TREE)
3286 stmt_packed = gfc_conv_descriptor_data (dumdesc);
3288 stmt_packed = NULL_TREE;
3290 /* Assign the data pointer. */
3291 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3293 /* Don't repack unknown shape arrays when the first stride is 1. */
3294 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3295 stmt_packed, stmt_unpacked);
3298 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3299 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3301 offset = gfc_index_zero_node;
3302 size = gfc_index_one_node;
3304 /* Evaluate the bounds of the array. */
3305 for (n = 0; n < sym->as->rank; n++)
3307 if (checkparm || !sym->as->upper[n])
3309 /* Get the bounds of the actual parameter. */
3310 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3311 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3315 dubound = NULL_TREE;
3316 dlbound = NULL_TREE;
3319 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3320 if (!INTEGER_CST_P (lbound))
3322 gfc_init_se (&se, NULL);
3323 gfc_conv_expr_type (&se, sym->as->upper[n],
3324 gfc_array_index_type);
3325 gfc_add_block_to_block (&block, &se.pre);
3326 gfc_add_modify_expr (&block, lbound, se.expr);
3329 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3330 /* Set the desired upper bound. */
3331 if (sym->as->upper[n])
3333 /* We know what we want the upper bound to be. */
3334 if (!INTEGER_CST_P (ubound))
3336 gfc_init_se (&se, NULL);
3337 gfc_conv_expr_type (&se, sym->as->upper[n],
3338 gfc_array_index_type);
3339 gfc_add_block_to_block (&block, &se.pre);
3340 gfc_add_modify_expr (&block, ubound, se.expr);
3343 /* Check the sizes match. */
3346 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3348 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
3350 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3352 tmp = fold (build2 (NE_EXPR, gfc_array_index_type, tmp, stride));
3353 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3358 /* For assumed shape arrays move the upper bound by the same amount
3359 as the lower bound. */
3360 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3361 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound));
3362 gfc_add_modify_expr (&block, ubound, tmp);
3364 /* The offset of this dimension. offset = offset - lbound * stride. */
3365 tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, lbound, stride));
3366 offset = fold (build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp));
3368 /* The size of this dimension, and the stride of the next. */
3369 if (n + 1 < sym->as->rank)
3371 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3373 if (no_repack || partial != NULL_TREE)
3376 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3379 /* Figure out the stride if not a known constant. */
3380 if (!INTEGER_CST_P (stride))
3383 stmt_packed = NULL_TREE;
3386 /* Calculate stride = size * (ubound + 1 - lbound). */
3387 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
3388 gfc_index_one_node, lbound));
3389 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
3391 size = fold (build2 (MULT_EXPR, gfc_array_index_type,
3396 /* Assign the stride. */
3397 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3398 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3399 stmt_unpacked, stmt_packed);
3401 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3402 gfc_add_modify_expr (&block, stride, tmp);
3407 /* Set the offset. */
3408 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3409 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3411 stmt = gfc_finish_block (&block);
3413 gfc_start_block (&block);
3415 /* Only do the entry/initialization code if the arg is present. */
3416 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3417 optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master;
3420 tmp = gfc_conv_expr_present (sym);
3421 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3423 gfc_add_expr_to_block (&block, stmt);
3425 /* Add the main function body. */
3426 gfc_add_expr_to_block (&block, body);
3431 gfc_start_block (&cleanup);
3433 if (sym->attr.intent != INTENT_IN)
3435 /* Copy the data back. */
3436 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3437 tmp = gfc_chainon_list (tmp, tmpdesc);
3438 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3439 gfc_add_expr_to_block (&cleanup, tmp);
3442 /* Free the temporary. */
3443 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3444 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3445 gfc_add_expr_to_block (&cleanup, tmp);
3447 stmt = gfc_finish_block (&cleanup);
3449 /* Only do the cleanup if the array was repacked. */
3450 tmp = gfc_build_indirect_ref (dumdesc);
3451 tmp = gfc_conv_descriptor_data (tmp);
3452 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3453 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3457 tmp = gfc_conv_expr_present (sym);
3458 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3460 gfc_add_expr_to_block (&block, stmt);
3462 /* We don't need to free any memory allocated by internal_pack as it will
3463 be freed at the end of the function by pop_context. */
3464 return gfc_finish_block (&block);
3468 /* Convert an array for passing as an actual parameter. Expressions and
3469 vector subscripts are evaluated and stored in a temporary, which is then
3470 passed. For whole arrays the descriptor is passed. For array sections
3471 a modified copy of the descriptor is passed, but using the original data.
3472 Also used for array pointer assignments by setting se->direct_byref. */
3475 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3491 gcc_assert (ss != gfc_ss_terminator);
3493 /* TODO: Pass constant array constructors without a temporary. */
3494 /* Special case things we know we can pass easily. */
3495 switch (expr->expr_type)
3498 /* If we have a linear array section, we can pass it directly.
3499 Otherwise we need to copy it into a temporary. */
3501 /* Find the SS for the array section. */
3503 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3504 secss = secss->next;
3506 gcc_assert (secss != gfc_ss_terminator);
3509 for (n = 0; n < secss->data.info.dimen; n++)
3511 vss = secss->data.info.subscript[secss->data.info.dim[n]];
3512 if (vss && vss->type == GFC_SS_VECTOR)
3516 info = &secss->data.info;
3518 /* Get the descriptor for the array. */
3519 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3520 desc = info->descriptor;
3521 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3523 /* Create a new descriptor if the array doesn't have one. */
3526 else if (info->ref->u.ar.type == AR_FULL)
3528 else if (se->direct_byref)
3533 gcc_assert (ref->u.ar.type == AR_SECTION);
3536 for (n = 0; n < ref->u.ar.dimen; n++)
3538 /* Detect passing the full array as a section. This could do
3539 even more checking, but it doesn't seem worth it. */
3540 if (ref->u.ar.start[n]
3542 || (ref->u.ar.stride[n]
3543 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3551 /* Check for substring references. */
3553 if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
3557 if (ref->type == REF_SUBSTRING)
3559 /* In general character substrings need a copy. Character
3560 array strides are expressed as multiples of the element
3561 size (consistent with other array types), not in
3570 if (se->direct_byref)
3572 /* Copy the descriptor for pointer assignments. */
3573 gfc_add_modify_expr (&se->pre, se->expr, desc);
3575 else if (se->want_pointer)
3577 /* We pass full arrays directly. This means that pointers and
3578 allocatable arrays should also work. */
3579 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3586 if (expr->ts.type == BT_CHARACTER)
3587 se->string_length = gfc_get_expr_charlen (expr);
3594 /* A transformational function return value will be a temporary
3595 array descriptor. We still need to go through the scalarizer
3596 to create the descriptor. Elemental functions ar handled as
3597 arbitary expressions, i.e. copy to a temporary. */
3599 /* Look for the SS for this function. */
3600 while (secss != gfc_ss_terminator
3601 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3602 secss = secss->next;
3604 if (se->direct_byref)
3606 gcc_assert (secss != gfc_ss_terminator);
3608 /* For pointer assignments pass the descriptor directly. */
3610 se->expr = gfc_build_addr_expr (NULL, se->expr);
3611 gfc_conv_expr (se, expr);
3615 if (secss == gfc_ss_terminator)
3617 /* Elemental function. */
3623 /* Transformational function. */
3624 info = &secss->data.info;
3630 /* Something complicated. Copy it into a temporary. */
3638 gfc_init_loopinfo (&loop);
3640 /* Associate the SS with the loop. */
3641 gfc_add_ss_to_loop (&loop, ss);
3643 /* Tell the scalarizer not to bother creating loop variables, etc. */
3645 loop.array_parameter = 1;
3647 gcc_assert (se->want_pointer && !se->direct_byref);
3649 /* Setup the scalarizing loops and bounds. */
3650 gfc_conv_ss_startstride (&loop);
3654 /* Tell the scalarizer to make a temporary. */
3655 loop.temp_ss = gfc_get_ss ();
3656 loop.temp_ss->type = GFC_SS_TEMP;
3657 loop.temp_ss->next = gfc_ss_terminator;
3658 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
3659 /* ... which can hold our string, if present. */
3660 if (expr->ts.type == BT_CHARACTER)
3661 se->string_length = loop.temp_ss->string_length
3662 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3664 loop.temp_ss->string_length = NULL;
3665 loop.temp_ss->data.temp.dimen = loop.dimen;
3666 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3669 gfc_conv_loop_setup (&loop);
3673 /* Copy into a temporary and pass that. We don't need to copy the data
3674 back because expressions and vector subscripts must be INTENT_IN. */
3675 /* TODO: Optimize passing function return values. */
3679 /* Start the copying loops. */
3680 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3681 gfc_mark_ss_chain_used (ss, 1);
3682 gfc_start_scalarized_body (&loop, &block);
3684 /* Copy each data element. */
3685 gfc_init_se (&lse, NULL);
3686 gfc_copy_loopinfo_to_se (&lse, &loop);
3687 gfc_init_se (&rse, NULL);
3688 gfc_copy_loopinfo_to_se (&rse, &loop);
3690 lse.ss = loop.temp_ss;
3693 gfc_conv_scalarized_array_ref (&lse, NULL);
3694 gfc_conv_expr_val (&rse, expr);
3696 gfc_add_block_to_block (&block, &rse.pre);
3697 gfc_add_block_to_block (&block, &lse.pre);
3699 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3701 /* Finish the copying loops. */
3702 gfc_trans_scalarizing_loops (&loop, &block);
3704 /* Set the first stride component to zero to indicate a temporary. */
3705 desc = loop.temp_ss->data.info.descriptor;
3706 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
3707 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3709 gcc_assert (is_gimple_lvalue (desc));
3710 se->expr = gfc_build_addr_expr (NULL, desc);
3712 else if (expr->expr_type == EXPR_FUNCTION)
3714 desc = info->descriptor;
3716 if (se->want_pointer)
3717 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3721 if (expr->ts.type == BT_CHARACTER)
3722 se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
3726 /* We pass sections without copying to a temporary. Make a new
3727 descriptor and point it at the section we want. The loop variable
3728 limits will be the limits of the section.
3729 A function may decide to repack the array to speed up access, but
3730 we're not bothered about that here. */
3739 /* Set the string_length for a character array. */
3740 if (expr->ts.type == BT_CHARACTER)
3741 se->string_length = gfc_get_expr_charlen (expr);
3743 desc = info->descriptor;
3744 gcc_assert (secss && secss != gfc_ss_terminator);
3745 if (se->direct_byref)
3747 /* For pointer assignments we fill in the destination. */
3749 parmtype = TREE_TYPE (parm);
3753 /* Otherwise make a new one. */
3754 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3755 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3756 loop.from, loop.to, 0);
3757 parm = gfc_create_var (parmtype, "parm");
3760 offset = gfc_index_zero_node;
3763 /* The following can be somewhat confusing. We have two
3764 descriptors, a new one and the original array.
3765 {parm, parmtype, dim} refer to the new one.
3766 {desc, type, n, secss, loop} refer to the original, which maybe
3767 a descriptorless array.
3768 The bounds of the scaralization are the bounds of the section.
3769 We don't have to worry about numeric overflows when calculating
3770 the offsets because all elements are within the array data. */
3772 /* Set the dtype. */
3773 tmp = gfc_conv_descriptor_dtype (parm);
3774 gfc_add_modify_expr (&loop.pre, tmp, GFC_TYPE_ARRAY_DTYPE (parmtype));
3776 if (se->direct_byref)
3777 base = gfc_index_zero_node;
3781 for (n = 0; n < info->ref->u.ar.dimen; n++)
3783 stride = gfc_conv_array_stride (desc, n);
3785 /* Work out the offset. */
3786 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3788 gcc_assert (info->subscript[n]
3789 && info->subscript[n]->type == GFC_SS_SCALAR);
3790 start = info->subscript[n]->data.scalar.expr;
3794 /* Check we haven't somehow got out of sync. */
3795 gcc_assert (info->dim[dim] == n);
3797 /* Evaluate and remember the start of the section. */
3798 start = info->start[dim];
3799 stride = gfc_evaluate_now (stride, &loop.pre);
3802 tmp = gfc_conv_array_lbound (desc, n);
3803 tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp));
3805 tmp = fold (build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride));
3806 offset = fold (build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp));
3808 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3810 /* For elemental dimensions, we only need the offset. */
3814 /* Vector subscripts need copying and are handled elsewhere. */
3815 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
3817 /* Set the new lower bound. */
3818 from = loop.from[dim];
3820 if (!integer_onep (from))
3822 /* Make sure the new section starts at 1. */
3823 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
3824 gfc_index_one_node, from));
3825 to = fold (build2 (PLUS_EXPR, gfc_array_index_type, to, tmp));
3826 from = gfc_index_one_node;
3828 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
3829 gfc_add_modify_expr (&loop.pre, tmp, from);
3831 /* Set the new upper bound. */
3832 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
3833 gfc_add_modify_expr (&loop.pre, tmp, to);
3835 /* Multiply the stride by the section stride to get the
3837 stride = fold (build2 (MULT_EXPR, gfc_array_index_type,
3838 stride, info->stride[dim]));
3840 if (se->direct_byref)
3841 base = fold (build2 (MINUS_EXPR, TREE_TYPE (base),
3844 /* Store the new stride. */
3845 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
3846 gfc_add_modify_expr (&loop.pre, tmp, stride);
3851 /* Point the data pointer at the first element in the section. */
3852 tmp = gfc_conv_array_data (desc);
3853 tmp = gfc_build_indirect_ref (tmp);
3854 tmp = gfc_build_array_ref (tmp, offset);
3855 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
3857 tmp = gfc_conv_descriptor_data (parm);
3858 gfc_add_modify_expr (&loop.pre, tmp,
3859 fold_convert (TREE_TYPE (tmp), offset));
3861 if (se->direct_byref)
3863 /* Set the offset. */
3864 tmp = gfc_conv_descriptor_offset (parm);
3865 gfc_add_modify_expr (&loop.pre, tmp, base);
3869 /* Only the callee knows what the correct offset it, so just set
3871 tmp = gfc_conv_descriptor_offset (parm);
3872 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3875 if (!se->direct_byref)
3877 /* Get a pointer to the new descriptor. */
3878 if (se->want_pointer)
3879 se->expr = gfc_build_addr_expr (NULL, parm);
3885 gfc_add_block_to_block (&se->pre, &loop.pre);
3886 gfc_add_block_to_block (&se->post, &loop.post);
3888 /* Cleanup the scalarizer. */
3889 gfc_cleanup_loop (&loop);
3893 /* Convert an array for passing as an actual parameter. */
3894 /* TODO: Optimize passing g77 arrays. */
3897 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
3906 /* Passing address of the array if it is not pointer or assumed-shape. */
3907 if (expr->expr_type == EXPR_VARIABLE
3908 && expr->ref->u.ar.type == AR_FULL && g77)
3910 sym = expr->symtree->n.sym;
3911 tmp = gfc_get_symbol_decl (sym);
3912 if (sym->ts.type == BT_CHARACTER)
3913 se->string_length = sym->ts.cl->backend_decl;
3914 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
3915 && !sym->attr.allocatable)
3917 /* Some variables are declared directly, others are declared as
3918 pointers and allocated on the heap. */
3919 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
3922 se->expr = gfc_build_addr_expr (NULL, tmp);
3925 if (sym->attr.allocatable)
3927 se->expr = gfc_conv_array_data (tmp);
3932 se->want_pointer = 1;
3933 gfc_conv_expr_descriptor (se, expr, ss);
3938 /* Repack the array. */
3939 tmp = gfc_chainon_list (NULL_TREE, desc);
3940 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3941 ptr = gfc_evaluate_now (ptr, &se->pre);
3944 gfc_start_block (&block);
3946 /* Copy the data back. */
3947 tmp = gfc_chainon_list (NULL_TREE, desc);
3948 tmp = gfc_chainon_list (tmp, ptr);
3949 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3950 gfc_add_expr_to_block (&block, tmp);
3952 /* Free the temporary. */
3953 tmp = convert (pvoid_type_node, ptr);
3954 tmp = gfc_chainon_list (NULL_TREE, tmp);
3955 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3956 gfc_add_expr_to_block (&block, tmp);
3958 stmt = gfc_finish_block (&block);
3960 gfc_init_block (&block);
3961 /* Only if it was repacked. This code needs to be executed before the
3962 loop cleanup code. */
3963 tmp = gfc_build_indirect_ref (desc);
3964 tmp = gfc_conv_array_data (tmp);
3965 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
3966 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3968 gfc_add_expr_to_block (&block, tmp);
3969 gfc_add_block_to_block (&block, &se->post);
3971 gfc_init_block (&se->post);
3972 gfc_add_block_to_block (&se->post, &block);
3977 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3980 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
3987 stmtblock_t fnblock;
3990 /* Make sure the frontend gets these right. */
3991 if (!(sym->attr.pointer || sym->attr.allocatable))
3993 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3995 gfc_init_block (&fnblock);
3997 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
3998 if (sym->ts.type == BT_CHARACTER
3999 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4000 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4002 /* Parameter variables don't need anything special. */
4003 if (sym->attr.dummy)
4005 gfc_add_expr_to_block (&fnblock, body);
4007 return gfc_finish_block (&fnblock);
4010 gfc_get_backend_locus (&loc);
4011 gfc_set_backend_locus (&sym->declared_at);
4012 descriptor = sym->backend_decl;
4014 if (TREE_STATIC (descriptor))
4016 /* SAVEd variables are not freed on exit. */
4017 gfc_trans_static_array_pointer (sym);
4021 /* Get the descriptor type. */
4022 type = TREE_TYPE (sym->backend_decl);
4023 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4025 /* NULLIFY the data pointer. */
4026 tmp = gfc_conv_descriptor_data (descriptor);
4027 gfc_add_modify_expr (&fnblock, tmp,
4028 convert (TREE_TYPE (tmp), integer_zero_node));
4030 gfc_add_expr_to_block (&fnblock, body);
4032 gfc_set_backend_locus (&loc);
4033 /* Allocatable arrays need to be freed when they go out of scope. */
4034 if (sym->attr.allocatable)
4036 gfc_start_block (&block);
4038 /* Deallocate if still allocated at the end of the procedure. */
4039 deallocate = gfc_array_deallocate (descriptor);
4041 tmp = gfc_conv_descriptor_data (descriptor);
4042 tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_zero_node);
4043 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4044 gfc_add_expr_to_block (&block, tmp);
4046 tmp = gfc_finish_block (&block);
4047 gfc_add_expr_to_block (&fnblock, tmp);
4050 return gfc_finish_block (&fnblock);
4053 /************ Expression Walking Functions ******************/
4055 /* Walk a variable reference.
4057 Possible extension - multiple component subscripts.
4058 x(:,:) = foo%a(:)%b(:)
4060 forall (i=..., j=...)
4061 x(i,j) = foo%a(j)%b(i)
4063 This adds a fair amout of complexity because you need to deal with more
4064 than one ref. Maybe handle in a similar manner to vector subscripts.
4065 Maybe not worth the effort. */
4069 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4077 for (ref = expr->ref; ref; ref = ref->next)
4079 /* We're only interested in array sections. */
4080 if (ref->type != REF_ARRAY)
4087 /* TODO: Take elemental array references out of scalarization
4092 newss = gfc_get_ss ();
4093 newss->type = GFC_SS_SECTION;
4096 newss->data.info.dimen = ar->as->rank;
4097 newss->data.info.ref = ref;
4099 /* Make sure array is the same as array(:,:), this way
4100 we don't need to special case all the time. */
4101 ar->dimen = ar->as->rank;
4102 for (n = 0; n < ar->dimen; n++)
4104 newss->data.info.dim[n] = n;
4105 ar->dimen_type[n] = DIMEN_RANGE;
4107 gcc_assert (ar->start[n] == NULL);
4108 gcc_assert (ar->end[n] == NULL);
4109 gcc_assert (ar->stride[n] == NULL);
4114 newss = gfc_get_ss ();
4115 newss->type = GFC_SS_SECTION;
4118 newss->data.info.dimen = 0;
4119 newss->data.info.ref = ref;
4123 /* We add SS chains for all the subscripts in the section. */
4124 for (n = 0; n < ar->dimen; n++)
4128 switch (ar->dimen_type[n])
4131 /* Add SS for elemental (scalar) subscripts. */
4132 gcc_assert (ar->start[n]);
4133 indexss = gfc_get_ss ();
4134 indexss->type = GFC_SS_SCALAR;
4135 indexss->expr = ar->start[n];
4136 indexss->next = gfc_ss_terminator;
4137 indexss->loop_chain = gfc_ss_terminator;
4138 newss->data.info.subscript[n] = indexss;
4142 /* We don't add anything for sections, just remember this
4143 dimension for later. */
4144 newss->data.info.dim[newss->data.info.dimen] = n;
4145 newss->data.info.dimen++;
4149 /* Get a SS for the vector. This will not be added to the
4151 indexss = gfc_walk_expr (ar->start[n]);
4152 if (indexss == gfc_ss_terminator)
4153 internal_error ("scalar vector subscript???");
4155 /* We currently only handle really simple vector
4157 if (indexss->next != gfc_ss_terminator)
4158 gfc_todo_error ("vector subscript expressions");
4159 indexss->loop_chain = gfc_ss_terminator;
4161 /* Mark this as a vector subscript. We don't add this
4162 directly into the chain, but as a subscript of the
4163 existing SS for this term. */
4164 indexss->type = GFC_SS_VECTOR;
4165 newss->data.info.subscript[n] = indexss;
4166 /* Also remember this dimension. */
4167 newss->data.info.dim[newss->data.info.dimen] = n;
4168 newss->data.info.dimen++;
4172 /* We should know what sort of section it is by now. */
4176 /* We should have at least one non-elemental dimension. */
4177 gcc_assert (newss->data.info.dimen > 0);
4182 /* We should know what sort of section it is by now. */
4191 /* Walk an expression operator. If only one operand of a binary expression is
4192 scalar, we must also add the scalar term to the SS chain. */
4195 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4201 head = gfc_walk_subexpr (ss, expr->op1);
4202 if (expr->op2 == NULL)
4205 head2 = gfc_walk_subexpr (head, expr->op2);
4207 /* All operands are scalar. Pass back and let the caller deal with it. */
4211 /* All operands require scalarization. */
4212 if (head != ss && (expr->op2 == NULL || head2 != head))
4215 /* One of the operands needs scalarization, the other is scalar.
4216 Create a gfc_ss for the scalar expression. */
4217 newss = gfc_get_ss ();
4218 newss->type = GFC_SS_SCALAR;
4221 /* First operand is scalar. We build the chain in reverse order, so
4222 add the scarar SS after the second operand. */
4224 while (head && head->next != ss)
4226 /* Check we haven't somehow broken the chain. */
4230 newss->expr = expr->op1;
4232 else /* head2 == head */
4234 gcc_assert (head2 == head);
4235 /* Second operand is scalar. */
4236 newss->next = head2;
4238 newss->expr = expr->op2;
4245 /* Reverse a SS chain. */
4248 gfc_reverse_ss (gfc_ss * ss)
4253 gcc_assert (ss != NULL);
4255 head = gfc_ss_terminator;
4256 while (ss != gfc_ss_terminator)
4259 /* Check we didn't somehow break the chain. */
4260 gcc_assert (next != NULL);
4270 /* Walk the arguments of an elemental function. */
4273 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4276 gfc_actual_arglist *arg;
4282 head = gfc_ss_terminator;
4285 for (arg = expr->value.function.actual; arg; arg = arg->next)
4290 newss = gfc_walk_subexpr (head, arg->expr);
4293 /* Scalar argument. */
4294 newss = gfc_get_ss ();
4296 newss->expr = arg->expr;
4306 while (tail->next != gfc_ss_terminator)
4313 /* If all the arguments are scalar we don't need the argument SS. */
4314 gfc_free_ss_chain (head);
4319 /* Add it onto the existing chain. */
4325 /* Walk a function call. Scalar functions are passed back, and taken out of
4326 scalarization loops. For elemental functions we walk their arguments.
4327 The result of functions returning arrays is stored in a temporary outside
4328 the loop, so that the function is only called once. Hence we do not need
4329 to walk their arguments. */
4332 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4335 gfc_intrinsic_sym *isym;
4338 isym = expr->value.function.isym;
4340 /* Handle intrinsic functions separately. */
4342 return gfc_walk_intrinsic_function (ss, expr, isym);
4344 sym = expr->value.function.esym;
4346 sym = expr->symtree->n.sym;
4348 /* A function that returns arrays. */
4349 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4351 newss = gfc_get_ss ();
4352 newss->type = GFC_SS_FUNCTION;
4355 newss->data.info.dimen = expr->rank;
4359 /* Walk the parameters of an elemental function. For now we always pass
4361 if (sym->attr.elemental)
4362 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4364 /* Scalar functions are OK as these are evaluated outside the scalarisation
4365 loop. Pass back and let the caller deal with it. */
4370 /* An array temporary is constructed for array constructors. */
4373 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4378 newss = gfc_get_ss ();
4379 newss->type = GFC_SS_CONSTRUCTOR;
4382 newss->data.info.dimen = expr->rank;
4383 for (n = 0; n < expr->rank; n++)
4384 newss->data.info.dim[n] = n;
4390 /* Walk an expression. Add walked expressions to the head of the SS chain.
4391 A wholy scalar expression will not be added. */
4394 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4398 switch (expr->expr_type)
4401 head = gfc_walk_variable_expr (ss, expr);
4405 head = gfc_walk_op_expr (ss, expr);
4409 head = gfc_walk_function_expr (ss, expr);
4414 case EXPR_STRUCTURE:
4415 /* Pass back and let the caller deal with it. */
4419 head = gfc_walk_array_constructor (ss, expr);
4422 case EXPR_SUBSTRING:
4423 /* Pass back and let the caller deal with it. */
4427 internal_error ("bad expression type during walk (%d)",
4434 /* Entry point for expression walking.
4435 A return value equal to the passed chain means this is
4436 a scalar expression. It is up to the caller to take whatever action is
4437 necessary to translate these. */
4440 gfc_walk_expr (gfc_expr * expr)
4444 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4445 return gfc_reverse_ss (res);